summaryrefslogtreecommitdiff
path: root/system
diff options
context:
space:
mode:
Diffstat (limited to 'system')
-rw-r--r--system/base/1.7.5/source-disk1
-rw-r--r--system/base/1.7.5/src/advertising35
-rw-r--r--system/base/1.7.5/src/basic transput177
-rw-r--r--system/base/1.7.5/src/bits78
-rw-r--r--system/base/1.7.5/src/bool16
-rw-r--r--system/base/1.7.5/src/command dialogue123
-rw-r--r--system/base/1.7.5/src/command handler290
-rw-r--r--system/base/1.7.5/src/dataspace74
-rw-r--r--system/base/1.7.5/src/date handling303
-rw-r--r--system/base/1.7.5/src/editor2959
-rw-r--r--system/base/1.7.5/src/elan do interface57
-rw-r--r--system/base/1.7.5/src/error handling142
-rw-r--r--system/base/1.7.5/src/eumel coder part 1866
-rw-r--r--system/base/1.7.5/src/file2122
-rw-r--r--system/base/1.7.5/src/functions760
-rw-r--r--system/base/1.7.5/src/init251
-rw-r--r--system/base/1.7.5/src/integer265
-rw-r--r--system/base/1.7.5/src/local manager373
-rw-r--r--system/base/1.7.5/src/local manager 241
-rw-r--r--system/base/1.7.5/src/mathlib268
-rw-r--r--system/base/1.7.5/src/pattern match768
-rw-r--r--system/base/1.7.5/src/pcb control79
-rw-r--r--system/base/1.7.5/src/real442
-rw-r--r--system/base/1.7.5/src/scanner325
-rw-r--r--system/base/1.7.5/src/screen33
-rw-r--r--system/base/1.7.5/src/std transput264
-rw-r--r--system/base/1.7.5/src/tasten113
-rw-r--r--system/base/1.7.5/src/text391
-rw-r--r--system/base/1.7.5/src/texter errors284
-rw-r--r--system/base/1.7.5/src/thesaurus332
-rw-r--r--system/dos/1.8.7/doc/dos-dat-handbuch650
-rw-r--r--system/dos/1.8.7/source-disk1
-rw-r--r--system/dos/1.8.7/src/block i-o180
-rw-r--r--system/dos/1.8.7/src/bpb dsbin0 -> 2048 bytes
-rw-r--r--system/dos/1.8.7/src/dir.dos693
-rw-r--r--system/dos/1.8.7/src/disk descriptor.dos339
-rw-r--r--system/dos/1.8.7/src/dos hd inserter41
-rw-r--r--system/dos/1.8.7/src/dos inserter59
-rw-r--r--system/dos/1.8.7/src/dump49
-rw-r--r--system/dos/1.8.7/src/eu disk descriptor107
-rw-r--r--system/dos/1.8.7/src/fat.dos369
-rw-r--r--system/dos/1.8.7/src/fetch371
-rw-r--r--system/dos/1.8.7/src/fetch save interface70
-rw-r--r--system/dos/1.8.7/src/get put interface.dos368
-rw-r--r--system/dos/1.8.7/src/insert.dos14
-rw-r--r--system/dos/1.8.7/src/konvert75
-rw-r--r--system/dos/1.8.7/src/manager-M.dos211
-rw-r--r--system/dos/1.8.7/src/manager-S.dos268
-rw-r--r--system/dos/1.8.7/src/name conversion.dos77
-rw-r--r--system/dos/1.8.7/src/open66
-rw-r--r--system/dos/1.8.7/src/save233
-rw-r--r--system/dos/1.8.7/src/shard interface20
-rw-r--r--system/eumel-coder/1.8.0/src/eumel coder 1.8.02594
-rw-r--r--system/eumel-coder/1.8.0/src/eumel coder 1.8.0_mod2043
-rw-r--r--system/eumel-coder/1.8.0/src/eumel0 codes50
-rw-r--r--system/eumel-coder/1.8.1/source-disk1
-rw-r--r--system/eumel-coder/1.8.1/src/eumel coder 1.8.13086
-rw-r--r--system/multiuser/1.7.5/source-disk2
-rw-r--r--system/multiuser/1.7.5/src/archive92
-rw-r--r--system/multiuser/1.7.5/src/archive manager670
-rw-r--r--system/multiuser/1.7.5/src/basic archive401
-rw-r--r--system/multiuser/1.7.5/src/canal227
-rw-r--r--system/multiuser/1.7.5/src/configuration manager553
-rw-r--r--system/multiuser/1.7.5/src/eumel printer3066
-rw-r--r--system/multiuser/1.7.5/src/font store695
-rw-r--r--system/multiuser/1.7.5/src/global manager683
-rw-r--r--system/multiuser/1.7.5/src/indexer1142
-rw-r--r--system/multiuser/1.7.5/src/konfigurieren254
-rw-r--r--system/multiuser/1.7.5/src/liner3079
-rw-r--r--system/multiuser/1.7.5/src/macro store298
-rw-r--r--system/multiuser/1.7.5/src/multi user monitor93
-rw-r--r--system/multiuser/1.7.5/src/nameset355
-rw-r--r--system/multiuser/1.7.5/src/pager2451
-rw-r--r--system/multiuser/1.7.5/src/print cmd29
-rw-r--r--system/multiuser/1.7.5/src/priv ops268
-rw-r--r--system/multiuser/1.7.5/src/silbentrennung1166
-rw-r--r--system/multiuser/1.7.5/src/spool manager887
-rw-r--r--system/multiuser/1.7.5/src/supervisor774
-rw-r--r--system/multiuser/1.7.5/src/sysgen off9
-rw-r--r--system/multiuser/1.7.5/src/system info342
-rw-r--r--system/multiuser/1.7.5/src/system manager117
-rw-r--r--system/multiuser/1.7.5/src/tasks978
-rw-r--r--system/multiuser/1.7.5/src/ur start40
-rw-r--r--system/net/1.7.5/doc/EUMEL Netz832
-rw-r--r--system/net/1.7.5/src/basic net840
-rw-r--r--system/net/1.7.5/src/callee14
-rw-r--r--system/net/1.7.5/src/net inserter50
-rw-r--r--system/net/1.7.5/src/net manager-M302
-rw-r--r--system/net/1.7.5/src/net report-M29
-rw-r--r--system/net/1.8.7/doc/netzhandbuch2045
-rw-r--r--system/net/1.8.7/doc/netzhandbuch.anhang58
-rw-r--r--system/net/1.8.7/doc/netzhandbuch.index259
-rw-r--r--system/net/1.8.7/source-disk1
-rw-r--r--system/net/1.8.7/src/basic net1148
-rw-r--r--system/net/1.8.7/src/net files-M5
-rw-r--r--system/net/1.8.7/src/net hardware interface389
-rw-r--r--system/net/1.8.7/src/net inserter145
-rw-r--r--system/net/1.8.7/src/net manager797
-rw-r--r--system/net/1.8.7/src/net report41
-rw-r--r--system/net/1.8.7/src/netz20
-rw-r--r--system/net/1.8.7/src/port server164
-rw-r--r--system/net/1.8.7/src/printer server99
-rw-r--r--system/net/1.8.7/src/spool cmd112
-rw-r--r--system/net/1.8.7/src/spool manager915
-rw-r--r--system/net/unknown/doc/EUMEL Netz829
-rw-r--r--system/printer-24nadel/0.9/doc/readme320
-rw-r--r--system/printer-24nadel/0.9/source-disk3
-rw-r--r--system/printer-24nadel/0.9/src/beschreibungen2462
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.brotherbin0 -> 38400 bytes
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.epson.lq1500bin0 -> 35840 bytes
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.epson.lq850bin0 -> 38400 bytes
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.nec.p5bin0 -> 39936 bytes
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.nec.p5.newbin0 -> 39936 bytes
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.nec.p6+bin0 -> 48128 bytes
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.okibin0 -> 38400 bytes
-rw-r--r--system/printer-24nadel/0.9/src/fonttab.toshiba.p321bin0 -> 15872 bytes
-rw-r--r--system/printer-24nadel/0.9/src/inserter793
-rw-r--r--system/printer-24nadel/0.9/src/module241554
-rw-r--r--system/printer-24nadel/0.9/src/printer.24.nadel776
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/doc/readme320
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/beschreibungen2462
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.brotherbin0 -> 38400 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq1500bin0 -> 35840 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq850bin0 -> 38400 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5bin0 -> 39936 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5.newbin0 -> 39936 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p6+bin0 -> 48128 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.okibin0 -> 38400 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/fonttab.toshiba.p321bin0 -> 15872 bytes
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/inserter793
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/module241554
-rw-r--r--system/printer-24nadel/schulis-mathe-1.0/src/printer.24.nadel776
l---------system/printer-24nadel/schulis-sim-3.01
-rw-r--r--system/printer-9nadel/0.9/doc/readme324
-rw-r--r--system/printer-9nadel/0.9/source-disk1
-rw-r--r--system/printer-9nadel/0.9/src/beschreibungen997
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.1bin0 -> 11264 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.10bin0 -> 15872 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.20bin0 -> 36864 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.20.lcbin0 -> 36864 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.20.lxbin0 -> 24576 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.7bin0 -> 46080 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.7.cxpbin0 -> 46080 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.7.fujbin0 -> 56832 bytes
-rw-r--r--system/printer-9nadel/0.9/src/fonttab.7.mtbin0 -> 46080 bytes
-rw-r--r--system/printer-9nadel/0.9/src/module91099
-rw-r--r--system/printer-9nadel/0.9/src/printer.neun.nadel1129
-rw-r--r--system/printer-laser/4/doc/readme155
-rw-r--r--system/printer-laser/4/source-disk1
-rw-r--r--system/printer-laser/4/src/fonttab.apple.laserwriterbin0 -> 100864 bytes
-rw-r--r--system/printer-laser/4/src/fonttab.canon.lbp-8bin0 -> 58368 bytes
-rw-r--r--system/printer-laser/4/src/fonttab.epson.sqbin0 -> 29696 bytes
-rw-r--r--system/printer-laser/4/src/fonttab.hp.laserjetbin0 -> 24064 bytes
-rw-r--r--system/printer-laser/4/src/fonttab.kyocera.f-1010bin0 -> 71168 bytes
-rw-r--r--system/printer-laser/4/src/fonttab.nec.lc-08bin0 -> 38400 bytes
-rw-r--r--system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic130
-rw-r--r--system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic230
-rw-r--r--system/printer-laser/4/src/laser.inserter275
-rw-r--r--system/printer-laser/4/src/printer.apple.laserwriter770
-rw-r--r--system/printer-laser/4/src/printer.canon.lbp-8327
-rw-r--r--system/printer-laser/4/src/printer.epson.sq585
-rw-r--r--system/printer-laser/4/src/printer.hp.laserjet417
-rw-r--r--system/printer-laser/4/src/printer.kyocera.f-1010373
-rw-r--r--system/printer-laser/4/src/printer.nec.lc-08626
-rw-r--r--system/setup/3.1/source-disk1
-rw-r--r--system/setup/3.1/src/AT-4.xbin0 -> 1024 bytes
-rw-r--r--system/setup/3.1/src/SHARDbin0 -> 7680 bytes
-rw-r--r--system/setup/3.1/src/SHard Basisbin0 -> 7680 bytes
-rw-r--r--system/setup/3.1/src/bootblockbin0 -> 4608 bytes
-rw-r--r--system/setup/3.1/src/configuration2
-rw-r--r--system/setup/3.1/src/neu34
-rw-r--r--system/setup/3.1/src/setup eumel -1: mini eumel dummies28
-rw-r--r--system/setup/3.1/src/setup eumel 0: -M32
-rw-r--r--system/setup/3.1/src/setup eumel 0: -S35
-rw-r--r--system/setup/3.1/src/setup eumel 1: basisoperationen1071
-rw-r--r--system/setup/3.1/src/setup eumel 2: modulzugriffe441
-rw-r--r--system/setup/3.1/src/setup eumel 3: modulkonfiguration854
-rw-r--r--system/setup/3.1/src/setup eumel 4: dienstprogramme218
-rw-r--r--system/setup/3.1/src/setup eumel 5: partitionierung435
-rw-r--r--system/setup/3.1/src/setup eumel 6: shardmontage389
-rw-r--r--system/setup/3.1/src/setup eumel 7: setupeumel1238
-rw-r--r--system/setup/3.1/src/setup eumel erzeugen15
-rw-r--r--system/setup/3.1/src/setup eumel erzeugen-M14
-rw-r--r--system/setup/3.1/src/shget.exebin0 -> 1536 bytes
-rw-r--r--system/std.graphik/1.8.7/doc/Altes Handbuch - Teil 10 - Graphik831
-rw-r--r--system/std.graphik/1.8.7/doc/GRAPHIK.book897
-rw-r--r--system/std.graphik/1.8.7/doc/graphik beschreibung661
-rw-r--r--system/std.graphik/1.8.7/source-disk1
-rw-r--r--system/std.graphik/1.8.7/src/Beispiel.Kreuz41
-rw-r--r--system/std.graphik/1.8.7/src/Beispiel.Sinus45
-rw-r--r--system/std.graphik/1.8.7/src/GRAPHIK.Picfile738
-rw-r--r--system/std.graphik/1.8.7/src/GRAPHIK.Plot285
-rw-r--r--system/std.graphik/1.8.7/src/GRAPHIK.Plotter247
-rw-r--r--system/std.graphik/1.8.7/src/GRAPHIK.Server97
-rw-r--r--system/std.graphik/1.8.7/src/GRAPHIK.Transform366
-rw-r--r--system/std.graphik/1.8.7/src/GRAPHIK.vektor plot506
-rw-r--r--system/std.graphik/1.8.7/src/HP7475.plot254
-rw-r--r--system/std.graphik/1.8.7/src/PC.plot758
-rw-r--r--system/std.graphik/1.8.7/src/ZEICHENSATZbin0 -> 11776 bytes
-rw-r--r--system/std.graphik/1.8.7/src/gen Graphik16
-rw-r--r--system/std.graphik/1.8.7/src/gen Plotter16
-rw-r--r--system/std.graphik/1.8.7/src/graphik editor324
-rw-r--r--system/std.zusatz/1.8.7/source-disk1
-rw-r--r--system/std.zusatz/1.8.7/src/AT Generator135
-rw-r--r--system/std.zusatz/1.8.7/src/AT Utilities1057
-rw-r--r--system/std.zusatz/1.8.7/src/AT install93
-rw-r--r--system/std.zusatz/1.8.7/src/complex115
-rw-r--r--system/std.zusatz/1.8.7/src/crypt138
-rw-r--r--system/std.zusatz/1.8.7/src/eumel printer.53473
-rw-r--r--system/std.zusatz/1.8.7/src/eumelmeter131
-rw-r--r--system/std.zusatz/1.8.7/src/font convertor 91095
-rw-r--r--system/std.zusatz/1.8.7/src/free channel430
-rw-r--r--system/std.zusatz/1.8.7/src/longint423
-rw-r--r--system/std.zusatz/1.8.7/src/matrix482
-rw-r--r--system/std.zusatz/1.8.7/src/port server164
-rw-r--r--system/std.zusatz/1.8.7/src/printer server99
-rw-r--r--system/std.zusatz/1.8.7/src/purge85
-rw-r--r--system/std.zusatz/1.8.7/src/referencer1077
-rw-r--r--system/std.zusatz/1.8.7/src/reporter531
-rw-r--r--system/std.zusatz/1.8.7/src/scheduler420
-rw-r--r--system/std.zusatz/1.8.7/src/spool cmd178
-rw-r--r--system/std.zusatz/1.8.7/src/spool manager1058
-rw-r--r--system/std.zusatz/1.8.7/src/std analysator68
-rw-r--r--system/std.zusatz/1.8.7/src/vector213
224 files changed, 87641 insertions, 0 deletions
diff --git a/system/base/1.7.5/source-disk b/system/base/1.7.5/source-disk
new file mode 100644
index 0000000..5708023
--- /dev/null
+++ b/system/base/1.7.5/source-disk
@@ -0,0 +1 @@
+175_src/source-code-1.7.5.img
diff --git a/system/base/1.7.5/src/advertising b/system/base/1.7.5/src/advertising
new file mode 100644
index 0000000..45f73ef
--- /dev/null
+++ b/system/base/1.7.5/src/advertising
@@ -0,0 +1,35 @@
+(* ------------------- VERSION 1 06.03.86 ------------------- *)
+PACKET advertising DEFINES (* Autor: J.Liedtke *)
+
+ eumel must advertise :
+
+
+LET myself id field = 9 ;
+
+
+PROC eumel must advertise :
+
+ IF online AND channel <= 15
+ THEN out (""1""4"") ;
+ IF station is not zero
+ THEN out (""15"Station: ") ;
+ out (text (station number)) ;
+ out (" "14"")
+ FI ;
+ cursor (60,1) ;
+ out (""15"Terminal: ") ;
+ out (text (channel)) ;
+ out (" "14"") ;
+ cursor (22,5) ;
+ (* out ("E U M E L Pilot-Version /M"13""10""10""10"") *)
+ out ("E U M E L Version 1.7.5.10 /M+ "13""10""10""10"")
+ FI .
+
+station is not zero : pcb (myself id field) >= 256 .
+
+station number : pcb (myself id field) DIV 256 .
+
+ENDPROC eumel must advertise ;
+
+ENDPACKET advertising ;
+
diff --git a/system/base/1.7.5/src/basic transput b/system/base/1.7.5/src/basic transput
new file mode 100644
index 0000000..5608bb1
--- /dev/null
+++ b/system/base/1.7.5/src/basic transput
@@ -0,0 +1,177 @@
+
+PACKET basic transput DEFINES
+ out ,
+ outsubtext ,
+ outtext ,
+ TIMESOUT ,
+ cout ,
+ display ,
+ inchar ,
+ incharety ,
+ cat input ,
+ pause ,
+ cursor ,
+ get cursor ,
+ channel ,
+ online ,
+ control ,
+ blockout ,
+ blockin :
+
+
+
+LET channel field = 4 ,
+ blank times 64 =
+ " " ;
+
+LET BLOCKIO = STRUCT (ALIGN page align, ROW 256 INT buffer) ,
+ buffer page = 2 ;
+
+BOUND BLOCKIO VAR block io ;
+DATASPACE VAR block io ds ;
+INITFLAG VAR this packet := FALSE ;
+
+
+PROC out (TEXT CONST text ) :
+ EXTERNAL 60
+ENDPROC out ;
+
+PROC outsubtext ( TEXT CONST source, INT CONST from ) :
+ EXTERNAL 62
+END PROC outsubtext;
+
+PROC outsubtext (TEXT CONST source, INT CONST from, to) :
+ EXTERNAL 63
+END PROC outsubtext;
+
+PROC outtext ( TEXT CONST source, INT CONST from, to ) :
+ out subtext (source, from, to) ;
+ INT VAR trailing ;
+ IF from <= LENGTH source
+ THEN trailing := to - LENGTH source
+ ELSE trailing := to + 1 - from
+ FI ;
+ IF trailing > 0
+ THEN trailing TIMESOUT " "
+ FI
+ENDPROC outtext ;
+
+OP TIMESOUT (INT CONST times, TEXT CONST text) :
+
+ IF text = " "
+ THEN fast timesout blank
+ ELSE timesout
+ FI .
+
+fast timesout blank :
+ INT VAR i := 0 ;
+ WHILE i + 64 < times REP
+ out (blank times 64) ;
+ i INCR 64
+ PER ;
+ outsubtext (blank times 64, 1, times - i) .
+
+timesout :
+ FOR i FROM 1 UPTO times REP
+ out(text)
+ ENDREP .
+
+ENDOP TIMESOUT ;
+
+PROC display (TEXT CONST text) :
+ IF online
+ THEN out (text)
+ FI
+ENDPROC display ;
+
+PROC inchar (TEXT VAR character ) :
+ EXTERNAL 64
+ENDPROC inchar ;
+
+TEXT PROC incharety :
+ EXTERNAL 65
+END PROC incharety ;
+
+TEXT PROC incharety (INT CONST time limit) :
+ internal pause (time limit) ;
+ incharety
+ENDPROC incharety ;
+
+PROC pause (INT CONST time limit) :
+ internal pause (time limit) ;
+ TEXT CONST dummy := incharety
+ENDPROC pause ;
+
+PROC pause :
+ TEXT VAR dummy; inchar (dummy)
+ENDPROC pause ;
+
+PROC internal pause (INT CONST time limit) :
+ EXTERNAL 66
+ENDPROC internal pause ;
+
+PROC cat input (TEXT VAR t, esc char) :
+ EXTERNAL 68
+ENDPROC cat input ;
+
+
+PROC cursor (INT CONST x, y) :
+ out (""6"") ;
+ out (code(y-1)) ;
+ out (code(x-1)) ;
+ENDPROC cursor ;
+
+PROC get cursor (INT VAR x, y) :
+ EXTERNAL 67
+ENDPROC get cursor ;
+
+PROC cout (INT CONST number) :
+ EXTERNAL 61
+ENDPROC cout ;
+
+
+INT PROC channel :
+ pcb (channel field)
+ENDPROC channel ;
+
+BOOL PROC online :
+ pcb (channel field) <> 0
+ENDPROC online ;
+
+
+PROC control (INT CONST code1, code2, code3, INT VAR return code) :
+ EXTERNAL 84
+ENDPROC control ;
+
+PROC blockout (ROW 256 INT CONST block, INT CONST code1, code2,
+ INT VAR return code) :
+
+ access block io ds ;
+ block io.buffer := block ;
+ blockout (block io ds, buffer page, code1, code2, return code) .
+
+access block io ds :
+ IF NOT initialized (this packet)
+ THEN block io ds := nilspace
+ FI ;
+ block io := block io ds .
+
+ENDPROC blockout ;
+
+PROC blockin (ROW 256 INT VAR block, INT CONST code1, code2,
+ INT VAR return code) :
+
+ access block io ds ;
+ blockin (block io ds, buffer page, code1, code2, return code) ;
+ block := block io.buffer .
+
+access block io ds :
+ IF NOT initialized (this packet)
+ THEN block io ds := nilspace
+ FI ;
+ block io := block io ds .
+
+ENDPROC blockin ;
+
+ENDPACKET basic transput ;
+
diff --git a/system/base/1.7.5/src/bits b/system/base/1.7.5/src/bits
new file mode 100644
index 0000000..e9e84e7
--- /dev/null
+++ b/system/base/1.7.5/src/bits
@@ -0,0 +1,78 @@
+
+PACKET bits DEFINES
+
+ AND ,
+ OR ,
+ XOR ,
+ bit ,
+ lowest reset ,
+ lowest set ,
+ reset bit ,
+ rotate ,
+ set bit :
+
+LET bits per int = 16 ;
+
+ROW bits per int INT VAR bit mask := ROW bits per int INT:
+ (1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,-32767-1) ;
+
+PROC rotate (INT VAR bits, INT CONST number of bits) :
+ EXTERNAL 83
+ENDPROC rotate ;
+
+INT OP AND (INT CONST left, right) :
+ EXTERNAL 124
+ENDOP AND ;
+
+INT OP OR (INT CONST left, right) :
+ EXTERNAL 125
+ENDOP OR ;
+
+INT OP XOR (INT CONST left, right) :
+ EXTERNAL 121
+ENDOP XOR ;
+
+BOOL PROC bit (INT CONST bits, bit no) :
+
+ (bits AND bit mask (bit no+1)) <> 0
+
+ENDPROC bit ;
+
+PROC set bit (INT VAR bits, INT CONST bit no) :
+
+ bits := bits OR bit mask (bit no+1)
+
+ENDPROC set bit ;
+
+PROC reset bit (INT VAR bits,INT CONST bit no) :
+
+ bits := bits XOR (bits AND bit mask (bit no+1))
+
+ENDPROC reset bit ;
+
+INT PROC lowest set (INT CONST bits) :
+
+ INT VAR mask index ;
+ FOR mask index FROM 1 UPTO 16 REP
+ IF (bits AND bit mask (mask index)) <> 0
+ THEN LEAVE lowest set WITH mask index - 1
+ FI
+ PER ;
+ -1
+
+ENDPROC lowest set ;
+
+INT PROC lowest reset (INT CONST bits) :
+
+ INT VAR mask index ;
+ FOR mask index FROM 1 UPTO bits per int REP
+ IF (bits AND bit mask (mask index)) = 0
+ THEN LEAVE lowest reset WITH mask index - 1
+ FI
+ PER ;
+ -1
+
+ENDPROC lowest reset ;
+
+ENDPACKET bits ;
+
diff --git a/system/base/1.7.5/src/bool b/system/base/1.7.5/src/bool
new file mode 100644
index 0000000..5bf1e65
--- /dev/null
+++ b/system/base/1.7.5/src/bool
@@ -0,0 +1,16 @@
+
+PACKET bool DEFINES XOR, true, false :
+
+BOOL CONST true := TRUE ,
+ false:= FALSE ;
+
+BOOL OP XOR (BOOL CONST left, right) :
+
+ IF left THEN NOT right
+ ELSE right
+ FI
+
+ENDOP XOR ;
+
+ENDPACKET bool ;
+
diff --git a/system/base/1.7.5/src/command dialogue b/system/base/1.7.5/src/command dialogue
new file mode 100644
index 0000000..3011187
--- /dev/null
+++ b/system/base/1.7.5/src/command dialogue
@@ -0,0 +1,123 @@
+
+PACKET command dialogue DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 25.11.83 *)
+ command dialogue ,
+ say ,
+ yes ,
+ no ,
+ param position ,
+ last param ,
+ std ,
+ QUIET ,
+ quiet :
+
+
+LET up = ""3"" ,
+ right = ""2"" ,
+ cr lf = ""13""10"" ,
+ param pre = " (""" ,
+ param post = """)"13""10"" ;
+
+
+TEXT VAR std param := "" ;
+
+BOOL VAR dialogue flag := TRUE ;
+
+INT VAR param x := 0 ;
+
+
+TYPE QUIET = INT ;
+
+QUIET PROC quiet :
+ QUIET:(0)
+ENDPROC quiet ;
+
+
+BOOL PROC command dialogue :
+ dialogue flag
+ENDPROC command dialogue ;
+
+PROC command dialogue (BOOL CONST status) :
+ dialogue flag := status
+ENDPROC command dialogue ;
+
+
+BOOL PROC yes (TEXT CONST question) :
+
+ IF dialogue flag
+ THEN ask question
+ ELSE TRUE
+ FI .
+
+ask question :
+ out (question) ;
+ skip previous input chars ;
+ out (" (j/n) ? ") ;
+ get answer ;
+ IF correct answer
+ THEN out (answer) ;
+ out (cr lf) ;
+ positive answer
+ ELSE out (""7"") ;
+ LENGTH question + 9 TIMESOUT ""8"" ;
+ yes (question)
+ FI .
+
+get answer :
+ TEXT VAR answer ;
+ inchar (answer) .
+
+correct answer :
+ pos ("jnyJNY", answer) > 0 .
+
+positive answer :
+ pos ("jyJY", answer) > 0 .
+
+skip previous input chars :
+ REP UNTIL incharety = "" PER .
+
+ENDPROC yes ;
+
+BOOL PROC no (TEXT CONST question) :
+
+ NOT yes (question)
+
+ENDPROC no ;
+
+PROC say (TEXT CONST message) :
+
+ IF dialogue flag
+ THEN out (message)
+ FI
+
+ENDPROC say ;
+
+PROC param position (INT CONST x) :
+
+ param x := x
+
+ENDPROC param position ;
+
+TEXT PROC last param :
+
+ IF param x > 0 AND online
+ THEN out (up) ;
+ param x TIMESOUT right ;
+ out (param pre) ;
+ out (std param) ;
+ out (param post)
+ FI ;
+ std param .
+
+ENDPROC last param ;
+
+PROC last param (TEXT CONST new) :
+ std param := new
+ENDPROC last param ;
+
+TEXT PROC std :
+ std param
+ENDPROC std ;
+
+ENDPACKET command dialogue ;
+
diff --git a/system/base/1.7.5/src/command handler b/system/base/1.7.5/src/command handler
new file mode 100644
index 0000000..756382b
--- /dev/null
+++ b/system/base/1.7.5/src/command handler
@@ -0,0 +1,290 @@
+(* ------------------- VERSION 2 05.05.86 ------------------- *)
+PACKET command handler DEFINES (* Autor: J.Liedtke *)
+
+ get command ,
+ analyze command ,
+ do command ,
+ command error ,
+ cover tracks :
+
+
+LET cr lf = ""4""13""10"" ,
+ esc k = ""27"k" ,
+ command pre = ""4""13" " ,
+ command post = ""13""10" " ,
+
+ max command length = 2010 ,
+
+ tag type = 1 ,
+ texttype = 4 ,
+ eof type = 7 ;
+
+
+TEXT VAR command handlers own command line := "" ,
+ previous command line := "" ,
+ symbol ,
+ procedure ,
+ pattern ,
+ error note := "" ;
+
+INT VAR symbol type ;
+
+
+PROC get command (TEXT CONST command text) :
+
+ get command (command text, command handlers own command line)
+
+ENDPROC get command ;
+
+PROC get command (TEXT CONST command text, TEXT VAR command line) :
+
+ set line nr (0) ;
+ error protocoll ;
+ get command from console .
+
+error protocoll :
+ IF is error
+ THEN put error ;
+ clear error
+ ELSE command line := "" ;
+ FI .
+
+get command from console :
+ normalize cursor ;
+ REP
+ out (command pre) ;
+ out (command text) ;
+ out (command post) ;
+ editget command
+ UNTIL command line <> "" PER ;
+ param position (LENGTH command line) ;
+ out (command post) .
+
+editget command :
+ TEXT VAR exit char ;
+ REP
+ get cursor (x, y) ;
+ editget (command line, max command length, x size - x,
+ "", "k", exit char) ;
+ ignore halt errors during editget ;
+ break quiet if command line is too long ;
+ IF exit char = esc k
+ THEN cursor to begin of command input ;
+ command line := previous command line
+ ELIF LENGTH command line > 1
+ THEN previous command line := command line ;
+ LEAVE editget command
+ ELSE LEAVE editget command
+ FI
+ PER .
+
+normalize cursor :
+ INT VAR x, y;
+ out (crlf) ;
+ get cursor (x, y) ;
+ cursor (x, y) .
+
+ignore halt errors during editget :
+ IF is error
+ THEN clear error
+ FI .
+
+break quiet if command line is too long :
+ IF command line is too long
+ THEN command line := "break (quiet)"
+ FI .
+
+command line is too long :
+ LENGTH command line = max command length .
+
+cursor to begin of command input :
+ out (command pre) .
+
+ENDPROC get command ;
+
+
+PROC analyze command ( TEXT CONST command list,
+ INT CONST permitted type,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2) :
+
+ analyze command (command list, command handlers own command line,
+ permitted type, command index,
+ number of params, param 1, param 2)
+
+ENDPROC analyze command ;
+
+PROC analyze command ( TEXT CONST command list, command line,
+ INT CONST permitted type,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2) :
+
+ error note := "" ;
+ scan (command line) ;
+ next symbol ;
+ IF symbol type <> tag type AND symbol <> "?"
+ THEN error ("Name ungueltig") ;
+ impossible command
+ ELIF pos (command list, symbol) > 0
+ THEN procedure name ;
+ parameter list pack option ;
+ nothing else in command line ;
+ decode command
+ ELSE impossible command
+ FI .
+
+procedure name :
+ procedure := symbol ;
+ next symbol .
+
+parameter list pack option :
+ number of params := 0 ;
+ param 1 := "" ;
+ param 2 := "" ;
+ IF symbol = "("
+ THEN next symbol ;
+ parameter list ;
+ IF symbol <> ")" AND error note = ""
+ THEN error (") fehlt")
+ FI
+ ELIF symbol type <> eof type
+ THEN error ("( fehlt")
+ FI .
+
+parameter list :
+ parameter (param 1, number of params, permitted type) ;
+ IF symbol = ","
+ THEN next symbol ;
+ parameter (param 2, number of params, permitted type) ;
+ FI .
+
+nothing else in command line :
+ next symbol ;
+ IF symbol <> ""
+ THEN error ("Kommando zu schwierig")
+ FI .
+
+decode command :
+ command index := index (command list, procedure, number of params) .
+
+impossible command :
+ command index := 0 .
+
+ENDPROC analyze command ;
+
+PROC parameter (TEXT VAR param, INT VAR number of params,
+ INT CONST permitted type) :
+
+ IF symbol type = text type OR symbol type = permitted type
+ THEN param := symbol ;
+ number of params INCR 1 ;
+ next symbol
+ ELSE error ("Parameter ist kein TEXT ("" fehlt)")
+ FI
+
+ENDPROC parameter ;
+
+INT PROC index (TEXT CONST list, procedure, INT CONST params) :
+
+ pattern := procedure ;
+ pattern CAT ":" ;
+ IF procedure name found
+ THEN get colon pos ;
+ get dot pos ;
+ get end pos ;
+ get command index ;
+ get param index ;
+ IF param index >= 0
+ THEN command index + param index
+ ELSE - command index
+ FI
+ ELSE 0
+ FI .
+
+procedure name found :
+ INT VAR index pos := pos (list, pattern) ;
+ WHILE index pos > 0 REP
+ IF index pos = 1 COR (list SUB index pos - 1) <= "9"
+ THEN LEAVE procedure name found WITH TRUE
+ FI ;
+ index pos := pos (list, pattern, index pos + 1)
+ PER ;
+ FALSE .
+
+get param index :
+ INT CONST param index :=
+ pos (list, text (params), dot pos, end pos) - dot pos - 1 .
+
+get command index :
+ INT CONST command index :=
+ int ( subtext (list, colon pos + 1, dot pos - 1) ) .
+
+get colon pos :
+ INT CONST colon pos := pos (list, ":", index pos) .
+
+get dot pos :
+ INT CONST dot pos := pos (list, ".", index pos) .
+
+get end pos :
+ INT CONST end pos := dot pos + 4 .
+
+ENDPROC index ;
+
+PROC do command :
+
+ do (command handlers own command line)
+
+ENDPROC do command ;
+
+PROC error (TEXT CONST message) :
+
+ error note := message ;
+ scan ("") ;
+ procedure := "-"
+
+ENDPROC error ;
+
+PROC command error :
+
+ disable stop ;
+ IF error note <> ""
+ THEN errorstop (error note) ;
+ error note := ""
+ FI ;
+ enable stop
+
+ENDPROC command error ;
+
+
+PROC next symbol :
+
+ next symbol (symbol, symbol type)
+
+ENDPROC next symbol ;
+
+
+PROC cover tracks :
+
+ cover tracks (command handlers own command line) ;
+ cover tracks (previous command line) ;
+ erase buffers of compiler and do packet .
+
+erase buffers of compiler and do packet :
+ do (command handlers own command line) .
+
+ENDPROC cover tracks ;
+
+PROC cover tracks (TEXT VAR secret) :
+
+ INT VAR i ;
+ FOR i FROM 1 UPTO LENGTH secret REP
+ replace (secret, i, " ")
+ PER ;
+ WHILE LENGTH secret < 13 REP
+ secret CAT " "
+ PER
+
+ENDPROC cover tracks ;
+
+ENDPACKET command handler ;
+
diff --git a/system/base/1.7.5/src/dataspace b/system/base/1.7.5/src/dataspace
new file mode 100644
index 0000000..3045a53
--- /dev/null
+++ b/system/base/1.7.5/src/dataspace
@@ -0,0 +1,74 @@
+(* ------------------- VERSION 3 22.04.86 ------------------- *)
+PACKET dataspace DEFINES
+
+ := ,
+ nilspace ,
+ forget ,
+ type ,
+ heap size ,
+ storage ,
+ ds pages ,
+ next ds page ,
+ blockout ,
+ blockin ,
+ ALIGN :
+
+
+LET myself id field = 9 ,
+ lowest ds number = 4 ,
+ highest ds number = 255 ;
+
+TYPE ALIGN = ROW 252 INT ;
+
+OP := (DATASPACE VAR dest, DATASPACE CONST source ) :
+ EXTERNAL 70
+ENDOP := ;
+
+DATASPACE PROC nilspace :
+ EXTERNAL 69
+ENDPROC nilspace ;
+
+PROC forget (DATASPACE CONST dataspace ) :
+ EXTERNAL 71
+ENDPROC forget ;
+
+PROC type (DATASPACE CONST ds, INT CONST type) :
+ EXTERNAL 72
+ENDPROC type ;
+
+INT PROC type (DATASPACE CONST ds) :
+ EXTERNAL 73
+ENDPROC type ;
+
+INT PROC heap size (DATASPACE CONST ds) :
+ EXTERNAL 74
+ENDPROC heap size ;
+
+INT PROC storage (DATASPACE CONST ds) :
+ (ds pages (ds) + 1) DIV 2
+ENDPROC storage ;
+
+INT PROC ds pages (DATASPACE CONST ds) :
+ pages (ds, pcb (myself id field))
+ENDPROC ds pages ;
+
+INT PROC pages (DATASPACE CONST ds, INT CONST task nr) :
+ EXTERNAL 88
+ENDPROC pages ;
+
+INT PROC next ds page (DATASPACE CONST ds, INT CONST page nr) :
+ EXTERNAL 87
+ENDPROC next ds page ;
+
+PROC blockout (DATASPACE CONST ds, INT CONST page nr, code1, code2,
+ INT VAR return code) :
+ EXTERNAL 85
+ENDPROC blockout ;
+
+PROC blockin (DATASPACE VAR ds, INT CONST page nr, code1, code2,
+ INT VAR return code) :
+ EXTERNAL 86
+ENDPROC blockin ;
+
+ENDPACKET dataspace ;
+
diff --git a/system/base/1.7.5/src/date handling b/system/base/1.7.5/src/date handling
new file mode 100644
index 0000000..66da110
--- /dev/null
+++ b/system/base/1.7.5/src/date handling
@@ -0,0 +1,303 @@
+PACKET date handling DEFINES date, time, (* Autor: H. Indenbirken *)
+ time of day, (* Stand: 02.06.1986 (wk)*)
+ month, day , year ,
+ hour ,
+ minute,
+ second :
+
+LET middle yearlength = 31557380.0,
+ weeklength = 604800.0,
+ daylength = 86400.0,
+ hours = 3600.0,
+ minutes = 60.0,
+ seconds = 1.0;
+
+
+(* Tage bis zum Jahr 01.01.1900: 693970.25 5.995903e10 Sekunden *)
+(* Dieser Tag ist ein Montag *)
+
+REAL VAR begin of today := 0.0 , end of today := 0.0 ;
+
+TEXT VAR today , result ;
+
+
+ROW 12 REAL CONST previous days :: ROW 12 REAL : (0.0, 2678400.0, 5097600.0,
+ 7776000.0, 10368000.0, 13046400.0,
+ 15638400.0, 18316800.0, 20995200.0,
+ 23587200.0, 26265600.0, 28857600.0);
+
+REAL PROC day: day length END PROC day;
+REAL PROC hour: hours END PROC hour;
+REAL PROC minute: minutes END PROC minute;
+REAL PROC second: seconds END PROC second;
+
+TEXT PROC date :
+
+ IF clock (1) < begin of today OR end of today <= clock (1)
+ THEN begin of today := clock (1) ;
+ end of today := floor (begin of today/daylength)*daylength+daylength;
+ today := date (begin of today)
+ FI ;
+ today
+
+ENDPROC date ;
+
+TEXT PROC date (REAL CONST datum):
+ INT VAR year :: int (datum/middle yearlength),
+ day :: int (((datum - datum MOD daylength) MOD middle yearlength) / daylength) + 1;
+
+correct kalendary day;
+
+ calculate month and correct day;
+ result := daytext;
+ result CAT monthtext;
+ result CAT yeartext;
+ change all (result, " ", "0") ;
+ result .
+
+correct kalendary day:
+ IF day >= 60 AND NOT leapyear
+ THEN day INCR 1 FI .
+
+leapyear:
+ IF year MOD 100 = 0
+ THEN year MOD 400 = 0
+ ELSE year MOD 4 = 0
+ FI.
+
+calculate month and correct day:
+ INT VAR month;
+ IF day > 182
+ THEN IF day > 274
+ THEN IF day > 305
+ THEN IF day > 335
+ THEN month := 12;
+ day DECR 335
+ ELSE month := 11;
+ day DECR 305
+ FI
+ ELSE month := 10;
+ day DECR 274
+ FI
+ ELSE IF day > 213
+ THEN IF day > 244
+ THEN month := 9;
+ day DECR 244
+ ELSE month := 8;
+ day DECR 213
+ FI
+ ELSE month := 7;
+ day DECR 182
+ FI
+ FI
+ ELSE IF day > 91
+ THEN IF day > 121
+ THEN IF day > 152
+ THEN month := 6;
+ day DECR 152
+ ELSE month := 5;
+ day DECR 121
+ FI
+ ELSE month := 4;
+ day DECR 91
+ FI
+ ELSE IF day > 31
+ THEN IF day > 60
+ THEN month := 3;
+ day DECR 60
+ ELSE month := 2;
+ day DECR 31
+ FI
+ ELSE month := 1 FI
+ FI
+ FI .
+
+daytext :
+ text (day, 2) + "." .
+
+monthtext :
+ text (month,2) + "." .
+
+yeartext:
+ IF 1900 <= year AND year < 2000
+ THEN text (year - 1900, 2)
+ ELSE text (year, 4)
+ FI .
+
+END PROC date;
+
+TEXT PROC day (REAL CONST datum):
+ SELECT int ((datum MOD weeklength)/daylength) OF
+ CASE 1: "Donnerstag"
+ CASE 2: "Freitag"
+ CASE 3: "Samstag"
+ CASE 4: "Sonntag"
+ CASE 5: "Montag"
+ CASE 6: "Dienstag"
+ OTHERWISE "Mittwoch" ENDSELECT .
+END PROC day;
+
+TEXT PROC month (REAL CONST datum):
+ SELECT int (subtext (date (datum), 4, 5)) OF
+ CASE 1: "Januar"
+ CASE 2: "Februar"
+ CASE 3: "März"
+ CASE 4: "April"
+ CASE 5: "Mai"
+ CASE 6: "Juni"
+ CASE 7: "Juli"
+ CASE 8: "August"
+ CASE 9: "September"
+ CASE 10: "Oktober"
+ CASE 11: "November"
+ OTHERWISE "Dezember" ENDSELECT .
+
+END PROC month;
+
+TEXT PROC year (REAL CONST datum) :
+
+ TEXT VAR buffer := subtext (date (datum), 7) ;
+ IF LENGTH buffer = 2
+ THEN "19" + buffer
+ ELSE buffer
+ FI .
+
+ENDPROC year ;
+
+TEXT PROC time of day :
+ time of day (clock (1))
+ENDPROC time of day ;
+
+TEXT PROC time of day (REAL CONST value) :
+ subtext (time (value MOD daylength), 1, 5)
+ENDPROC time of day ;
+
+TEXT PROC time (REAL CONST value) :
+ time (value,10)
+ENDPROC time ;
+
+TEXT PROC time (REAL CONST value, INT CONST length) :
+ result := "" ;
+ IF length > 7
+ THEN result CAT hour ;
+ result CAT ":"
+ FI ;
+ result CAT minute ;
+ result CAT ":" ;
+ result CAT rest ;
+ change all (result, " ", "0") ;
+ result .
+
+hour :
+ text (int (value/hours), length-8) .
+
+minute :
+ text (int (value/minutes MOD 60.0), 2) .
+
+rest :
+ text (value MOD minutes, 4, 1) .
+
+END PROC time ;
+
+REAL PROC date (TEXT CONST datum) :
+ split and check datum;
+ real (day no)*daylength +
+ previous days [month no] + calendary day +
+ floor (real (year no)*middleyearlength / daylength)*daylength .
+
+split and check datum:
+ INT CONST day no :: first no;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI;
+
+ INT CONST month no :: second no;
+ IF NOT last conversion ok OR month no < 1 OR month no > 12
+ THEN errorstop ("inkorrekte Datumsangabe (Monat) : " + datum) FI;
+
+ INT CONST year no :: third no + century;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Jahr) : " + datum) FI;
+
+ IF day no < 1 OR day no > size of month
+ THEN errorstop ("inkorrekte Datumsangabe (Tag) : " + datum) FI .
+
+century:
+ IF (length (datum) - second pos) <= 2
+ THEN 1900
+ ELSE 0 FI .
+
+size of month:
+ SELECT month no OF
+ CASE 1, 3, 5, 7, 8, 10, 12: 31
+ CASE 4, 6, 9, 11: 30
+ OTHERWISE february size ENDSELECT .
+
+february size:
+ IF leapyear
+ THEN 29
+ ELSE 28 FI .
+
+calendary day:
+ IF month no > 2 AND leapyear
+ THEN daylength
+ ELSE 0.0 FI .
+
+leapyear:
+ year no MOD 4 = 0 AND year no MOD 400 <> 0 .
+
+first no:
+ INT CONST first pos :: pos (datum, ".");
+ int (subtext (datum, 1, first pos-1)) .
+
+second no:
+ INT CONST second pos :: pos (datum, ".", first pos+1);
+ int (subtext (datum, first pos + 1, second pos-1)) .
+
+third no:
+ int (subtext (datum, second pos + 1)) .
+
+END PROC date;
+
+REAL PROC time (TEXT CONST time) :
+ split and check time;
+ hour + min + sec .
+
+split and check time:
+ REAL CONST hour :: hour no * hours;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Stunde) : " + time) FI;
+
+ REAL CONST min :: min no * minutes;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Minute) : " + time) FI;
+
+ REAL CONST sec :: sec no;
+ IF NOT last conversion ok
+ THEN errorstop ("inkorrekte Datumsangabe (Sekunde) : " + time) FI;
+
+ set conversion (hour ok AND min ok AND sec ok) .
+
+hour no:
+ INT CONST hour pos :: pos (time, ":");
+ real (subtext (time, 1, hour pos-1)) .
+
+min no:
+ INT VAR min pos :: pos (time, ":", hour pos+1);
+ IF min pos = 0
+ THEN real (subtext (time, hour pos + 1, LENGTH time))
+ ELSE real (subtext (time, hour pos + 1, min pos-1))
+ FI .
+
+sec no:
+ IF min pos = 0
+ THEN 0.0
+ ELSE real (subtext (time, min pos + 1))
+ FI .
+
+hour ok: 0.0 <= hour AND hour < daylength .
+min ok: 0.0 <= min AND min < hours .
+sec ok: 0.0 <= sec AND sec < minutes .
+END PROC time;
+
+END PACKET datehandling
+
diff --git a/system/base/1.7.5/src/editor b/system/base/1.7.5/src/editor
new file mode 100644
index 0000000..62af2db
--- /dev/null
+++ b/system/base/1.7.5/src/editor
@@ -0,0 +1,2959 @@
+PACKET editor paket DEFINES (* EDITOR 121 *)
+ (**********) (* 19.07.85 -bk- *)
+ (* 10.09.85 -ws- *)
+ (* 25.04.86 -sh- *)
+ edit, editget, (* 06.06.86 -wk- *)
+ quit, quit last, (* 04.06.86 -jl- *)
+ push, type,
+ word wrap, margin,
+ write permission,
+ set busy indicator,
+ two bytes,
+ is kanji esc,
+ within kanji,
+ rubin mode,
+ is editget,
+ getchar, nichts neu,
+ getcharety, satznr neu,
+ is incharety, ueberschrift neu,
+ get window, zeile neu,
+ get editcursor, abschnitt neu,
+ get editline, bildabschnitt neu,
+ put editline, bild neu,
+ aktueller editor, alles neu,
+ groesster editor, satznr zeigen,
+ open editor, ueberschrift zeigen,
+ editfile, bild zeigen:
+
+
+LET hop = ""1"", right = ""2"",
+ up char = ""3"", clear eop = ""4"",
+ clear eol = ""5"", cursor pos = ""6"",
+ piep = ""7"", left = ""8"",
+ down char = ""10"", rubin = ""11"",
+ rubout = ""12"", cr = ""13"",
+ mark key = ""16"", abscr = ""17"",
+ inscr = ""18"", dezimal = ""19"",
+ backcr = ""20"", esc = ""27"",
+ dach = ""94"", blank = " ";
+
+
+LET no output = 0, out zeichen = 1,
+ out feldrest = 2, out feld = 3,
+ clear feldrest = 4;
+
+LET FELDSTATUS = STRUCT (INT stelle, alte stelle, rand, limit,
+ anfang, marke, laenge, verschoben,
+ BOOL einfuegen, fliesstext, write access,
+ TEXT tabulator);
+FELDSTATUS VAR feldstatus;
+
+TEXT VAR begin mark := ""15"",
+ end mark := ""14"";
+
+TEXT VAR separator := "", kommando := "", audit := "", zeichen := "",
+ satzrest := "", merksatz := "", alter editsatz := "";
+
+INT VAR kommando zeiger := 1, umbruchstelle, umbruch verschoben,
+ zeile, spalte, output mode := no output, postblanks := 0,
+ min schreibpos, max schreibpos, cpos, absatz ausgleich;
+
+BOOL VAR lernmodus := FALSE, separator eingestellt := FALSE,
+ invertierte darstellung := FALSE, absatzmarke steht,
+ cursor diff := FALSE, editget modus := FALSE,
+ two byte mode := FALSE, std fliesstext := TRUE;.
+
+schirmbreite : x size - 1 .
+schirmhoehe : y size .
+maxbreite : schirmbreite - 2 .
+maxlaenge : schirmhoehe - 1 .
+marklength : mark size .;
+
+initialisiere editor;
+
+.initialisiere editor :
+ anfang := 1; zeile := 0; verschoben := 0; tabulator := "";
+ einfuegen := FALSE; fliesstext := TRUE; zeileneinfuegen := FALSE;
+ marke := 0; bildmarke := 0; feldmarke := 0.;
+
+(******************************** editget ********************************)
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge,
+ TEXT CONST sep, res, TEXT VAR exit char) :
+ IF editlaenge < 1 THEN errorstop ("Fenster zu klein") FI;
+ separator := ""13""; separator CAT sep;
+ separator eingestellt := TRUE;
+ TEXT VAR reservierte editget tasten := ""11""12"" ;
+ reservierte editget tasten CAT res ;
+ disable stop;
+ absatz ausgleich := 0; exit char := ""; get cursor;
+ FELDSTATUS CONST alter feldstatus := feldstatus;
+ feldstatus := FELDSTATUS : (1, 1, spalte - 1, editlimit,
+ 1, 0, editlaenge, 0,
+ FALSE, FALSE, TRUE, "");
+ konstanten neu berechnen;
+ output mode := out feld;
+ feld editieren;
+ zeile verlassen;
+ feldstatus := alter feldstatus;
+ konstanten neu berechnen;
+ separator := "";
+ separator eingestellt := FALSE .
+
+feld editieren :
+ REP
+ feldeditor (editsatz, reservierte editget tasten);
+ IF is error
+ THEN kommando zeiger := 1; kommando := ""; LEAVE feld editieren
+ FI ;
+ TEXT VAR t, zeichen; getchar (zeichen);
+ IF zeichen ist separator
+ THEN exit char := zeichen; LEAVE feld editieren
+ ELIF zeichen = hop
+ THEN feldout (editsatz, stelle); getchar (zeichen)
+ ELIF zeichen = mark key
+ THEN output mode := out feld
+ ELIF zeichen = abscr
+ THEN exit char := cr; LEAVE feld editieren
+ ELIF zeichen = esc
+ THEN getchar (zeichen); auf exit pruefen;
+ IF zeichen = rubout (*sh*)
+ THEN IF marke > 0
+ THEN merksatz := subtext (editsatz, marke, stelle - 1);
+ change (editsatz, marke, stelle - 1, "");
+ stelle := marke; marke := 0; konstanten neu berechnen
+ FI
+ ELIF zeichen = rubin
+ THEN t := subtext (editsatz, 1, stelle - 1);
+ t CAT merksatz;
+ satzrest := subtext (editsatz, stelle);
+ t CAT satzrest;
+ stelle INCR LENGTH merksatz;
+ merksatz := ""; editsatz := t
+ ELIF zeichen ist kein esc kommando (*wk*)
+ AND
+ kommando auf taste (zeichen) <> ""
+ THEN editget kommando ausfuehren
+ FI ;
+ output mode := out feld
+ FI
+ PER .
+
+zeichen ist kein esc kommando : (*wk*)
+ pos (hop + left + right, zeichen) = 0 .
+
+zeile verlassen :
+ IF marke > 0 OR verschoben <> 0
+ THEN stelle DECR verschoben; verschoben := 0; feldout (editsatz, 0)
+ ELSE cursor (rand + 1 + min (LENGTH editsatz, editlaenge), zeile)
+ FI .
+
+zeichen ist separator : pos (separator, zeichen) > 0 .
+
+auf exit pruefen :
+ IF pos (res, zeichen) > 0
+ THEN exit char := esc + zeichen; LEAVE feld editieren
+ FI .
+
+editget kommando ausfuehren :
+ editget zustaende sichern ;
+ do (kommando auf taste (zeichen)) ;
+ alte editget zustaende wieder herstellen ;
+ IF stelle < marke THEN stelle := marke FI;
+ konstanten neu berechnen .
+
+editget zustaende sichern : (*wk*)
+ BOOL VAR alter editget modus := editget modus;
+ FELDSTATUS VAR feldstatus vor do kommando := feldstatus ;
+ INT VAR zeile vor do kommando := zeile ;
+ TEXT VAR separator vor do kommando := separator ;
+ BOOL VAR separator eingestellt vor do kommando := separator eingestellt ;
+ editget modus := TRUE ;
+ alter editsatz := editsatz .
+
+alte editget zustaende wieder herstellen :
+ editget modus := alter editget modus ;
+ editsatz := alter editsatz;
+ feldstatus := feldstatus vor do kommando ;
+ zeile := zeile vor do kommando ;
+ separator := separator vor do kommando ;
+ separator eingestellt := separator eingestellt vor do kommando .
+
+END PROC editget;
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, TEXT VAR exit char) :
+ editget (editsatz, editlimit, x size - x cursor, "", "", exit char)
+END PROC editget; (* 05.07.84 -bk- *)
+
+PROC editget (TEXT VAR editsatz, TEXT CONST sep, res, TEXT VAR exit char) :
+ editget (editsatz, max text length, x size - x cursor, sep, res, exit char)
+END PROC editget; (* 05.07.84 -bk- *)
+
+PROC editget (TEXT VAR editsatz) :
+ TEXT VAR exit char; (* 05.07.84 -bk- *)
+ editget (editsatz, max text length, x size - x cursor, "", "", exit char)
+END PROC editget;
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, editlaenge) :
+ TEXT VAR exit char;
+ editget (editsatz, editlimit, editlaenge, "", "", exit char)
+ENDPROC editget;
+
+(******************************* feldeditor ******************************)
+
+TEXT VAR reservierte feldeditor tasten ; (*jl*)
+
+PROC feldeditor (TEXT VAR satz, TEXT CONST res) :
+ enable stop;
+ reservierte feldeditor tasten := ""1""2""8"" ;
+ reservierte feldeditor tasten CAT res;
+ absatzmarke steht := (satz SUB LENGTH satz) = blank;
+ alte stelle merken;
+ cursor diff bestimmen und ggf ausgleichen;
+ feld editieren;
+ absatzmarke updaten .
+
+alte stelle merken : alte stelle := stelle .
+
+cursor diff bestimmen und ggf ausgleichen :
+ IF cursor diff
+ THEN stelle INCR 1; cursor diff := FALSE
+ FI ;
+ IF stelle auf zweitem halbzeichen
+ THEN stelle DECR 1; cursor diff := TRUE
+ FI .
+
+feld editieren :
+ REP
+ feld optisch aufbereiten;
+ kommando annehmen und ausfuehren
+ PER .
+
+absatzmarke updaten :
+ IF absatzmarke soll stehen
+ THEN IF NOT absatzmarke steht THEN absatzmarke schreiben (TRUE) FI
+ ELSE IF absatzmarke steht THEN absatzmarke schreiben (FALSE) FI
+ FI .
+
+absatzmarke soll stehen : (satz SUB LENGTH satz) = blank .
+
+feld optisch aufbereiten :
+ stelle korrigieren;
+ verschieben wenn erforderlich;
+ randausgleich fuer doppelzeichen;
+ output mode behandeln;
+ ausgabe verhindern .
+
+randausgleich fuer doppelzeichen :
+ IF stelle = max schreibpos CAND stelle auf erstem halbzeichen
+ THEN verschiebe (1)
+ FI .
+
+stelle korrigieren :
+ IF stelle auf zweitem halbzeichen THEN stelle DECR 1 FI .
+
+stelle auf erstem halbzeichen : within kanji (satz, stelle + 1) .
+
+stelle auf zweitem halbzeichen : within kanji (satz, stelle) .
+
+output mode behandeln :
+ SELECT output mode OF
+ CASE no output : im markiermode markierung anpassen
+ CASE out zeichen : zeichen ausgeben; LEAVE output mode behandeln
+ CASE out feldrest : feldrest neu schreiben
+ CASE out feld : feldout (satz, stelle)
+ CASE clear feldrest : feldrest loeschen
+ END SELECT;
+ schreibmarke positionieren (stelle) .
+
+ausgabe verhindern : output mode := no output .
+
+im markiermode markierung anpassen :
+ IF markiert THEN markierung anpassen FI .
+
+markierung anpassen :
+ IF stelle > alte stelle
+ THEN markierung verlaengern
+ ELIF stelle < alte stelle
+ THEN markierung verkuerzen
+ FI .
+
+markierung verlaengern :
+ invers out (satz, alte stelle, stelle, "", end mark) .
+
+markierung verkuerzen :
+ invers out (satz, stelle, alte stelle, end mark, "") .
+
+zeichen ausgeben :
+ IF NOT markiert
+ THEN out (zeichen)
+ ELIF mark refresh line mode
+ THEN feldout (satz, stelle); schreibmarke positionieren (stelle)
+ ELSE out (begin mark); markleft; out (zeichen); out (end mark); markleft
+ FI .
+
+markleft :
+ marklength TIMESOUT left .
+
+feldrest neu schreiben :
+ IF NOT markiert
+ THEN feldrest unmarkiert neu schreiben
+ ELSE feldrest markiert neu schreiben
+ FI ;
+ WHILE postblanks > 0 CAND x cursor <= rand + laenge REP
+ out (blank); postblanks DECR 1
+ PER ; postblanks := 0 .
+
+feldrest unmarkiert neu schreiben :
+ schreibmarke positionieren (alte stelle);
+ out subtext mit randbehandlung (satz, alte stelle, stelle am ende) .
+
+feldrest markiert neu schreiben :
+ markierung verlaengern; out subtext mit randbehandlung
+ (satz, stelle, stelle am ende - 2 * marklength) .
+
+kommando annehmen und ausfuehren :
+ kommando annehmen; kommando ausfuehren .
+
+kommando annehmen :
+ getchar (zeichen); kommando zurueckweisen falls noetig .
+
+kommando zurueckweisen falls noetig :
+ IF NOT write access CAND zeichen ist druckbar
+ THEN benutzer warnen; kommando ignorieren
+ FI .
+
+benutzer warnen : out (piep) .
+
+kommando ignorieren :
+ zeichen := ""; LEAVE kommando annehmen und ausfuehren .
+
+kommando ausfuehren :
+ neue satzlaenge bestimmen;
+ alte stelle merken;
+ IF zeichen ist separator
+ THEN feldeditor verlassen
+ ELIF zeichen ist druckbar
+ THEN fortschreiben
+ ELSE funktionstasten behandeln
+ FI .
+
+neue satzlaenge bestimmen : INT VAR satzlaenge := LENGTH satz .
+
+feldeditor verlassen :
+ IF NOT absatzmarke steht THEN blanks abschneiden FI; (*sh*)
+ push (zeichen); LEAVE feld editieren .
+
+blanks abschneiden :
+ INT VAR letzte non blank pos := satzlaenge;
+ WHILE letzte non blank pos > 0 CAND (satz SUB letzte non blank pos) = blank REP
+ letzte non blank pos DECR 1
+ PER; satz := subtext (satz, 1, letzte non blank pos) .
+
+zeichen ist druckbar : zeichen >= blank .
+
+zeichen ist separator :
+ separator eingestellt CAND pos (separator, zeichen) > 0 .
+
+fortschreiben :
+ zeichen in satz eintragen;
+ IF is kanji esc (zeichen) THEN kanji zeichen schreiben FI;
+ bei erreichen von limit ueberlauf behandeln .
+
+zeichen in satz eintragen :
+ IF hinter dem satz
+ THEN satz mit leerzeichen auffuellen und zeichen anfuegen
+ ELIF einfuegen
+ THEN zeichen vor aktueller position einfuegen
+ ELSE altes zeichen ersetzen
+ FI .
+
+hinter dem satz : stelle > satzlaenge .
+
+satz mit leerzeichen auffuellen und zeichen anfuegen :
+ satz AUFFUELLENMIT blank;
+ zeichen anfuegen;
+ output mode := out zeichen .
+
+zeichen anfuegen : satz CAT zeichen; neue satzlaenge bestimmen .
+zeichen ignorieren : benutzer warnen; LEAVE kommando ausfuehren .
+
+zeichen vor aktueller position einfuegen :
+ insert char (satz, zeichen, stelle);
+ neue satzlaenge bestimmen;
+ output mode := out feldrest .
+
+altes zeichen ersetzen :
+ replace (satz, stelle, zeichen);
+ IF stelle auf erstem halbzeichen
+ THEN output mode := out feldrest; replace (satz, stelle + 1, blank)
+ ELSE output mode := out zeichen
+ FI .
+
+kanji zeichen schreiben :
+ alte stelle merken;
+ stelle INCR 1; getchar (zeichen);
+ IF zeichen < ""64"" THEN zeichen := ""64"" FI;
+ IF hinter dem satz
+ THEN zeichen anfuegen
+ ELIF einfuegen
+ THEN zeichen vor aktueller position einfuegen
+ ELSE replace (satz, stelle, zeichen)
+ FI ;
+ output mode := out feldrest .
+
+bei erreichen von limit ueberlauf behandeln : (*sh*)
+ IF satzlaenge kritisch
+ THEN in naechste zeile falls moeglich
+ ELSE stelle INCR 1
+ FI .
+
+satzlaenge kritisch :
+ IF stelle >= satzlaenge
+ THEN satzlaenge = limit
+ ELSE satzlaenge = limit + 1
+ FI .
+
+in naechste zeile falls moeglich :
+ IF fliesstext AND umbruch moeglich OR NOT fliesstext AND stelle >= satzlaenge
+ THEN in naechste zeile
+ ELSE stelle INCR 1
+ FI .
+
+umbruch moeglich :
+ INT CONST st := stelle; stelle := limit;
+ INT CONST ltzt wortanf := letzter wortanfang (satz);
+ stelle := st; einrueckposition (satz) < ltzt wortanf .
+
+in naechste zeile :
+ IF fliesstext
+ THEN ueberlauf und oder umbruch
+ ELSE ueberlauf ohne umbruch
+ FI .
+
+ueberlauf und oder umbruch :
+ INT VAR umbruchpos := 1;
+ umbruchposition bestimmen;
+ loeschposition bestimmen;
+ IF stelle = satzlaenge
+ THEN ueberlauf mit oder ohne umbruch
+ ELSE umbruch mit oder ohne ueberlauf
+ FI .
+
+umbruchposition bestimmen :
+ umbruchstelle := stelle;
+ stelle := satzlaenge;
+ umbruchpos := max (umbruchpos, letzter wortanfang (satz));
+ stelle := umbruchstelle .
+
+loeschposition bestimmen :
+ INT VAR loeschpos := umbruchpos;
+ WHILE davor noch blank REP loeschpos DECR 1 PER .
+
+davor noch blank :
+ loeschpos > ganz links CAND (satz SUB (loeschpos - 1)) = blank .
+
+ganz links : max (1, marke) .
+
+ueberlauf mit oder ohne umbruch :
+ IF zeichen = blank OR loeschpos = ganz links
+ THEN stelle := 1; ueberlauf ohne umbruch
+ ELSE ueberlauf mit umbruch
+ FI .
+
+ueberlauf ohne umbruch : push (cr) .
+
+ueberlauf mit umbruch :
+ ausgabe verhindern;
+ umbruchkommando aufbereiten;
+ auf loeschposition positionieren .
+
+umbruchkommando aufbereiten :
+ zeichen := hop + rubout + inscr;
+ satzrest := subtext (satz, umbruchpos);
+ zeichen CAT satzrest;
+ IF stelle ist im umgebrochenen teil
+ THEN insert char (zeichen, backcr, max (stelle - umbruchpos + 1, 0) + 4);
+ zeichen CAT backcr
+ FI ;
+ push (zeichen) .
+
+stelle ist im umgebrochenen teil : stelle >= loeschpos .
+
+auf loeschposition positionieren : stelle := loeschpos .
+
+umbruch mit oder ohne ueberlauf :
+ umbruchposition anpassen;
+ IF stelle ist im umgebrochenen teil
+ THEN umbruch mit ueberlauf
+ ELSE umbruch ohne ueberlauf
+ FI .
+
+umbruchposition anpassen :
+ IF zeichen = blank
+ THEN umbruchpos := stelle + 1;
+ umbruchposition bestimmen;
+ neue loeschposition bestimmen
+ FI .
+
+neue loeschposition bestimmen :
+ loeschpos := umbruchpos;
+ WHILE davor noch blank AND stelle noch nicht erreicht REP loeschpos DECR 1 PER .
+
+stelle noch nicht erreicht : loeschpos > stelle + 1 .
+
+umbruch mit ueberlauf : ueberlauf mit umbruch .
+
+umbruch ohne ueberlauf :
+ zeichen := inscr;
+ satzrest := subtext (satz, umbruchpos);
+ zeichen CAT satzrest;
+ zeichen CAT up char + backcr;
+ umbruchstelle INCR 1; umbruch verschoben := verschoben;
+ satz := subtext (satz, 1, loeschpos - 1);
+ schreibmarke positionieren (loeschpos); feldrest loeschen;
+ output mode := out feldrest;
+ push (zeichen) .
+
+funktionstasten behandeln :
+ SELECT pos (kommandos, zeichen) OF
+ CASE c hop : hop kommandos behandeln
+ CASE c esc : esc kommandos behandeln
+ CASE c right : nach rechts oder ueberlauf
+ CASE c left : wenn moeglich ein schritt nach links
+ CASE c tab : zur naechsten tabulator position
+ CASE c dezimal : dezimalen schreiben
+ CASE c rubin : einfuegen umschalten
+ CASE c rubout : ein zeichen loeschen
+ CASE c abscr, c inscr, c down : feldeditor verlassen
+ CASE c up : eine zeile nach oben (*sh*)
+ CASE c cr : ggf absatz erzeugen
+ CASE c mark : markieren umschalten
+ CASE c backcr : zurueck zur umbruchstelle
+ OTHERWISE : sondertaste behandeln
+ END SELECT .
+
+kommandos :
+ LET c hop = 1, c right = 2,
+ c up = 3, c left = 4,
+ c tab = 5, c down = 6,
+ c rubin = 7, c rubout = 8,
+ c cr = 9, c mark = 10,
+ c abscr = 11, c inscr = 12,
+ c dezimal = 13, c esc = 14,
+ c backcr = 15;
+
+ ""1""2""3""8""9""10""11""12""13""16""17""18""19""27""20"" .
+
+dezimalen schreiben : IF write access THEN dezimaleditor (satz) FI .
+
+zurueck zur umbruchstelle:
+ IF umbruch stelle > 0 THEN stelle := umbruch stelle FI;
+ IF verschoben <> umbruch verschoben
+ THEN verschoben := umbruch verschoben; output mode := out feld
+ FI .
+
+hop kommandos behandeln :
+ TEXT VAR zweites zeichen; getchar (zweites zeichen);
+ zeichen CAT zweites zeichen;
+ SELECT pos (hop kommandos, zweites zeichen) OF
+ CASE h hop : nach links oben
+ CASE h right : nach rechts blaettern
+ CASE h left : nach links blaettern
+ CASE h tab : tab position definieren oder loeschen
+ CASE h rubin : zeile splitten
+ CASE h rubout : loeschen oder rekombinieren
+ CASE h cr, h up, h down : feldeditor verlassen
+ OTHERWISE : zeichen ignorieren
+ END SELECT .
+
+hop kommandos :
+ LET h hop = 1, h right = 2,
+ h up = 3, h left = 4,
+ h tab = 5, h down = 6,
+ h rubin = 7, h rubout = 8,
+ h cr = 9;
+
+ ""1""2""3""8""9""10""11""12""13"" .
+
+nach links oben :
+ stelle := max (marke, anfang) + verschoben; feldeditor verlassen .
+
+nach rechts blaettern :
+ INT CONST rechter rand := stelle am ende - markierausgleich;
+ IF stelle ist am rechten rand
+ THEN stelle INCR laenge - 2 * markierausgleich + ausgleich fuer doppelzeichen
+ ELSE stelle := rechter rand
+ FI ;
+ IF satzlaenge <= limit THEN stelle := min (stelle, limit) FI;
+ alte einrueckposition mitziehen .
+
+stelle ist am rechten rand :
+ stelle auf erstem halbzeichen CAND stelle = rechter rand - 1
+ COR stelle = rechter rand .
+
+ausgleich fuer doppelzeichen : stelle - rechter rand .
+
+nach links blaettern :
+ INT CONST linker rand := stelle am anfang;
+ IF stelle = linker rand
+ THEN stelle DECR laenge - 2 * markierausgleich
+ ELSE stelle := linker rand
+ FI ;
+ stelle := max (ganz links, stelle);
+ alte einrueckposition mitziehen .
+
+tab position definieren oder loeschen :
+ IF stelle > LENGTH tabulator
+ THEN tabulator AUFFUELLENMIT right; tabulator CAT dach
+ ELSE replace (tabulator, stelle, neues tab zeichen)
+ FI ;
+ feldeditor verlassen .
+
+neues tab zeichen :
+ IF (tabulator SUB stelle) = right THEN dach ELSE right FI .
+
+zeile splitten :
+ IF write access THEN feldeditor verlassen ELSE zeichen ignorieren FI .
+
+loeschen oder rekombinieren :
+ IF NOT write access
+ THEN zeichen ignorieren
+ ELIF hinter dem satz
+ THEN zeilen rekombinieren
+ ELIF auf erstem zeichen
+ THEN ganze zeile loeschen
+ ELSE zeilenrest loeschen
+ FI .
+
+zeilen rekombinieren : feldeditor verlassen .
+auf erstem zeichen : stelle = 1 .
+ganze zeile loeschen : satz := ""; feldeditor verlassen .
+
+zeilenrest loeschen :
+ change (satz, stelle, satzlaenge, "");
+ output mode := clear feldrest .
+
+esc kommandos behandeln :
+ getchar (zweites zeichen);
+ zeichen CAT zweites zeichen;
+ auf exit pruefen;
+ SELECT pos (esc kommandos, zweites zeichen) OF
+ CASE e hop : lernmodus umschalten
+ CASE e right : zum naechsten wort
+ CASE e left : zum vorigen wort
+ OTHERWISE : belegte taste ausfuehren
+ END SELECT .
+
+auf exit pruefen :
+ IF pos (res, zweites zeichen) > 0 THEN feldeditor verlassen FI .
+
+esc kommandos :
+ LET e hop = 1,
+ e right = 2,
+ e left = 3;
+
+ ""1""2""8"" .
+
+lernmodus umschalten :
+ IF lernmodus THEN lernmodus ausschalten ELSE lernmodus einschalten FI;
+ feldeditor verlassen .
+
+lernmodus ausschalten :
+ lernmodus := FALSE;
+ belegbare taste erfragen;
+ audit := subtext (audit, 1, LENGTH audit - 2);
+ IF taste = hop
+ THEN (* lernsequenz nicht auf taste legen *) (* 16.08.85 -ws- *)
+ ELSE lernsequenz auf taste legen (taste, audit)
+ FI ;
+ audit := "" .
+
+belegbare taste erfragen :
+ TEXT VAR taste; getchar (taste);
+ WHILE taste ist reserviert REP
+ benutzer warnen; getchar (taste)
+ PER .
+
+taste ist reserviert : (* 16.08.85 -ws- *)
+ taste <> hop CAND pos (reservierte feldeditor tasten, taste) > 0 .
+
+lernmodus einschalten : audit := ""; lernmodus := TRUE .
+
+zum vorigen wort :
+ IF stelle > 1
+ THEN stelle DECR 1; stelle := letzter wortanfang (satz);
+ alte einrueckposition mitziehen;
+ IF (satz SUB stelle) <> blank THEN LEAVE zum vorigen wort FI
+ FI ;
+ feldeditor verlassen .
+
+zum naechsten wort :
+ IF kein naechstes wort THEN feldeditor verlassen FI .
+
+kein naechstes wort :
+ BOOL VAR im alten wort := TRUE;
+ INT VAR i;
+ FOR i FROM stelle UPTO satzlaenge REP
+ IF im alten wort
+ THEN im alten wort := (satz SUB i) <> blank
+ ELIF (satz SUB i) <> blank
+ THEN stelle := i; LEAVE kein naechstes wort WITH FALSE
+ FI
+ PER;
+ TRUE .
+
+belegte taste ausfuehren :
+ IF ist kommando taste
+ THEN feldeditor verlassen
+ ELSE gelerntes ausfuehren
+ FI .
+
+ist kommando taste : taste enthaelt kommando (zweites zeichen) .
+
+gelerntes ausfuehren :
+ push (lernsequenz auf taste (zweites zeichen)) . (*sh*)
+
+nach rechts oder ueberlauf :
+ IF fliesstext COR stelle < limit OR satzlaenge > limit
+ THEN nach rechts
+ ELSE auf anfang der naechsten zeile
+ FI .
+
+nach rechts :
+ IF stelle auf erstem halbzeichen THEN stelle INCR 2 ELSE stelle INCR 1 FI;
+ alte einrueckposition mitziehen .
+
+auf anfang der naechsten zeile : push (abscr) .
+
+nach links : stelle DECR 1; alte einrueckposition mitziehen .
+
+alte einrueckposition mitziehen :
+ IF satz ist leerzeile
+ THEN alte einrueckposition := stelle
+ ELSE alte einrueckposition := min (stelle, einrueckposition (satz))
+ FI .
+
+satz ist leerzeile :
+ satz = "" OR satz = blank .
+
+wenn moeglich ein schritt nach links :
+ IF stelle = ganz links
+ THEN zeichen ignorieren
+ ELSE nach links
+ FI .
+
+zur naechsten tabulator position :
+ bestimme naechste explizite tabulator position;
+ IF tabulator gefunden
+ THEN explizit tabulieren
+ ELIF stelle <= satzlaenge
+ THEN implizit tabulieren
+ ELSE auf anfang der naechsten zeile
+ FI .
+
+bestimme naechste explizite tabulator position :
+ INT VAR tab position := pos (tabulator, dach, stelle + 1);
+ IF tab position > limit AND satzlaenge <= limit
+ THEN tab position := 0
+ FI .
+
+tabulator gefunden : tab position <> 0 .
+
+explizit tabulieren : stelle := tab position; push (dezimal) .
+
+implizit tabulieren :
+ tab position := einrueckposition (satz);
+ IF stelle < tab position
+ THEN stelle := tab position
+ ELSE stelle := satzlaenge + 1
+ FI .
+
+einfuegen umschalten :
+ IF NOT write access THEN zeichen ignorieren FI; (*sh*)
+ einfuegen := NOT einfuegen;
+ IF einfuegen THEN einfuegen optisch anzeigen FI;
+ feldeditor verlassen .
+
+einfuegen optisch anzeigen :
+ IF markiert
+ THEN out (begin mark); markleft; out (dach left); warten;
+ out (end mark); markleft
+ ELSE out (dach left); warten;
+ IF stelle auf erstem halbzeichen
+ THEN out text (satz, stelle, stelle + 1)
+ ELSE out text (satz, stelle, stelle)
+ FI
+ FI .
+
+markiert : marke > 0 .
+dach left : ""94""8"" .
+
+warten :
+ TEXT VAR t := incharety (2);
+ kommando CAT t; IF lernmodus THEN audit CAT t FI .
+
+ein zeichen loeschen :
+ IF NOT write access THEN zeichen ignorieren FI; (*sh*)
+ IF zeichen davor soll geloescht werden
+ THEN nach links oder ignorieren
+ FI ;
+ IF NOT hinter dem satz THEN aktuelles zeichen loeschen FI .
+
+zeichen davor soll geloescht werden :
+ hinter dem satz COR markiert .
+
+nach links oder ignorieren :
+ IF stelle > ganz links
+ THEN nach links (*sh*)
+ ELSE zeichen ignorieren
+ FI .
+
+aktuelles zeichen loeschen :
+ stelle korrigieren; alte stelle merken;
+ IF stelle auf erstem halbzeichen
+ THEN delete char (satz, stelle);
+ postblanks INCR 1
+ FI ;
+ delete char (satz, stelle);
+ postblanks INCR 1;
+ neue satzlaenge bestimmen;
+ output mode := out feldrest .
+
+eine zeile nach oben : (*sh*)
+ IF NOT absatzmarke steht CAND NOT ist teil eines umbruchkommandos
+ THEN blanks abschneiden
+ FI ;
+ push (zeichen); LEAVE feld editieren .
+
+ist teil eines umbruchkommandos : (kommando SUB kommandozeiger) = backcr .
+
+ggf absatz erzeugen : (*sh*)
+ IF write access
+ THEN IF NOT absatzmarke steht THEN blanks abschneiden FI;
+ IF stelle > LENGTH satz AND fliesstext AND NOT absatzmarke steht
+ THEN satz CAT blank
+ FI
+ FI ; push (zeichen); LEAVE feld editieren .
+
+markieren umschalten :
+ IF markiert
+ THEN marke := 0; maxschreibpos INCR marklength; cpos DECR marklength
+ ELSE marke := stelle; maxschreibpos DECR marklength; cpos INCR marklength;
+ verschieben wenn erforderlich
+ FI ;
+ feldeditor verlassen .
+
+sondertaste behandeln : push (esc + zeichen) .
+END PROC feldeditor;
+
+PROC dezimaleditor (TEXT VAR satz) :
+ INT VAR dezimalanfang := stelle;
+ zeichen einlesen;
+ IF dezimalstartzeichen CAND ueberschreibbar THEN dezimalen schreiben FI;
+ push (zeichen) .
+
+zeichen einlesen : TEXT VAR zeichen; getchar (zeichen) .
+dezimalzeichen : pos (dezimalen, zeichen) > 0 AND nicht separator .
+dezimalstartzeichen : pos (startdezimalen, zeichen) > 0 AND nicht separator .
+dezimalen : "0123456789" .
+startdezimalen : "+-0123456789" .
+nicht separator : pos (separator, zeichen) = 0 .
+
+ueberschreibbar :
+ dezimalanfang > LENGTH satz OR
+ pos (ueberschreibbare zeichen, satz SUB dezimalanfang) > 0 .
+
+ueberschreibbare zeichen : " ,.+-0123456789" .
+
+dezimalen schreiben :
+ REP
+ dezimale in satz eintragen;
+ dezimalen zeigen;
+ zeichen einlesen;
+ dezimalanfang DECR 1
+ UNTIL dezimaleditor beendet PER;
+ stelle INCR 1 .
+
+dezimale in satz eintragen :
+ IF dezimalanfang > LENGTH satz
+ THEN satz AUFFUELLENMIT blank; satz CAT zeichen
+ ELSE delete char (satz, dezimalanfang); insert char (satz, zeichen, stelle)
+ FI .
+
+dezimalen zeigen :
+ INT VAR min dezimalschreibpos := max (min schreibpos, dezimalanfang);
+ IF markiert THEN markiert zeigen ELSE unmarkiert zeigen FI;
+ schreibmarke positionieren (stelle) .
+
+markiert : marke > 0 .
+
+markiert zeigen :
+ invers out (satz, min dezimalschreibpos, stelle, "", end mark);
+ out (zeichen) .
+
+unmarkiert zeigen :
+ schreibmarke positionieren (min dezimalschreibpos);
+ out subtext (satz, min dezimalschreibpos, stelle) .
+
+dezimaleditor beendet :
+ NOT dezimalzeichen OR
+ dezimalanfang < max (min schreibpos, marke) OR
+ NOT ueberschreibbar .
+END PROC dezimaleditor;
+
+BOOL PROC is editget :
+ editget modus
+END PROC is editget ;
+
+PROC get editline (TEXT VAR editline, INT VAR editpos, editmarke) :
+ IF editget modus
+ THEN editline := alter editsatz;
+ editpos := stelle
+ FI ;
+ editmarke := marke
+END PROC get editline;
+
+PROC put editline (TEXT CONST editline, INT CONST editpos, editmarke) :
+ IF editget modus
+ THEN alter editsatz := editline;
+ stelle := max (editpos, 1);
+ marke := max (editmarke, 0)
+ FI
+END PROC put editline;
+
+BOOL PROC within kanji (TEXT CONST satz, INT CONST stelle) :
+ count directly prefixing kanji esc bytes;
+ number of kanji esc bytes is odd .
+
+count directly prefixing kanji esc bytes :
+ INT VAR pos := stelle - 1, kanji esc bytes := 0;
+ WHILE pos > 0 CAND is kanji esc (satz SUB pos) REP
+ kanji esc bytes INCR 1; pos DECR 1
+ PER .
+
+number of kanji esc bytes is odd :
+ (kanji esc bytes AND 1) <> 0 .
+END PROC within kanji;
+
+BOOL PROC is kanji esc (TEXT CONST char) : (*sh*)
+ two byte mode CAND
+ (char >= ""129"" AND char <= ""159"" OR char >= ""224"" AND char <= ""239"")
+END PROC is kanji esc;
+
+BOOL PROC two bytes : two byte mode END PROC two bytes;
+
+PROC two bytes (BOOL CONST new mode) :
+ two byte mode := new mode
+END PROC two bytes;
+
+PROC outtext (TEXT CONST source, INT CONST from, to) :
+ out subtext mit randbehandlung (source, from, to);
+ INT VAR trailing;
+ IF from <= LENGTH source
+ THEN trailing := to - LENGTH source
+ ELSE trailing := to - from + 1
+ FI ; trailing TIMESOUT blank
+END PROC outtext;
+
+PROC out subtext mit randbehandlung (TEXT CONST satz, INT CONST von, bis) :
+ IF von > bis
+ THEN
+ ELIF bis >= LENGTH satz COR NOT within kanji (satz, bis + 1)
+ THEN out subtext mit anfangsbehandlung (satz, von, bis)
+ ELSE out subtext mit anfangsbehandlung (satz, von, bis - 1); out (blank)
+ FI
+END PROC out subtext mit randbehandlung;
+
+PROC out subtext mit anfangsbehandlung (TEXT CONST satz, INT CONST von, bis) :
+ IF von > bis
+ THEN
+ ELIF von = 1 COR NOT within kanji (satz, von)
+ THEN out subtext (satz, von, bis)
+ ELSE out (blank); out subtext (satz, von + 1, bis)
+ FI
+END PROC out subtext mit anfangsbehandlung;
+
+PROC get cursor : get cursor (spalte, zeile) END PROC get cursor;
+
+INT PROC x cursor : get cursor; spalte END PROC x cursor;
+
+BOOL PROC write permission : write access END PROC write permission;
+
+PROC push (TEXT CONST ausfuehrkommando) :
+ IF ausfuehrkommando = "" (*sh*)
+ THEN
+ ELIF kommando = ""
+ THEN kommando := ausfuehrkommando
+ ELIF (kommando SUB kommando zeiger - 1) = ausfuehrkommando
+ THEN kommando zeiger DECR 1
+ ELIF replace moeglich
+ THEN kommando zeiger DECR laenge des ausfuehrkommandos;
+ replace (kommando, kommando zeiger, ausfuehrkommando)
+ ELSE insert char (kommando, ausfuehrkommando, kommando zeiger)
+ FI .
+
+replace moeglich :
+ INT CONST laenge des ausfuehrkommandos := LENGTH ausfuehrkommando;
+ kommando zeiger > laenge des ausfuehrkommandos .
+END PROC push;
+
+PROC type (TEXT CONST ausfuehrkommando) :
+ kommando CAT ausfuehrkommando
+END PROC type;
+
+INT PROC stelle am anfang : anfang + verschoben END PROC stelle am anfang;
+
+INT PROC stelle am ende : stelle am anfang+laenge-1 END PROC stelle am ende;
+
+INT PROC markierausgleich : SIGN marke * marklength END PROC markierausgleich;
+
+PROC verschieben wenn erforderlich :
+ IF stelle > max schreibpos
+ THEN verschiebe (stelle - max schreibpos)
+ ELIF stelle < min schreibpos
+ THEN verschiebe (stelle - min schreibpos)
+ FI
+END PROC verschieben wenn erforderlich;
+
+PROC verschiebe (INT CONST i) :
+ verschoben INCR i;
+ min schreibpos INCR i;
+ max schreibpos INCR i;
+ cpos DECR i;
+ output mode := out feld;
+ schreibmarke positionieren (stelle) (* 11.05.85 -ws- *)
+END PROC verschiebe;
+
+PROC konstanten neu berechnen :
+ min schreibpos := anfang + verschoben;
+ IF min schreibpos < 0 (* 17.05.85 -ws- *)
+ THEN min schreibpos DECR verschoben; verschoben := 0
+ FI ;
+ max schreibpos := min schreibpos + laenge - 1 - markierausgleich;
+ cpos := rand + laenge - max schreibpos
+END PROC konstanten neu berechnen;
+
+PROC schreibmarke positionieren (INT CONST sstelle) :
+ cursor (cpos + sstelle, zeile)
+END PROC schreibmarke positionieren;
+
+PROC simple feldout (TEXT CONST satz, INT CONST dummy) :
+ (* PRECONDITION : NOT markiert AND verschoben = 0 *)
+ (* AND feldrest schon geloescht *)
+ schreibmarke an feldanfang positionieren;
+ out subtext mit randbehandlung (satz, anfang, anfang + laenge - 1);
+ IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI .
+
+schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) .
+END PROC simple feldout;
+
+PROC feldout (TEXT CONST satz, INT CONST sstelle) :
+ schreibmarke an feldanfang positionieren;
+ feld ausgeben;
+ feldrest loeschen;
+ IF (satz SUB LENGTH satz) = blank THEN absatzmarke schreiben (TRUE) FI .
+
+schreibmarke an feldanfang positionieren : cursor (rand + 1, zeile) .
+
+feld ausgeben :
+ INT VAR von := anfang + verschoben, bis := von + laenge - 1;
+ IF nicht markiert
+ THEN unmarkiert ausgeben
+ ELIF markiertes nicht sichtbar
+ THEN unmarkiert ausgeben
+ ELSE markiert ausgeben
+ FI .
+
+nicht markiert : marke <= 0 .
+
+markiertes nicht sichtbar :
+ bis DECR marklength * (1 + SIGN sstelle); marke > bis + 1 .
+
+unmarkiert ausgeben :
+ out subtext mit randbehandlung (satz, von, bis) .
+
+markiert ausgeben :
+ INT VAR smarke := max (von, marke);
+ out text (satz, von, smarke - 1); out (begin mark);
+ verschiedene feldout modes behandeln .
+
+verschiedene feldout modes behandeln :
+ IF sstelle = 0
+ THEN out subtext mit randbehandlung (satz, smarke, bis); out (end mark)
+ ELSE out text (satz, smarke, zeilenrand); out (end mark); (*sh*)
+ out subtext mit randbehandlung (satz, sstelle, bis)
+ FI .
+
+zeilenrand : min (bis, sstelle - 1) .
+END PROC feldout;
+
+PROC absatzmarke schreiben (BOOL CONST schreiben) :
+ IF fliesstext AND nicht markiert
+ THEN cursor (rand + 1 + laenge, zeile);
+ out (absatzmarke) ;
+ absatzmarke steht := TRUE
+ FI .
+
+nicht markiert : marke <= 0 .
+
+absatzmarke :
+ IF NOT schreiben
+ THEN " "
+ ELIF marklength > 0
+ THEN ""15""14""
+ ELSE ""15" "14" "
+ FI .
+END PROC absatzmarke schreiben;
+
+PROC invers out (TEXT CONST satz, INT CONST von, bis, TEXT CONST pre, post) :
+ IF mark refresh line mode
+ THEN feldout (satz, stelle)
+ ELSE schreibmarke positionieren (von);
+ out (begin mark); markleft; out (pre);
+ out text (satz, von, bis - 1); out (post)
+ FI .
+
+markleft :
+ marklength TIMESOUT left .
+
+END PROC invers out;
+
+PROC feldrest loeschen :
+ IF rand + laenge < maxbreite COR invertierte darstellung
+ THEN INT VAR x; get cursor (x, zeile);
+ (rand + laenge - x + 1 + absatz ausgleich) TIMESOUT blank; (*sh*)
+ cursor (x, zeile)
+ ELSE out (clear eol); absatzmarke steht := FALSE
+ FI
+END PROC feldrest loeschen;
+
+OP AUFFUELLENMIT (TEXT VAR satz, TEXT CONST fuellzeichen) :
+ INT VAR i;
+ FOR i FROM stelle - LENGTH satz DOWNTO 2 REP
+ satz CAT fuellzeichen
+ PER
+END OP AUFFUELLENMIT;
+
+INT PROC einrueckposition (TEXT CONST satz) : (*sh*)
+ IF fliesstext AND satz = blank
+ THEN anfang
+ ELSE max (pos (satz, ""33"", ""254"", 1), 1)
+ FI
+END PROC einrueckposition;
+
+INT PROC letzter wortanfang (TEXT CONST satz) : (*sh*)
+ INT CONST ganz links := max (1, marke);
+ BOOL VAR noch nicht im neuen wort := TRUE;
+ INT VAR i;
+ FOR i FROM stelle DOWNTO ganz links REP
+ IF noch nicht im neuen wort
+ THEN noch nicht im neuen wort := char = blank
+ ELIF is kanji esc (char)
+ THEN LEAVE letzter wortanfang WITH i
+ ELIF nicht mehr im neuen wort
+ THEN LEAVE letzter wortanfang WITH i + 1
+ FI
+ PER ;
+ ganz links .
+
+char : satz SUB i .
+
+nicht mehr im neuen wort : char = blank COR within kanji (satz, i) .
+END PROC letzter wortanfang;
+
+PROC getchar (TEXT VAR zeichen) :
+ IF kommando = ""
+ THEN inchar (zeichen); IF lernmodus THEN audit CAT zeichen FI
+ ELSE zeichen := kommando SUB kommando zeiger;
+ kommando zeiger INCR 1;
+ IF kommando zeiger > LENGTH kommando
+ THEN kommando zeiger := 1; kommando := ""
+ FI ;
+ IF LENGTH kommando - kommando zeiger < 3
+ THEN kommando CAT inchety
+ FI
+ FI .
+END PROC getchar;
+
+TEXT PROC inchety :
+ IF lernmodus
+ THEN TEXT VAR t := incharety; audit CAT t; t
+ ELSE incharety
+ FI
+END PROC inchety;
+
+BOOL PROC is incharety (TEXT CONST muster) :
+ IF kommando = ""
+ THEN TEXT CONST t := inchety;
+ IF t = muster THEN TRUE ELSE kommando := t; FALSE FI
+ ELIF (kommando SUB kommando zeiger) = muster
+ THEN kommando zeiger INCR 1;
+ IF kommando zeiger > LENGTH kommando
+ THEN kommando zeiger := 1; kommando := ""
+ FI ;
+ TRUE
+ ELSE FALSE
+ FI
+END PROC is incharety;
+
+TEXT PROC getcharety :
+ IF kommando = ""
+ THEN inchety
+ ELSE TEXT CONST t := kommando SUB kommando zeiger;
+ kommando zeiger INCR 1;
+ IF kommando zeiger > LENGTH kommando
+ THEN kommando zeiger := 1; kommando := ""
+ FI ; t
+ FI
+END PROC getcharety;
+
+PROC get editcursor (INT VAR x, y) : (*sh*)
+ IF actual editor > 0 THEN aktualisiere bildparameter FI;
+ x := rand - (anfang + verschoben - 1 - markierausgleich) + stelle;
+ y := zeile .
+
+ aktualisiere bildparameter :
+ INT VAR old x, old y; get cursor (old x, old y);
+ dateizustand holen; bildausgabe steuern; satznr zeigen;
+ fenster zeigen; zeile := bildrand + zeilennr; cursor (old x, old y) .
+END PROC get editcursor;
+
+(************************* Zugriff auf Feldstatus *************************).
+
+stelle : feldstatus.stelle .
+alte stelle : feldstatus.alte stelle .
+rand : feldstatus.rand .
+limit : feldstatus.limit .
+anfang : feldstatus.anfang .
+marke : feldstatus.marke .
+laenge : feldstatus.laenge .
+verschoben : feldstatus.verschoben .
+einfuegen : feldstatus.einfuegen .
+fliesstext : feldstatus.fliesstext .
+write access : feldstatus.write access .
+tabulator : feldstatus.tabulator .
+
+(***************************************************************************)
+
+LET undefinierter bereich = 0, nix = 1,
+ bildzeile = 2, akt satznr = 2,
+ abschnitt = 3, ueberschrift = 3,
+ bild = 4, fehlermeldung = 4;
+
+LET BILDSTATUS = STRUCT (INT feldlaenge, kurze feldlaenge,
+ bildrand, bildlaenge, kurze bildlaenge,
+ ueberschriftbereich, bildbereich,
+ erster neusatz, letzter neusatz,
+ old zeilennr, old lineno, old mark lineno,
+ BOOL zeileneinfuegen, old line update,
+ TEXT satznr pre, ueberschrift pre,
+ ueberschrift text, ueberschrift post, old satz,
+ FRANGE old range,
+ FILE file),
+ EDITSTATUS = STRUCT (FELDSTATUS feldstatus, BILDSTATUS bildstatus),
+ max editor = 10,
+ EDITSTACK = ROW max editor EDITSTATUS;
+
+BILDSTATUS VAR bildstatus ;
+EDITSTACK VAR editstack;
+
+ROW max editor INT VAR einrueckstack;
+
+BOOL VAR markiert;
+TEXT VAR filename, tab, bildsatz, bildzeichen, fehlertext,
+ akt bildsatz ;
+INT VAR zeilennr, satznr, bildanfang, bildmarke, feldmarke,
+ actual editor := 0, max used editor := 0,
+ letzer editor auf dieser datei,
+ alte einrueckposition := 1;
+
+INT PROC aktueller editor : actual editor END PROC aktueller editor;
+
+INT PROC groesster editor : max used editor END PROC groesster editor;
+
+(****************************** bildeditor *******************************)
+
+PROC bildeditor (TEXT CONST res, PROC (TEXT CONST) kommando interpreter) :
+ evtl fehler behandeln;
+ enable stop;
+ TEXT VAR reservierte tasten := ""11""12""27"bf" ;
+ reservierte tasten CAT res ;
+ INT CONST my highest editor := max used editor;
+ laenge := feldlaenge;
+ konstanten neu berechnen;
+ REP
+ markierung justieren;
+ altes feld nachbereiten;
+ feldlaenge einstellen;
+ ueberschrift zeigen;
+ fenster zeigen ;
+ zeile bereitstellen;
+ zeile editieren;
+ kommando ausfuehren
+ PER .
+
+evtl fehler behandeln :
+ IF is error
+ THEN fehlertext := errormessage;
+ IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI;
+ clear error
+ ELSE fehlertext := ""
+ FI .
+
+markierung justieren :
+ IF bildmarke > 0
+ THEN IF satznr <= bildmarke
+ THEN bildmarke := satznr;
+ stelle := max (stelle, feldmarke);
+ marke := feldmarke
+ ELSE marke := 1
+ FI
+ FI .
+
+zeile bereitstellen : IF hinter letztem satz THEN insert record (file) FI .
+hinter letztem satz : lineno (file) > lines (file) .
+
+altes feld nachbereiten :
+ IF old line update AND lineno (file) <> old lineno
+ THEN IF verschoben <> 0
+ THEN verschoben := 0; konstanten neu berechnen;
+ FI ;
+ INT CONST alte zeilennr := old lineno - bildanfang + 1;
+ IF alte zeilennr > 0 AND alte zeilennr <= aktuelle bildlaenge
+ THEN INT CONST m := marke;
+ IF lineno (file) < old lineno
+ THEN marke := 0
+ ELIF old lineno = bildmarke
+ THEN marke := min (feldmarke, LENGTH old satz + 1)
+ ELSE marke := min (marke, LENGTH old satz + 1)
+ FI ;
+ zeile := bildrand + alte zeilennr;
+ feldout (old satz, 0); marke := m
+ FI
+ FI ;
+ old line update := FALSE; old satz := "" .
+
+feldlaenge einstellen :
+ INT CONST alte laenge := laenge;
+ IF zeilennr > kurze bildlaenge
+ THEN laenge := kurze feldlaenge
+ ELSE laenge := feldlaenge
+ FI ;
+ IF laenge <> alte laenge
+ THEN konstanten neu berechnen
+ FI .
+
+zeile editieren :
+ zeile := bildrand + zeilennr;
+ exec (PROC (TEXT VAR, TEXT CONST) feldeditor, file, reservierte tasten);
+ old lineno := satznr;
+ IF markiert oder verschoben
+ THEN old line update := TRUE; read record (file, old satz)
+ FI .
+
+markiert oder verschoben : markiert COR verschoben <> 0 .
+
+kommando ausfuehren :
+ getchar (bildzeichen);
+ SELECT pos (kommandos, bildzeichen) OF
+ CASE x hop : hop kommando verarbeiten
+ CASE x esc : esc kommando verarbeiten
+ CASE x up : zum vorigen satz
+ CASE x down : zum folgenden satz
+ CASE x rubin : zeicheneinfuegen umschalten
+ CASE x mark : markierung umschalten
+ CASE x cr : eingerueckt mit cr (* 08.06.85 -ws- *)
+ CASE x inscr : eingerueckt zum folgenden satz
+ CASE x abscr : zum anfang des folgenden satzes
+ END SELECT .
+
+kommandos :
+ LET x hop = 1, x up = 2,
+ x down = 3, x rubin = 4,
+ x cr = 5, x mark = 6,
+ x abscr = 7, x inscr = 8,
+ x esc = 9;
+
+ ""1""3""10""11""13""16""17""18""27"" .
+
+zeicheneinfuegen umschalten :
+ rubin segment in ueberschrift eintragen;
+ neu (ueberschrift, nix) .
+
+rubin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 9, rubin segment) .
+
+rubin segment :
+ IF einfuegen THEN "RUBIN" ELSE "....." FI .
+
+hop kommando verarbeiten :
+ getchar (bildzeichen);
+ read record (file, bildsatz);
+ SELECT pos (hop kommandos, bildzeichen) OF
+ CASE y hop : nach oben
+ CASE y cr : neue seite
+ CASE y up : zurueckblaettern
+ CASE y down : weiterblaettern
+ CASE y tab : put tabs (file, tabulator); neu (ueberschrift, nix)
+ CASE y rubout : zeile loeschen
+ CASE y rubin : zeileneinfuegen umschalten
+ END SELECT .
+
+hop kommandos :
+ LET y hop = 1, y up = 2,
+ y tab = 3, y down = 4,
+ y rubin = 5, y rubout = 6,
+ y cr = 7;
+
+ ""1""3""9""10""11""12""13"" .
+
+zeileneinfuegen umschalten :
+ zeileneinfuegen := NOT zeileneinfuegen;
+ IF zeileneinfuegen
+ THEN zeile aufspalten; logisches eof setzen
+ ELSE leere zeile am ende loeschen; logisches eof loeschen
+ FI ; restbild zeigen .
+
+zeile aufspalten :
+ IF stelle <= LENGTH bildsatz OR stelle = 1
+ THEN loesche ggf trennende blanks und spalte zeile
+ FI .
+
+loesche ggf trennende blanks und spalte zeile: (* 26.06.84 -bk- *)
+ INT VAR first non blank pos := stelle;
+ WHILE first non blank pos <= length (bildsatz) CAND
+ (bildsatz SUB first non blank pos) = blank REP
+ first non blank pos INCR 1
+ PER ;
+ split line and indentation; (*sh*)
+ first non blank pos := stelle - 1;
+ WHILE first non blank pos >= 1 CAND
+ (bildsatz SUB first non blank pos) = blank REP
+ first non blank pos DECR 1
+ PER;
+ bildsatz := subtext (bildsatz, 1, first non blank pos);
+ write record (file, bildsatz) .
+
+split line and indentation :
+ split line (file, first non blank pos, TRUE) .
+
+logisches eof setzen :
+ down (file); col (file, 1);
+ set range (file, 1, 1, old range); up (file) .
+
+leere zeile am ende loeschen :
+ to line (file, lines (file));
+ IF len (file) = 0 THEN delete record (file) FI;
+ to line (file, satznr) .
+
+logisches eof loeschen :
+ col (file, stelle); set range (file, old range) .
+
+restbild zeigen :
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ rest segment in ueberschrift eintragen;
+ neu (ueberschrift, abschnitt) .
+
+rest segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 25, rest segment) .
+
+rest segment :
+ IF zeileneinfuegen THEN "REST" ELSE "...." FI .
+
+esc kommando verarbeiten :
+ getchar (bildzeichen);
+ eventuell zeichen zurueckweisen; (* 04.05.85 -ws- *)
+ IF taste ist reserviert
+ THEN belegte taste ausfuehren
+ ELSE fest vordefinierte esc funktion
+ FI ; ende nach quit .
+
+eventuell zeichen zurueckweisen : (* 04.05.85 -ws- *)
+ IF NOT write access CAND NOT erlaubte taste
+ THEN benutzer warnen; LEAVE kommando ausfuehren
+ FI .
+
+erlaubte taste : pos (zulaessige zeichen, bildzeichen) > 0 .
+zulaessige zeichen : res + ""1""2""8""27"bfq" .
+benutzer warnen : out (piep) .
+
+ende nach quit :
+ IF max used editor < my highest editor THEN LEAVE bildeditor FI .
+
+taste ist reserviert : pos (res, bildzeichen) > 0 .
+
+fest vordefinierte esc funktion :
+ read record (file, bildsatz);
+ SELECT pos (esc kommandos, bildzeichen) OF
+ CASE z hop : lernmodus umschalten
+ CASE z esc : kommandodialog versuchen
+ CASE z left : zum vorigen wort
+ CASE z right : zum naechsten wort
+ CASE z b : bild an aktuelle zeile angleichen
+ CASE z f : belegte taste ausfuehren
+ CASE z rubout : markiertes vorsichtig loeschen
+ CASE z rubin : vorsichtig geloeschtes einfuegen
+ OTHERWISE : belegte taste ausfuehren
+ END SELECT .
+
+esc kommandos :
+ LET z hop = 1, z right = 2,
+ z left = 3, z rubin = 4,
+ z rubout = 5, z esc = 6,
+ z b = 7, z f = 8;
+
+ ""1""2""8""11""12""27"bf" .
+
+zum vorigen wort :
+ IF vorgaenger erlaubt
+ THEN vorgaenger; read record (file, bildsatz);
+ stelle := LENGTH bildsatz + 1; push (esc + left)
+ FI .
+
+vorgaenger erlaubt :
+ satznr > max (1, bildmarke) .
+
+zum naechsten wort :
+ IF nicht auf letztem satz THEN weitersuchen wenn nicht gefunden FI .
+
+nicht auf letztem satz : line no (file) < lines (file) .
+
+weitersuchen wenn nicht gefunden :
+ nachfolgenden satz holen;
+ IF (nachfolgender satz SUB anfang) = blank
+ THEN push (abscr + esc + right)
+ ELSE push (abscr)
+ FI .
+
+nachfolgenden satz holen :
+ down (file); read record (file, nachfolgender satz); up (file) .
+
+bild an aktuelle zeile angleichen :
+ anfang INCR verschoben; verschoben := 0;
+ margin segment in ueberschrift eintragen;
+ neu (ueberschrift, bild) .
+
+margin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 2, margin segment) .
+
+margin segment :
+ IF anfang <= 1
+ THEN "......"
+ ELSE TEXT VAR margin text := "M" + text (anfang);
+ (6 - LENGTH margin text) * "." + margin text
+ FI .
+
+belegte taste ausfuehren :
+ kommando analysieren (bildzeichen, PROC(TEXT CONST) kommando interpreter) .
+
+kommandodialog versuchen:
+ IF fenster ist zu schmal fuer dialog
+ THEN kommandodialog ablehnen
+ ELSE kommandodialog fuehren
+ FI .
+
+fenster ist zu schmal fuer dialog : laenge < 20 .
+
+kommandodialog ablehnen :
+ fehlertext := "zu schmal fuer ESC ESC"; neu (fehlermeldung, nix) .
+
+kommandodialog fuehren:
+ INT VAR x0, x1, x2, x3, y;
+ get cursor (x0, y);
+ cursor (rand + 1, bildrand + zeilennr);
+ get cursor (x1, y);
+ out (begin mark); out (monitor meldung);
+ get cursor (x2, y);
+ (laenge - LENGTH monitor meldung - marklength) TIMESOUT blank;
+ get cursor (x3, y);
+ out (end mark); out (blank);
+ kommandozeile editieren;
+ ueberschrift zeigen;
+ absatz ausgleich := 2; (*sh*)
+ IF kommandotext = "" THEN LEAVE kommandodialog fuehren FI;
+ kommando auf taste legen ("f", kommandotext);
+ kommando analysieren ("f", PROC(TEXT CONST) kommando interpreter);
+ IF fehlertext <> ""
+ THEN push (esc + esc + esc + "k")
+ ELIF markiert
+ THEN zeile neu
+ FI .
+
+kommandozeile editieren :
+ TEXT VAR kommandotext := "";
+ cursor (x1, y); out (begin mark);
+ disable stop;
+ darstellung invertieren;
+ editget schleife;
+ darstellung invertieren;
+ enable stop;
+ cursor (x3, y); out (end mark);
+ exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle);
+ cursor (x0, y) .
+
+darstellung invertieren :
+ TEXT VAR dummy := begin mark; begin mark := end mark; end mark := dummy;
+ invertierte darstellung := NOT invertierte darstellung .
+
+editget schleife :
+ TEXT VAR exit char;
+ REP
+ cursor (x2, y);
+ editget (kommandotext, max textlength, rand + laenge - x cursor,
+ "", "k?!", exit char);
+ neu (ueberschrift, nix);
+ IF exit char = ""27"k"
+ THEN kommando text := kommando auf taste ("f")
+ ELIF exit char = ""27"?"
+ THEN TEXT VAR taste; getchar (taste);
+ kommando text := kommando auf taste (taste)
+ ELIF exit char = ""27"!"
+ THEN getchar (taste);
+ IF ist reservierte taste
+ THEN set busy indicator; (*sh*)
+ out ("FEHLER: """ + taste + """ ist reserviert"7"")
+ ELSE kommando auf taste legen (taste, kommandotext);
+ kommandotext := ""; LEAVE editget schleife
+ FI
+ ELSE LEAVE editget schleife
+ FI
+ PER .
+
+ist reservierte taste : pos (res, taste) > 0 .
+monitor meldung : "gib kommando : " .
+
+neue seite : bildanfang := satznr; zeilennr := 1; neu (akt satznr, bild) .
+
+weiterblaettern :
+ INT CONST akt bildlaenge := aktuelle bildlaenge;
+ IF nicht auf letztem satz
+ THEN erster neusatz := satznr;
+ IF zeilennr >= akt bildlaenge
+ THEN bildanfang INCR akt bildlaenge; neu (akt satznr, bild)
+ FI ;
+ satznr := min (lines (file), bildanfang + akt bildlaenge - 1);
+ letzter neusatz := satznr;
+ toline (file, satznr);
+ stelle DECR verschoben;
+ neu (akt satznr, nix);
+ zeilennr := satznr - bildanfang + 1;
+ IF markiert THEN neu (nix, abschnitt) FI;
+ einrueckposition bestimmen
+ FI .
+
+zurueckblaettern :
+ IF vorgaenger erlaubt
+ THEN IF zeilennr <= 1
+ THEN bildanfang := max (1, bildanfang - aktuelle bildlaenge);
+ neu (akt satznr, bild)
+ FI ;
+ nach oben; einrueckposition bestimmen
+ FI .
+
+zeile loeschen :
+ IF stelle = 1
+ THEN delete record (file);
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ neu (nix, abschnitt)
+ ELSE zeilen rekombinieren
+ FI .
+
+zeilen rekombinieren :
+ IF nicht auf letztem satz
+ THEN aktuellen satz mit blanks auffuellen;
+ delete record (file);
+ nachfolgenden satz lesen;
+ bildsatz CAT nachfolgender satz ohne fuehrende blanks;
+ write record (file, bildsatz);
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ neu (nix, abschnitt)
+ FI .
+
+aktuellen satz mit blanks auffuellen :
+ bildsatz AUFFUELLENMIT blank .
+
+nachfolgenden satz lesen :
+ TEXT VAR nachfolgender satz;
+ read record (file, nachfolgender satz) .
+
+nachfolgender satz ohne fuehrende blanks :
+ satzrest := subtext (nachfolgender satz,
+ einrueckposition (nachfolgender satz)); satzrest .
+
+zeile aufsplitten :
+ nachfolgender satz := "";
+ INT VAR i;
+ FOR i FROM 2 UPTO min (stelle, einrueckposition (bildsatz)) REP
+ nachfolgender satz CAT blank
+ PER;
+ satzrest := subtext (bildsatz, naechste non blank position);
+ nachfolgender satz CAT satzrest;
+ bildsatz := subtext (bildsatz, 1, stelle - 1);
+ write record (file, bildsatz);
+ down (file); insert record (file);
+ write record (file, nachfolgender satz); up (file) .
+
+naechste non blank position :
+ INT VAR non blank pos := stelle;
+ WHILE (bildsatz SUB non blank pos) = blank REP
+ non blank pos INCR 1
+ PER; non blank pos .
+
+zum vorigen satz :
+ IF vorgaenger erlaubt THEN vorgaenger; einrueckposition bestimmen FI .
+
+zum folgenden satz : (* 12.09.85 -ws- *)
+ IF nachfolger erlaubt THEN nachfolger; einrueckposition bestimmen
+ ELSE col (file, len (file) + 1); neu (nix, nix)
+ FI .
+
+einrueckposition bestimmen : (* 27.08.85 -ws- *)
+ read record (file, akt bildsatz);
+ INT VAR neue einrueckposition := einrueckposition (akt bildsatz);
+ IF akt bildsatz ist leerzeile
+ THEN alte einrueckposition := max (stelle, neue einrueckposition)
+ ELSE alte einrueckposition := min (stelle, neue einrueckposition)
+ FI .
+
+akt bildsatz ist leerzeile :
+ akt bildsatz = "" OR akt bildsatz = blank .
+
+zum anfang des folgenden satzes :
+ IF nachfolger erlaubt THEN nachfolger; stelle := anfang FI .
+
+nachfolger erlaubt :
+ write access COR nicht auf letztem satz .
+
+eingerueckt mit cr :
+ IF NOT nachfolger erlaubt THEN LEAVE eingerueckt mit cr FI; (*sh*)
+ read record (file, bildsatz);
+ INT VAR epos := einrueckposition (bildsatz);
+ nachfolger; col (file, 1);
+ IF eof (file)
+ THEN IF LENGTH bildsatz <= epos
+ THEN stelle := alte einrueckposition
+ ELSE stelle := epos
+ FI
+ ELSE read record (file, bildsatz);
+ stelle := einrueckposition (bildsatz);
+ IF bildsatz ist leerzeile (* 29.08.85 -ws- *)
+ THEN stelle := alte einrueckposition;
+ aktuellen satz mit blanks auffuellen
+ FI
+ FI ;
+ alte einrueckposition := stelle .
+
+bildsatz ist leerzeile :
+ bildsatz = "" OR bildsatz = blank .
+
+eingerueckt zum folgenden satz : (*sh*)
+ IF NOT nachfolger erlaubt OR NOT write access
+ THEN LEAVE eingerueckt zum folgenden satz
+ FI;
+ alte einrueckposition merken;
+ naechsten satz holen;
+ neue einrueckposition bestimmen;
+ alte einrueckposition := stelle .
+
+alte einrueckposition merken :
+ read record (file, bildsatz);
+ epos := einrueckposition (bildsatz);
+ auf aufzaehlung pruefen;
+ IF epos > LENGTH bildsatz THEN epos := anfang FI.
+
+auf aufzaehlung pruefen :
+ BOOL CONST aufzaehlung gefunden :=
+ ist aufzaehlung CAND vorher absatzzeile CAND wort folgt;
+ IF aufzaehlung gefunden THEN epos := anfang des naechsten wortes FI .
+
+ist aufzaehlung :
+ INT CONST wortende := pos (bildsatz, blank, epos, epos + 20) - 1;
+ SELECT pos ("-*).:" , bildsatz SUB wortende) OF
+ CASE 1,2 : wortende = epos
+ CASE 3,4 : wortende <= epos + 7
+ CASE 5 : TRUE
+ OTHERWISE: FALSE
+ ENDSELECT .
+
+vorher absatzzeile :
+ IF satznr = 1
+ THEN TRUE
+ ELSE up (file);
+ INT CONST vorige satzlaenge := len (file);
+ BOOL CONST vorher war absatzzeile :=
+ subtext (file, vorige satzlaenge, vorige satzlaenge) = blank;
+ down (file); vorher war absatzzeile
+ FI .
+
+wort folgt :
+ INT CONST anfang des naechsten wortes :=
+ pos (bildsatz, ""33"", ""254"", wortende + 1);
+ anfang des naechsten wortes > wortende .
+
+naechsten satz holen :
+ nachfolger; col (file, 1);
+ IF eof (file)
+ THEN bildsatz := ""
+ ELSE IF neue zeile einfuegen erforderlich
+ THEN insert record (file); bildsatz := "";
+ letzter neusatz := bildanfang + bildlaenge - 1
+ ELSE read record (file, bildsatz);
+ letzter neusatz := satznr;
+ ggf trennungen zurueckwandeln und umbruch indikator einfuegen
+ FI ;
+ erster neusatz := satznr;
+ neu (nix, abschnitt)
+ FI .
+
+neue zeile einfuegen erforderlich :
+ BOOL CONST war absatz := war absatzzeile;
+ war absatz COR neuer satz ist zu lang .
+
+war absatzzeile :
+ INT VAR wl := pos (kommando, up backcr, kommando zeiger);
+ wl = 0 COR (kommando SUB (wl - 1)) = blank .
+
+neuer satz ist zu lang : laenge des neuen satzes >= limit .
+
+laenge des neuen satzes :
+ IF len (file) > 0
+ THEN len (file) + wl
+ ELSE wl + epos
+ FI .
+
+up backcr : ""3""20"" .
+
+ggf trennungen zurueckwandeln und umbruch indikator einfuegen :
+ LET trenn k = ""220"",
+ trenn strich = ""221"";
+ TEXT VAR umbruch indikator;
+ IF letztes zeichen ist trenn strich
+ THEN entferne trenn strich;
+ IF letztes zeichen = trenn k
+ THEN wandle trenn k um
+ FI ;
+ umbruch indikator := up backcr
+ ELIF letztes umgebrochenes zeichen ist kanji
+ THEN umbruch indikator := up backcr
+ ELSE umbruch indikator := blank + up backcr
+ FI ;
+ change (kommando, wl, wl+1, umbruch indikator) .
+
+letztes umgebrochenes zeichen ist kanji : within kanji (kommando, wl-1) .
+
+letztes zeichen ist trenn strich :
+ TEXT CONST last char := letztes zeichen;
+ last char = trenn strich COR
+ last char = "-" CAND wl > 2 CAND (kommando SUB (wl-2)) <> blank .
+
+letztes zeichen : kommando SUB (wl-1) .
+entferne trenn strich : delete char (kommando, wl-1); wl DECR 1 .
+wandle trenn k um : replace (kommando, wl-1, "c") .
+loesche indikator : delete char (kommando, wl) .
+
+neue einrueckposition bestimmen :
+ IF aufzaehlung gefunden CAND bildsatz ist leerzeile
+ THEN stelle := epos
+ ELIF NOT bildsatz ist leerzeile
+ THEN stelle := einrueckposition (bildsatz)
+ ELIF war absatz COR auf letztem satz
+ THEN stelle := epos
+ ELSE down (file); read record (file, nachfolgender satz);
+ up (file); stelle := einrueckposition (nachfolgender satz)
+ FI ;
+ IF ist einfuegender aber nicht induzierter umbruch
+ THEN loesche indikator;
+ umbruchstelle := stelle + wl - kommando zeiger - anzahl der stz;
+ umbruchverschoben := 0
+ FI .
+
+auf letztem satz : NOT nicht auf letztem satz .
+
+ist einfuegender aber nicht induzierter umbruch :
+ wl := pos (kommando, backcr, kommando zeiger);
+ wl > 0 CAND (kommando SUB (wl - 1)) <> up char .
+
+anzahl der stz :
+ TEXT CONST umgebrochener anfang := subtext (kommando, kommando zeiger, wl-1);
+ INT VAR anz := 0, anf := pos (umgebrochener anfang, ""1"", ""31"", 1);
+ WHILE anf > 0 REP
+ anz INCR 1; anf := pos (umgebrochener anfang, ""1"", ""31"", anf + 1)
+ PER; anz .
+
+markiertes vorsichtig loeschen :
+ IF write access CAND markiert
+ THEN clear removed (file);
+ IF nur im satz markiert
+ THEN behandle einen satz
+ ELSE behandle mehrere saetze
+ FI
+ FI .
+
+nur im satz markiert : line no (file) = bildmarke .
+
+behandle einen satz :
+ insert record (file);
+ satzrest := subtext (bildsatz, marke, stelle - 1);
+ write record (file, satzrest);
+ remove (file, 1);
+ change (bildsatz, marke, stelle - 1, "");
+ stelle := marke;
+ marke := 0; bildmarke := 0; feldmarke := 0;
+ markiert := FALSE; mark (file, 0, 0);
+ konstanten neu berechnen;
+ IF bildsatz = ""
+ THEN delete record (file);
+ erster neusatz := satznr;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ neu (nix, abschnitt)
+ ELSE write record (file, bildsatz);
+ neu (nix, bildzeile)
+ FI .
+
+behandle mehrere saetze :
+ erster neusatz := bildmarke;
+ letzter neusatz := bildanfang + bildlaenge - 1;
+ zeile an aktueller stelle auftrennen;
+ ersten markierten satz an markieranfang aufspalten;
+ markierten bereich entfernen;
+ bild anpassen .
+
+zeile an aktueller stelle auftrennen :
+ INT VAR markierte saetze := line no (file) - bildmarke + 1;
+ IF nicht am ende der zeile
+ THEN IF nicht am anfang der zeile
+ THEN zeile aufsplitten
+ ELSE up (file); markierte saetze DECR 1
+ FI
+ FI .
+
+nicht am anfang der zeile : stelle > 1 .
+nicht am ende der zeile : stelle <= LENGTH bildsatz .
+
+ersten markierten satz an markieranfang aufspalten :
+ to line (file, line no (file) - (markierte saetze - 1));
+ read record (file, bildsatz);
+ stelle := feldmarke;
+ IF nicht am anfang der zeile
+ THEN IF nicht am ende der zeile
+ THEN zeile aufsplitten
+ ELSE markierte saetze DECR 1
+ FI ;
+ to line (file, line no (file) + markierte saetze)
+ ELSE to line (file, line no (file) + markierte saetze - 1)
+ FI ;
+ read record (file, bildsatz) .
+
+markierten bereich entfernen :
+ zeilen nr := line no (file) - markierte saetze - bildanfang + 2;
+ remove (file, markierte saetze);
+ marke := 0; bildmarke := 0; feldmarke := 0;
+ markiert := FALSE; mark (file, 0, 0);
+ konstanten neu berechnen;
+ stelle := 1 .
+
+bild anpassen :
+ satz nr := line no (file);
+ IF zeilen nr <= 1
+ THEN bildanfang := line no (file); zeilen nr := 1;
+ neu (akt satznr, bild)
+ ELSE neu (akt satznr, abschnitt)
+ FI .
+
+vorsichtig geloeschtes einfuegen :
+ IF NOT write access OR removed lines (file) = 0
+ THEN LEAVE vorsichtig geloeschtes einfuegen
+ FI ;
+ IF nur ein satz
+ THEN in aktuellen satz einfuegen
+ ELSE aktuellen satz aufbrechen und einfuegen
+ FI .
+
+nur ein satz : removed lines (file) = 1 .
+
+in aktuellen satz einfuegen :
+ reinsert (file);
+ read record (file, nachfolgender satz);
+ delete record (file);
+ TEXT VAR t := bildsatz;
+ bildsatz := subtext (t, 1, stelle - 1);
+ aktuellen satz mit blanks auffuellen; (*sh*)
+ bildsatz CAT nachfolgender satz;
+ satzrest := subtext (t, stelle);
+ bildsatz CAT satzrest;
+ write record (file, bildsatz);
+ stelle INCR LENGTH nachfolgender satz;
+ neu (nix, bildzeile) .
+
+aktuellen satz aufbrechen und einfuegen :
+ INT CONST alter bildanfang := bildanfang;
+ old lineno := satznr;
+ IF stelle = 1
+ THEN reinsert (file);
+ read record (file, bildsatz)
+ ELIF stelle > LENGTH bildsatz
+ THEN down (file);
+ reinsert (file);
+ read record (file, bildsatz)
+ ELSE INT VAR von := stelle;
+ WHILE (bildsatz SUB von) = blank REP von INCR 1 PER;
+ satzrest := subtext (bildsatz, von, LENGTH bildsatz);
+ INT VAR bis := stelle - 1;
+ WHILE (bildsatz SUB bis) = blank REP bis DECR 1 PER;
+ bildsatz := subtext (bildsatz, 1, bis);
+ write record (file, bildsatz);
+ down (file);
+ reinsert (file);
+ read record (file, bildsatz);
+ nachfolgender satz := einrueckposition (bildsatz) * blank;
+ nachfolgender satz CAT satzrest;
+ down (file); insert record (file);
+ write record (file, nachfolgender satz); up (file)
+ FI ;
+ stelle := max (1, LENGTH bildsatz); (* 22.06.84 -bk- *)
+ satz nr := line no (file);
+ zeilennr INCR satznr - old lineno;
+ zeilennr := min (zeilennr, aktuelle bildlaenge);
+ bildanfang := satznr - zeilennr + 1;
+ IF bildanfang veraendert
+ THEN abschnitt neu (bildanfang, 9999)
+ ELSE abschnitt neu (old lineno, 9999)
+ FI ;
+ neu (akt satznr, nix).
+
+bildanfang veraendert : bildanfang <> alter bildanfang .
+
+lernmodus umschalten :
+ learn segment in ueberschrift eintragen; neu (ueberschrift, nix) .
+
+learn segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 19, learn segment) .
+
+learn segment :
+ IF lernmodus THEN "LEARN" ELSE "....." FI .
+
+markierung umschalten :
+ IF markiert THEN markierung ausschalten ELSE markierung einschalten FI .
+
+markierung einschalten :
+ bildmarke := satznr; feldmarke := marke; markiert := TRUE;
+ mark (file, bildmarke, feldmarke);
+ neu (nix, bildzeile) .
+
+markierung ausschalten :
+ erster neusatz := max (bildmarke, bildanfang);
+ letzter neusatz := satznr;
+ bildmarke := 0; feldmarke := 0; markiert := FALSE;
+ mark (file, 0, 0);
+ IF erster neusatz = letzter neusatz
+ THEN neu (nix, bildzeile)
+ ELSE neu (nix, abschnitt)
+ FI .
+END PROC bildeditor;
+
+PROC neu (INT CONST ue bereich, b bereich) :
+ ueberschriftbereich := max (ueberschriftbereich, ue bereich);
+ bildbereich := max (bildbereich, b bereich)
+END PROC neu;
+
+
+PROC nach oben :
+ letzter neusatz := satznr;
+ satznr := max (bildanfang, bildmarke);
+ toline (file, satznr);
+ stelle DECR verschoben;
+ zeilennr := satznr - bildanfang + 1;
+ erster neusatz := satznr;
+ IF markiert
+ THEN neu (akt satznr, abschnitt)
+ ELSE neu (akt satznr, nix)
+ FI
+END PROC nach oben;
+
+INT PROC aktuelle bildlaenge :
+ IF stelle - stelle am anfang < kurze feldlaenge
+ AND feldlaenge > 0
+ THEN bildlaenge (*wk*)
+ ELSE kurze bildlaenge
+ FI
+END PROC aktuelle bildlaenge;
+
+PROC vorgaenger :
+ up (file); satznr DECR 1;
+ marke := 0; stelle DECR verschoben;
+ IF zeilennr = 1
+ THEN bildanfang DECR 1; neu (ueberschrift, bild)
+ ELSE zeilennr DECR 1; neu (akt satznr, nix); (*sh*)
+ IF markiert THEN neu (nix, bildzeile) FI
+ FI
+END PROC vorgaenger;
+
+PROC nachfolger :
+ down (file); satznr INCR 1;
+ stelle DECR verschoben;
+ IF zeilennr = aktuelle bildlaenge
+ THEN bildanfang INCR 1;
+ IF rollup erlaubt
+ THEN rollup
+ ELSE neu (ueberschrift, bild)
+ FI
+ ELSE neu (akt satznr, nix); zeilennr INCR 1 (*sh*)
+ FI ;
+ IF markiert THEN neu (nix, bildzeile) FI .
+
+rollup erlaubt :
+ kurze bildlaenge = maxlaenge AND kurze feldlaenge = maxbreite .
+
+rollup :
+ out (down char);
+ IF bildzeichen = inscr
+ THEN neu (ueberschrift, nix)
+ ELIF is cr or down CAND (write access COR nicht auf letztem satz) (*sh*)
+ THEN neu (nix, bildzeile)
+ ELSE neu (ueberschrift, bildzeile)
+ FI .
+
+is cr or down :
+ IF kommando = "" THEN kommando := inchety FI;
+ kommando char = down char COR kommando char = cr .
+
+kommando char : kommando SUB kommando zeiger .
+
+nicht auf letztem satz : line no (file) < lines (file) .
+END PROC nachfolger;
+
+BOOL PROC next incharety is (TEXT CONST muster) :
+ INT CONST klen := LENGTH kommando - kommando zeiger + 1,
+ mlen := LENGTH muster;
+ INT VAR i; FOR i FROM 1 UPTO mlen - klen REP kommando CAT inchety PER;
+ subtext (kommando, kommando zeiger, kommando zeiger + mlen - 1) = muster
+END PROC next incharety is;
+
+PROC quit last: (* 22.06.84 -bk- *)
+ IF actual editor > 0 AND actual editor < max used editor
+ THEN verlasse alle groesseren editoren
+ FI .
+
+verlasse alle groesseren editoren :
+ open editor (actual editor + 1); quit .
+END PROC quit last;
+
+PROC quit :
+ IF actual editor > 0 THEN verlasse aktuellen editor FI .
+
+verlasse aktuellen editor :
+ disable stop;
+ INT CONST aktueller editor := actual editor;
+ in innersten editor gehen;
+ REP
+ IF zeileneinfuegen THEN hop rubin simulieren FI;
+ ggf bildschirmdarstellung korrigieren;
+ innersten editor schliessen
+ UNTIL aktueller editor > max used editor PER;
+ actual editor := max used editor .
+
+in innersten editor gehen : open editor (max used editor) .
+
+hop rubin simulieren :
+ zeileneinfuegen := FALSE;
+ leere zeilen am dateiende loeschen; (*sh*)
+ ggf bildschirmdarstellung korrigieren;
+ logisches eof loeschen .
+
+innersten editor schliessen :
+ max used editor DECR 1;
+ IF max used editor > 0
+ THEN open editor (max used editor);
+ bildeinschraenkung aufheben
+ FI .
+
+logisches eof loeschen :
+ col (file, stelle); set range (file, old range) .
+
+leere zeilen am dateiende loeschen : (* 15.08.85 -ws- *)
+ satz nr := line no (file) ;
+ to line (file, lines (file)) ;
+ WHILE lines (file) > 1 AND bildsatz ist leerzeile REP
+ delete record (file);
+ to line (file, lines (file))
+ PER;
+ toline (file, satznr) .
+
+bildsatz ist leerzeile :
+ TEXT VAR bildsatz;
+ read record (file, bildsatz);
+ ist leerzeile .
+
+ist leerzeile :
+ bildsatz = "" OR bildsatz = blank .
+
+ggf bildschirmdarstellung korrigieren :
+ satz nr DECR 1; (* für Bildschirmkorrektur *)
+ IF satznr > lines (file)
+ THEN zeilen nr DECR satz nr - lines (file);
+ satz nr := lines (file);
+ dateizustand retten
+ FI .
+
+bildeinschraenkung aufheben :
+ laenge := feldlaenge;
+ kurze feldlaenge := feldlaenge;
+ kurze bildlaenge := bildlaenge;
+ neu (nix, bild) .
+END PROC quit;
+
+PROC nichts neu : neu (nix, nix) END PROC nichts neu;
+
+PROC satznr neu : neu (akt satznr, nix) END PROC satznr neu;
+
+PROC ueberschrift neu : neu (ueberschrift, nix) END PROC ueberschrift neu;
+
+PROC zeile neu :
+ INT CONST zeile := line no (file);
+ abschnitt neu (zeile, zeile)
+END PROC zeile neu;
+
+PROC abschnitt neu (INT CONST von satznr, bis satznr) :
+ IF von satznr <= bis satznr
+ THEN erster neusatz := min (erster neusatz, von satznr);
+ letzter neusatz := max (letzter neusatz, bis satznr);
+ neu (nix, abschnitt)
+ ELSE abschnitt neu (bis satznr, von satznr)
+ FI
+END PROC abschnitt neu;
+
+PROC bildabschnitt neu (INT CONST von zeile, bis zeile) : (*sh*)
+ IF von zeile <= bis zeile
+ THEN erster neusatz := max (1, von zeile + bildanfang - 1);
+ letzter neusatz := min (bildlaenge, bis zeile + bildanfang - 1);
+ IF von zeile < 1
+ THEN neu (ueberschrift, abschnitt)
+ ELSE neu (nix , abschnitt)
+ FI
+ ELSE bildabschnitt neu (bis zeile, von zeile)
+ FI
+END PROC bildabschnitt neu;
+
+PROC bild neu : neu (nix, bild) END PROC bild neu; (*sh*)
+
+PROC bild neu (FILE VAR f) :
+ INT CONST editor no := abs (editinfo (f)) DIV 256;
+ IF editor no > 0 AND editor no <= max used editor
+ THEN IF editor no = actual editor
+ THEN bild neu
+ ELSE editstack (editor no).bildstatus.bildbereich := bild
+ FI
+ FI
+END PROC bild neu;
+
+PROC alles neu :
+ neu (ueberschrift, bild);
+ INT VAR i;
+ FOR i FROM 1 UPTO max used editor REP
+ editstack (i).bildstatus.bildbereich := bild;
+ editstack (i).bildstatus.ueberschriftbereich := ueberschrift
+ PER
+END PROC alles neu;
+
+PROC satznr zeigen :
+ out (satznr pre); out (text (text (lineno (file)), 4))
+END PROC satznr zeigen;
+
+PROC ueberschrift zeigen :
+ SELECT ueberschriftbereich OF
+ CASE akt satznr : satznr zeigen;
+ ueberschriftbereich := nix
+ CASE ueberschrift : ueberschrift schreiben;
+ ueberschriftbereich := nix
+ CASE fehlermeldung : fehlermeldung schreiben;
+ ueberschriftbereich := ueberschrift
+ END SELECT
+END PROC ueberschrift zeigen;
+
+PROC fenster zeigen :
+ SELECT bildbereich OF
+ CASE bildzeile :
+ zeile := bildrand + zeilennr;
+ IF line no (file) > lines (file)
+ THEN feldout ("", stelle)
+ ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle)
+ FI
+ CASE abschnitt :
+ bild ausgeben
+ CASE bild :
+ erster neusatz := 1;
+ letzter neusatz := 9999;
+ bild ausgeben
+ OTHERWISE :
+ LEAVE fenster zeigen
+ END SELECT;
+ erster neusatz := 9999;
+ letzter neusatz := 0;
+ bildbereich := nix
+END PROC fenster zeigen ;
+
+PROC bild ausgeben :
+ BOOL CONST schreiben ist ganz einfach := NOT markiert AND verschoben = 0;
+ INT CONST save marke := marke,
+ save verschoben := verschoben,
+ save laenge := laenge,
+ act lineno := lineno (file),
+ von := max (1, erster neusatz - bildanfang + 1);
+ INT VAR bis := min (letzter neusatz - bildanfang + 1, bildlaenge);
+ IF kurze feldlaenge <= 0 THEN bis := min (bis, kurze bildlaenge) FI;
+ IF von > bis THEN LEAVE bild ausgeben FI;
+ verschoben := 0;
+ IF markiert
+ THEN IF mark lineno (file) < bildanfang + von - 1
+ THEN marke := anfang
+ ELSE marke := 0
+ FI
+ FI ;
+ abschnitt loeschen und neuschreiben;
+ to line (file, act lineno);
+ laenge := save laenge;
+ verschoben := save verschoben;
+ marke := save marke .
+
+markiert : mark lineno (file) > 0 .
+
+abschnitt loeschen und neuschreiben :
+ abschnitt loeschen;
+ INT VAR line number := bildanfang + von - 1;
+ to line (file, line number);
+ abschnitt schreiben .
+
+abschnitt loeschen :
+ cursor (rand + 1, bildrand + von);
+ IF bildrest darf komplett geloescht werden
+ THEN out (clear eop)
+ ELSE zeilenweise loeschen
+ FI .
+
+bildrest darf komplett geloescht werden :
+ bis = maxlaenge AND kurze bildlaenge = maxlaenge
+ AND kurze feldlaenge = maxbreite .
+
+zeilenweise loeschen :
+ INT VAR i;
+ FOR i FROM von UPTO bis REP
+ check for interrupt;
+ feldlaenge einstellen;
+ feldrest loeschen;
+ IF i < bis THEN out (down char) FI
+ PER .
+
+feldlaenge einstellen :
+ IF ganze zeile sichtbar
+ THEN laenge := feldlaenge
+ ELSE laenge := kurze feldlaenge
+ FI .
+
+ganze zeile sichtbar : i <= kurze bildlaenge .
+
+abschnitt schreiben :
+ INT CONST last line := lines (file);
+ FOR i FROM von UPTO bis
+ WHILE line number <= last line REP
+ check for interrupt;
+ feldlaenge einstellen;
+ zeile schreiben;
+ down (file);
+ line number INCR 1
+ PER .
+
+check for interrupt :
+ kommando CAT inchety;
+ IF kommando <> ""
+ THEN IF zeilen nr = 1 CAND up command CAND vorgaenger erlaubt
+ THEN LEAVE abschnitt loeschen und neuschreiben
+ ELIF zeilen nr = bildlaenge CAND down command CAND nicht letzter satz
+ THEN LEAVE abschnitt loeschen und neuschreiben
+ FI
+ FI .
+
+vorgaenger erlaubt :
+ satznr > max (1, bildmarke) .
+
+up command : next incharety is (""3"") COR next incharety is (""1""3"") .
+
+down command :
+ next incharety is (""10"") CAND bildlaenge < maxlaenge
+ COR next incharety is (""1""10"") .
+
+nicht letzter satz : act lineno < lines (file) .
+
+zeile schreiben :
+ zeile := bildrand + i;
+ IF schreiben ist ganz einfach
+ THEN exec (PROC (TEXT CONST, INT CONST) simple feldout, file, 0)
+ ELSE zeile kompliziert schreiben
+ FI ;
+ IF line number = old lineno THEN old line update := FALSE FI .
+
+zeile kompliziert schreiben :
+ IF line number = mark lineno (file) THEN marke := mark col (file) FI;
+ IF line number = act lineno
+ THEN verschoben := save verschoben;
+ exec (PROC (TEXT CONST, INT CONST) feldout, file, stelle);
+ verschoben := 0; marke := 0
+ ELSE exec (PROC (TEXT CONST, INT CONST) feldout, file, 0);
+ IF line number = mark lineno (file) THEN marke := anfang FI
+ FI .
+END PROC bild ausgeben;
+
+PROC bild zeigen : (* wk *)
+
+ dateizustand holen ;
+ ueberschrift zeigen ;
+ bildausgabe steuern ;
+ bild neu ;
+ fenster zeigen ;
+ oldline no := satznr ;
+ old line update := FALSE ;
+ old satz := "" ;
+ old zeilennr := satznr - bildanfang + 1 ;
+ dateizustand retten .
+
+ENDPROC bild zeigen ;
+
+PROC ueberschrift initialisieren : (*sh*)
+ satznr pre :=
+ cursor pos + code (bildrand - 1) + code (rand + feldlaenge - 6);
+ ueberschrift pre :=
+ cursor pos + code (bildrand - 1) + code (rand) + mark anf;
+ ueberschrift text := ""; INT VAR i;
+ FOR i FROM 16 UPTO feldlaenge REP ueberschrift text CAT "." PER;
+ ueberschrift post := blank + mark end + "Zeile " + mark anf;
+ ueberschrift post CAT blank + mark end + " ";
+ filename := headline (file);
+ filename := subtext (filename, 1, feldlaenge - 24);
+ insert char (filename, blank, 1); filename CAT blank;
+ replace (ueberschrift text, filenamepos, filename);
+ rubin segment in ueberschrift eintragen;
+ margin segment in ueberschrift eintragen;
+ rest segment in ueberschrift eintragen;
+ learn segment in ueberschrift eintragen .
+
+filenamepos : (LENGTH ueberschrift text - LENGTH filename + 3) DIV 2 .
+mark anf : begin mark + mark ausgleich.
+mark end : end mark + mark ausgleich.
+mark ausgleich : (1 - sign (max (mark size, 0))) * blank .
+
+rubin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 9, rubin segment) .
+
+rubin segment :
+ IF einfuegen THEN "RUBIN" ELSE "....." FI .
+
+margin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 2, margin segment) .
+
+margin segment :
+ IF anfang <= 1
+ THEN "......"
+ ELSE TEXT VAR margin text := "M" + text (anfang);
+ (6 - LENGTH margin text) * "." + margin text
+ FI .
+
+rest segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 25, rest segment) .
+
+rest segment :
+ IF zeileneinfuegen THEN "REST" ELSE "...." FI .
+
+learn segment in ueberschrift eintragen :
+ replace (ueberschrift text, feldlaenge - 19, learn segment) .
+
+learn segment :
+ IF lernmodus THEN "LEARN" ELSE "....." FI .
+
+END PROC ueberschrift initialisieren;
+
+PROC ueberschrift schreiben :
+ replace (ueberschrift post, satznr pos, text (text (lineno (file)), 4));
+ out (ueberschrift pre); out (ueberschrift text); out (ueberschrift post);
+ get tabs (file, tab);
+ IF pos (tab, dach) > 0
+ THEN out (ueberschrift pre);
+ out subtext (tab, anfang + 1, anfang + feldlaenge - 1);
+ cursor (rand + 1 + feldlaenge, bildrand); out (end mark)
+ FI .
+
+ satznr pos : IF mark size > 0 THEN 9 ELSE 10 FI . (*sh*)
+END PROC ueberschrift schreiben;
+
+PROC fehlermeldung schreiben :
+ ueberschrift schreiben;
+ out (ueberschrift pre);
+ out ("FEHLER: ");
+ out subtext (fehlertext, 1, feldlaenge - 21);
+ out (blank);
+ out (piep);
+ cursor (rand + 1 + feldlaenge, bildrand); out (end mark)
+END PROC fehlermeldung schreiben;
+
+PROC set busy indicator :
+ cursor (rand + 2, bildrand)
+END PROC set busy indicator;
+
+PROC kommando analysieren (TEXT CONST taste,
+ PROC (TEXT CONST) kommando interpreter) :
+ disable stop;
+ bildausgabe normieren;
+ zustand in datei sichern;
+ editfile modus setzen;
+ kommando interpreter (taste);
+ editfile modus zuruecksetzen;
+ IF actual editor <= 0 THEN LEAVE kommando analysieren FI;
+ absatz ausgleich := 2; (*sh*)
+ konstanten neu berechnen;
+ neues bild bei undefinierter benutzeraktion;
+ evtl fehler behandeln;
+ zustand aus datei holen;
+ bildausgabe steuern .
+
+editfile modus setzen :
+ BOOL VAR alter editget modus := editget modus ;
+ editget modus := FALSE .
+
+editfile modus zuruecksetzen :
+ editget modus := alter editget modus .
+
+evtl fehler behandeln :
+ IF is error
+ THEN fehlertext := errormessage;
+ IF fehlertext <> "" THEN neu (fehlermeldung, nix) FI;
+ clear error
+ ELSE fehlertext := ""
+ FI .
+
+zustand in datei sichern :
+ old zeilennr := zeilennr;
+ old mark lineno := bildmarke;
+ dateizustand retten .
+
+zustand aus datei holen :
+ dateizustand holen;
+ IF letzer editor auf dieser datei <> actual editor
+ THEN zurueck auf alte position; neu (ueberschrift, bild)
+ FI .
+
+zurueck auf alte position :
+ to line (file, old lineno);
+ col (file, alte stelle);
+ IF fliesstext
+ THEN editinfo (file, old zeilennr)
+ ELSE editinfo (file, - old zeilennr)
+ FI ; dateizustand holen .
+
+bildausgabe normieren :
+ bildbereich := undefinierter bereich;
+ erster neusatz := 9999;
+ letzter neusatz := 0 .
+
+neues bild bei undefinierter benutzeraktion :
+ IF bildbereich = undefinierter bereich THEN alles neu FI .
+END PROC kommando analysieren;
+
+PROC bildausgabe steuern :
+ IF markiert
+ THEN IF old mark lineno = 0
+ THEN abschnitt neu (bildmarke, satznr);
+ konstanten neu berechnen
+ ELIF stelle veraendert (*sh*)
+ THEN zeile neu
+ FI
+ ELIF old mark lineno > 0
+ THEN abschnitt neu (old mark lineno, (max (satznr, old lineno)));
+ konstanten neu berechnen
+ FI ;
+ IF satznr <> old lineno
+ THEN neu (akt satznr, nix);
+ neuen bildaufbau bestimmen
+ ELSE zeilennr := old zeilennr
+ FI ;
+ zeilennr := min (min (zeilennr, satznr), aktuelle bildlaenge);
+ bildanfang := satznr - zeilennr + 1 .
+
+stelle veraendert : stelle <> alte stelle .
+
+neuen bildaufbau bestimmen :
+ zeilennr := old zeilennr + satznr - old lineno;
+ IF 1 <= zeilennr AND zeilennr <= aktuelle bildlaenge
+ THEN im fenster springen
+ ELSE bild neu aufbauen
+ FI .
+
+im fenster springen :
+ IF markiert THEN abschnitt neu (old lineno, satznr) FI .
+
+bild neu aufbauen :
+ neu (nix, bild); zeilennr := max (1, aktuelle bildlaenge DIV 2) .
+END PROC bildausgabe steuern;
+
+PROC word wrap (BOOL CONST b) :
+ IF actual editor = 0
+ THEN std fliesstext := b
+ ELSE fliesstext in datei setzen
+ FI .
+
+fliesstext in datei setzen :
+ fliesstext := b;
+ IF fliesstext veraendert THEN editinfo (file, - editinfo (file)) FI;
+ neu (ueberschrift, bild) .
+
+fliesstext veraendert :
+ fliesstext AND editinfo (file) < 0 OR
+ NOT fliesstext AND editinfo (file) > 0 .
+END PROC word wrap;
+
+BOOL PROC word wrap : (*sh*)
+ IF actual editor = 0
+ THEN std fliesstext
+ ELSE fliesstext
+ FI
+END PROC word wrap;
+
+INT PROC margin : anfang END PROC margin;
+
+PROC margin (INT CONST i) : (*sh*)
+ IF anfang <> i CAND i > 0 AND i < 16001
+ THEN anfang := i; neu (ueberschrift, bild);
+ margin segment in ueberschrift eintragen
+ ELSE IF i >= 16001 OR i < 0
+ THEN errorstop ("ungueltige Anfangsposition (1 - 16000)")
+ FI
+ FI .
+
+margin segment in ueberschrift eintragen :
+ replace (ueberschrift text, 2, margin segment) .
+
+margin segment :
+ IF anfang <= 1
+ THEN "......"
+ ELSE TEXT VAR margin text := "M" + text (anfang);
+ (6 - LENGTH margin text) * "." + margin text
+ FI .
+
+END PROC margin;
+
+BOOL PROC rubin mode : rubin mode (actual editor) END PROC rubin mode;
+
+BOOL PROC rubin mode (INT CONST editor nr) : (*sh*)
+ IF editor nr < 1 OR editor nr > max used editor
+ THEN errorstop ("Editor nicht eroeffnet")
+ FI ;
+ IF editor nr = actual editor
+ THEN einfuegen
+ ELSE editstack (editor nr).feldstatus.einfuegen
+ FI
+END PROC rubin mode;
+
+PROC edit (INT CONST i, TEXT CONST res,
+ PROC (TEXT CONST) kommando interpreter) :
+ edit (i, i, i, res, PROC (TEXT CONST) kommando interpreter)
+END PROC edit;
+
+PROC edit (INT CONST von, bis, start, TEXT CONST res,
+ PROC (TEXT CONST) kommando interpreter) :
+ disable stop;
+ IF von < bis
+ THEN edit (von+1, bis, start, res, PROC (TEXT CONST) kommando interpreter);
+ IF max used editor < von THEN LEAVE edit FI;
+ open editor (von)
+ ELSE open editor (start)
+ FI ;
+ absatz ausgleich := 2;
+ bildeditor (res, PROC (TEXT CONST) kommando interpreter);
+ cursor (1, schirmhoehe);
+ IF is error
+ THEN kommando zeiger := 1; kommando := ""; quit
+ FI ;
+ IF lernmodus CAND actual editor = 0 THEN warnung ausgeben FI . (*sh*)
+
+ warnung ausgeben :
+ out (clear eop); out ("WARNUNG: Lernmodus nicht ausgeschaltet"13""10"") .
+END PROC edit;
+
+PROC dateizustand holen :
+ modify (file);
+ get tabs (file, tabulator);
+ zeilennr und fliesstext und letzter editor aus editinfo decodieren;
+ limit := max line length (file);
+ stelle := col (file);
+ markiert := mark (file);
+ IF markiert
+ THEN markierung holen
+ ELSE keine markierung
+ FI ;
+ satz nr := lineno (file);
+ IF zeilennr > aktuelle bildlaenge (*sh*)
+ THEN zeilennr := min (satznr, aktuelle bildlaenge); bild neu
+ ELIF zeilennr > satznr
+ THEN zeilennr := min (satznr, aktuelle bildlaenge)
+ FI ; zeilennr := max (zeilennr, 1);
+ bildanfang := satz nr - zeilennr + 1 .
+
+zeilennr und fliesstext und letzter editor aus editinfo decodieren :
+ zeilennr := edit info (file);
+ IF zeilennr = 0
+ THEN zeilennr := 1;
+ fliesstext := std fliesstext
+ ELIF zeilennr > 0
+ THEN fliesstext := TRUE
+ ELSE zeilennr := - zeilennr;
+ fliesstext := FALSE
+ FI ;
+ letzer editor auf dieser datei := zeilennr DIV 256;
+ zeilennr := zeilennr MOD 256 .
+
+markierung holen :
+ bildmarke := mark lineno (file);
+ feldmarke := mark col (file);
+ IF line no (file) <= bildmarke
+ THEN to line (file, bildmarke);
+ marke := feldmarke;
+ stelle := max (stelle, feldmarke)
+ ELSE marke := 1
+ FI .
+
+keine markierung :
+ bildmarke := 0;
+ feldmarke := 0;
+ marke := 0 .
+END PROC dateizustand holen;
+
+PROC dateizustand retten :
+ put tabs (file, tabulator);
+ IF fliesstext
+ THEN editinfo (file, zeilennr + actual editor * 256)
+ ELSE editinfo (file, - (zeilennr + actual editor * 256))
+ FI ;
+ max line length (file, limit);
+ col (file, stelle);
+ IF markiert
+ THEN mark (file, bildmarke, feldmarke)
+ ELSE mark (file, 0, 0)
+ FI
+END PROC dateizustand retten;
+
+PROC open editor (FILE CONST new file, BOOL CONST access) :
+ disable stop; quit last;
+ neue bildparameter bestimmen;
+ open editor (actual editor + 1, new file, access, x, y, x len, y len).
+
+neue bildparameter bestimmen :
+ INT VAR x, y, x len, y len;
+ IF actual editor > 0
+ THEN teilbild des aktuellen editors
+ ELSE volles bild
+ FI .
+
+teilbild des aktuellen editors :
+ get editcursor (x, y); bildgroesse bestimmen;
+ IF fenster zu schmal (*sh*)
+ THEN enable stop; errorstop ("Fenster zu klein")
+ ELIF fenster zu kurz
+ THEN verkuerztes altes bild nehmen
+ FI .
+
+bildgroesse bestimmen :
+ x len := rand + feldlaenge - x + 3;
+ y len := bildrand + bildlaenge - y + 1 .
+
+fenster zu schmal : x > schirmbreite - 17 .
+fenster zu kurz : y > schirmhoehe - 1 .
+
+verkuerztes altes bild nehmen :
+ x := rand + 1; y := bildrand + 1;
+ IF fenster zu kurz THEN enable stop; errorstop ("Fenster zu klein") FI;
+ x len := feldlaenge + 2;
+ y len := bildlaenge;
+ kurze feldlaenge := 0;
+ kurze bildlaenge := 1 .
+
+volles bild :
+ x := 1; y := 1; x len := schirmbreite; y len := schirmhoehe .
+END PROC open editor;
+
+PROC open editor (INT CONST editor nr,
+ FILE CONST new file, BOOL CONST access,
+ INT CONST x start, y, x len start, y len) :
+ INT VAR x := x start,
+ x len := x len start;
+ IF editor nr > max editor
+ THEN errorstop ("zu viele Editor-Fenster")
+ ELIF editor nr > max used editor + 1 OR editor nr < 1
+ THEN errorstop ("Editor nicht eroeffnet")
+ ELIF fenster ungueltig
+ THEN errorstop ("Fenster ungueltig")
+ ELSE neuen editor stacken
+ FI .
+
+fenster ungueltig :
+ x < 1 COR x > schirmbreite COR y < 1 COR y > schirmhoehe COR
+ x len - 2 <= 15 COR y len - 1 < 1 COR
+ x + x len - 1 > schirmbreite COR y + y len - 1 > schirmhoehe .
+
+neuen editor stacken :
+ disable stop;
+ IF actual editor > 0 AND ist einschraenkung des alten bildes
+ THEN dateizustand holen;
+ aktuelles editorbild einschraenken;
+ arbeitspunkt in das restbild positionieren;
+ abgrenzung beruecksichtigen
+ FI ;
+ aktuellen zustand retten;
+ neuen zustand setzen;
+ neues editorbild zeigen;
+ actual editor := editor nr;
+ IF actual editor > max used editor
+ THEN max used editor := actual editor
+ FI .
+
+ist einschraenkung des alten bildes :
+ x > rand CAND x + x len = rand + feldlaenge + 3 CAND
+ y > bildrand CAND y + y len = bildrand + bildlaenge + 1 .
+
+aktuelles editorbild einschraenken :
+ kurze feldlaenge := x - rand - 3;
+ kurze bildlaenge := y - bildrand - 1 .
+
+arbeitspunkt in das restbild positionieren :
+ IF stelle > 3
+ THEN stelle DECR 3; alte stelle := stelle
+ ELSE WHILE zeilennr > 1 AND zeilennr > kurze bildlaenge REP
+ vorgaenger
+ PER; old lineno := satznr
+ FI .
+
+abgrenzung beruecksichtigen :
+ IF x - rand > 1
+ THEN balken malen;
+ x INCR 2;
+ x len DECR 2
+ FI .
+
+balken malen :
+ INT VAR i;
+ FOR i FROM 0 UPTO y len-1 REP
+ cursor (x, y+i); out (kloetzchen) (*sh*)
+ PER .
+
+kloetzchen : IF mark size > 0 THEN ""15""14"" ELSE ""15" "14" " FI .
+
+aktuellen zustand retten :
+ IF actual editor > 0
+ THEN dateizustand retten;
+ editstack (actual editor).feldstatus := feldstatus;
+ editstack (actual editor).bildstatus := bildstatus;
+ einrueckstack (actual editor) := alte einrueckposition
+ FI .
+
+neuen zustand setzen :
+ FRANGE VAR frange;
+ feldstatus := FELDSTATUS :
+ (1, 1, x-1, 0, 1, 0, x len-2, 0, FALSE, TRUE, access, "");
+ bildstatus := BILDSTATUS :
+ (x len-2, x len-2, y, y len-1, y len-1, ueberschrift, bild,
+ 0, 0, 1, 0, 0, FALSE, FALSE, "", "", "", "", "", frange, new file);
+ alte einrueckposition := 1;
+ dateizustand holen;
+ ueberschrift initialisieren .
+
+neues editorbild zeigen :
+ ueberschrift zeigen; fenster zeigen
+END PROC open editor;
+
+PROC open editor (INT CONST i) :
+ IF i < 1 OR i > max used editor
+ THEN errorstop ("Editor nicht eroeffnet")
+ ELIF actual editor <> i
+ THEN switch editor
+ FI .
+
+switch editor :
+ aktuellen zustand retten;
+ actual editor := i;
+ neuen zustand setzen;
+ IF kein platz mehr fuer restfenster
+ THEN eingeschachtelte editoren vergessen;
+ bildeinschraenkung aufheben
+ ELSE neu (nix, nix)
+ FI .
+
+aktuellen zustand retten :
+ IF actual editor > 0
+ THEN editstack (actual editor).feldstatus := feldstatus;
+ editstack (actual editor).bildstatus := bildstatus;
+ einrueckstack (actual editor) := alte einrueckposition;
+ dateizustand retten
+ FI .
+
+neuen zustand setzen :
+ feldstatus := editstack (i).feldstatus;
+ bildstatus := editstack (i).bildstatus;
+ alte einrueckposition := einrueckstack (i);
+ dateizustand holen .
+
+kein platz mehr fuer restfenster :
+ kurze feldlaenge < 1 AND kurze bildlaenge < 1 .
+
+eingeschachtelte editoren vergessen :
+ IF actual editor < max used editor
+ THEN open editor (actual editor + 1) ;
+ quit
+ FI ;
+ open editor (i) .
+
+bildeinschraenkung aufheben :
+ laenge := feldlaenge;
+ kurze feldlaenge := feldlaenge;
+ kurze bildlaenge := bildlaenge;
+ neu (ueberschrift, bild) .
+END PROC open editor;
+
+FILE PROC editfile :
+ IF actual editor = 0 OR editget modus
+ THEN errorstop ("Editor nicht eroeffnet")
+ FI ; file
+END PROC editfile;
+
+PROC get window (INT VAR x, y, x size, y size) :
+ x := rand + 1;
+ y := bildrand;
+ x size := feldlaenge + 2;
+ y size := bildlaenge + 1
+ENDPROC get window;
+
+(************************* Zugriff auf Bildstatus *************************).
+
+feldlaenge : bildstatus.feldlaenge .
+kurze feldlaenge : bildstatus.kurze feldlaenge .
+bildrand : bildstatus.bildrand .
+bildlaenge : bildstatus.bildlaenge .
+kurze bildlaenge : bildstatus.kurze bildlaenge .
+ueberschriftbereich : bildstatus.ueberschriftbereich .
+bildbereich : bildstatus.bildbereich .
+erster neusatz : bildstatus.erster neusatz .
+letzter neusatz : bildstatus.letzter neusatz .
+old zeilennr : bildstatus.old zeilennr .
+old lineno : bildstatus.old lineno .
+old mark lineno : bildstatus.old mark lineno .
+zeileneinfuegen : bildstatus.zeileneinfuegen .
+old line update : bildstatus.old line update .
+satznr pre : bildstatus.satznr pre .
+ueberschrift pre : bildstatus.ueberschrift pre .
+ueberschrift text : bildstatus.ueberschrift text .
+ueberschrift post : bildstatus.ueberschrift post .
+old satz : bildstatus.old satz .
+old range : bildstatus.old range .
+file : bildstatus.file .
+
+END PACKET editor paket;
+
diff --git a/system/base/1.7.5/src/elan do interface b/system/base/1.7.5/src/elan do interface
new file mode 100644
index 0000000..72026a7
--- /dev/null
+++ b/system/base/1.7.5/src/elan do interface
@@ -0,0 +1,57 @@
+
+PACKET elan do interface DEFINES (*Autor: J.Liedtke *)
+ (*Stand: 08.11.85 *)
+ do ,
+ no do again :
+
+
+LET no ins = FALSE ,
+ no lst = FALSE ,
+ no check = FALSE ,
+ no sermon = FALSE ,
+ compile line mode = 2 ,
+ do again mode = 4 ,
+ max command length = 2000 ;
+
+
+INT VAR do again mod nr := 0 ;
+TEXT VAR previous command := "" ;
+
+DATASPACE VAR ds ;
+
+
+PROC do (TEXT CONST command) :
+
+ enable stop ;
+ IF LENGTH command > max command length
+ THEN errorstop ("Kommando zu lang")
+ ELIF do again mod nr <> 0 AND command = previous command
+ THEN do again
+ ELSE previous command := command ;
+ compile and execute
+ FI .
+
+do again :
+ elan (do again mode, ds, "", do again mod nr,
+ no ins, no lst, no check, no sermon) .
+
+compile and execute :
+ elan (compile line mode, ds, command, do again mod nr,
+ no ins, no lst, no check, no sermon) .
+
+ENDPROC do ;
+
+PROC no do again :
+
+ do again mod nr := 0
+
+ENDPROC no do again ;
+
+PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line,
+ INT VAR start module number,
+ BOOL CONST ins, lst, rt check, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ENDPACKET elan do interface ;
+
diff --git a/system/base/1.7.5/src/error handling b/system/base/1.7.5/src/error handling
new file mode 100644
index 0000000..34db65d
--- /dev/null
+++ b/system/base/1.7.5/src/error handling
@@ -0,0 +1,142 @@
+
+PACKET error handling DEFINES
+
+ enable stop ,
+ disable stop ,
+ is error ,
+ clear error ,
+ errormessage ,
+ error code ,
+ error line ,
+ put error ,
+ errorstop ,
+ stop :
+
+
+LET cr lf = ""13""10"" ,
+ line nr field = 1 ,
+ error line field = 2 ,
+ error code field = 3 ,
+ syntax error code= 100 ,
+
+ error pre = ""7""13""10""5"FEHLER : " ;
+
+
+TEXT VAR errortext := "" ;
+
+
+PROC enable stop :
+ EXTERNAL 75
+ENDPROC enable stop ;
+
+PROC disable stop :
+ EXTERNAL 76
+ENDPROC disable stop ;
+
+PROC set error stop (INT CONST code) :
+ EXTERNAL 77
+ENDPROC set error stop ;
+
+BOOL PROC is error :
+ EXTERNAL 78
+ENDPROC is error ;
+
+PROC clear error :
+ EXTERNAL 79
+ENDPROC clear error ;
+
+PROC select error message :
+
+ SELECT error code OF
+ CASE 1 : error text := "'halt' vom Terminal"
+ CASE 2 : error text := "Stack-Ueberlauf"
+ CASE 3 : error text := "Heap-Ueberlauf"
+ CASE 4 : error text := "INT-Ueberlauf"
+ CASE 5 : error text := "DIV durch 0"
+ CASE 6 : error text := "REAL-Ueberlauf"
+ CASE 7 : error text := "TEXT-Ueberlauf"
+ CASE 8 : error text := "zu viele DATASPACEs"
+ CASE 9 : error text := "Ueberlauf bei Subskription"
+ CASE 10: error text := "Unterlauf bei Subskription"
+ CASE 11: error text := "falscher DATASPACE-Zugriff"
+ CASE 12: error text := "INT nicht initialisiert"
+ CASE 13: error text := "REAL nicht initialisiert"
+ CASE 14: error text := "TEXT nicht initialisiert"
+ CASE 15: error text := "nicht implementiert"
+ CASE 16: error text := "Block unlesbar"
+ CASE 17: error text := "Codefehler"
+ END SELECT
+
+ENDPROC select error message ;
+
+TEXT PROC error message :
+
+ select error message ;
+ error text
+
+ENDPROC error message ;
+
+INT PROC error code :
+
+ pcb (error code field)
+
+ENDPROC error code ;
+
+INT PROC error line :
+
+ IF is error
+ THEN pcb (error line field)
+ ELSE 0
+ FI
+
+ENDPROC error line ;
+
+PROC syntax error (TEXT CONST message) :
+
+ INTERNAL 259 ;
+ errorstop (syntax error code, message) .
+
+ENDPROC syntax error ;
+
+PROC errorstop (TEXT CONST message) :
+
+ errorstop (0, message) ;
+
+ENDPROC errorstop ;
+
+PROC errorstop (INT CONST code, TEXT CONST message) :
+
+ IF NOT is error
+ THEN error text := message ;
+ set error stop (code)
+ FI
+
+ENDPROC errorstop ;
+
+PROC put error :
+
+ IF is error
+ THEN select error message ;
+ IF error text <> ""
+ THEN put error message
+ FI
+ FI .
+
+put error message :
+ out (error pre) ;
+ out (error text) ;
+ IF error line > 0
+ THEN out (" bei Zeile "); out (text (error line)) ;
+ FI ;
+ out (cr lf) .
+
+ENDPROC put error ;
+
+PROC stop :
+
+ errorstop ("stop")
+
+ENDPROC stop ;
+
+ENDPACKET error handling ;
+
diff --git a/system/base/1.7.5/src/eumel coder part 1 b/system/base/1.7.5/src/eumel coder part 1
new file mode 100644
index 0000000..83974f7
--- /dev/null
+++ b/system/base/1.7.5/src/eumel coder part 1
@@ -0,0 +1,866 @@
+PACKET eumel coder part 1 (* Autor: U. Bartling *)
+ DEFINES run, run again,
+ insert,
+ prot, prot off,
+ check, check on, check off,
+ warnings, warnings on, warnings off,
+
+ help, bulletin, packets
+ :
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 13.02.1986 *)
+(* Stand der Implementation : 16.04.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR hash table pointer, nt link, permanent pointer, param link,
+ index, mode, word;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 10.04.1986 *)
+(* 1.7.5.4 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+ before first pt entry = 22784 ,
+ first permanent entry = 22785 ,
+ end of permanent table = 32767 ,
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+(* permanent param proc end marker = 0 , *)
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+
+ void = 0 ,
+ int = 1 ,
+ real = 2 ,
+ string = 3 ,
+ bool = 5 ,
+ bool result = 6 ,
+ dataspace = 7 ,
+ row = 10 ,
+ struct = 11 ,
+
+ const = 1 ,
+ var = 2 ,
+(* proc = 3 , *)
+(* denoter = 5 , *)
+ bold = 2 ,
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+
+ warning message = 2 ,
+ error message = 4 ,
+
+ point line = "..............." ;
+
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ (***** Hash/Namenstabelle *****)
+.
+next hash entry :
+ hash table pointer INCR wordlength .
+
+end of hash table reached :
+ hash table pointer > end of hash table .
+
+yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ next pt param ;
+ mode := cdb int (param link)
+ UNTIL mode = permanent type field PER ;
+ param link INCR wordlength
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode = permanent param proc THEN type of param proc
+ ELSE type of object
+ FI .
+
+type of param proc :
+ param link INCR wordlength ;
+ get type and mode (type) ;
+ mode := permanent param proc .
+
+type of object :
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 16.04.1986 *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR line number, pattern length, packet link,
+ begin of packet, last packet entry, indentation;
+
+TEXT VAR bulletin name, type and mode, pattern, buffer;
+
+DATASPACE VAR bulletin ds :: nilspace ;
+
+.packet name :
+ cdb text (cdb int(packet link + wordlength) + two word length) .
+
+.within editor :
+ aktueller editor > 0 . ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void :
+ CASE int : type and mode CAT "INT"
+ CASE real : type and mode CAT "REAL"
+ CASE string : type and mode CAT "TEXT"
+ CASE bool, bool result : type and mode CAT "BOOL"
+ CASE dataspace : type and mode CAT "DATASPACE"
+ CASE row : type and mode CAT "ROW "
+ CASE struct : type and mode CAT "STRUCT"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+PROC help (TEXT CONST proc name) :
+ prep bulletin ;
+ prep help ;
+ scan (object name) ;
+ next symbol (pattern) ;
+ packet link := end of permanent table ;
+ IF function = 0 THEN standard help
+ ELSE asterisk help
+ FI .
+
+prep help :
+ object name := compress (proc name) ;
+ INT VAR function :: 0 ;
+ INT CONST l :: LENGTH object name ;
+ IF l > 1 AND object name <> "**"
+ THEN IF (object name SUB l) = "*"
+ THEN function INCR 2 ;
+ delete char (object name, l)
+ FI ;
+ IF (object name SUB 1) = "*"
+ THEN function INCR 1 ;
+ delete char (object name, 1)
+ FI ;
+ IF another asterisk THEN wrong function FI
+ FI.
+
+another asterisk :
+ pos (object name, "*") <> 0 .
+
+wrong function :
+ errorstop ("unzulaessige Sternfunktion") .
+
+standard help :
+ to object (pattern) ;
+ IF found THEN display
+ ELSE error stop ("unbekannt: " + proc name)
+ FI .
+
+display :
+ WHILE permanent pointer <> 0 REP
+ put name of packet if necessary ;
+ put specifications (pattern) ;
+ next procedure
+ ENDREP ;
+ show bulletin file .
+
+put name of packet if necessary :
+ IF new packet THEN packet link := permanent pointer ;
+ find begin of packet ;
+ writeline (2) ;
+ write packet name
+ FI .
+
+find begin of packet :
+ REP
+ packet link DECR wordlength
+ UNTIL begin of packet found PER .
+
+begin of packet found :
+ cdb int (packet link) = permanent packet .
+
+new packet :
+ permanent pointer < packet link .
+
+asterisk help :
+ hash table pointer := begin of hash table ;
+ pattern length := LENGTH pattern - 1 ;
+ REP
+ list all objects in current hash table chain ;
+ next hash entry
+ UNTIL end of hash table reached ENDREP ;
+ show bulletin file .
+
+list all objects in current hash table chain :
+ nt link := hash table pointer ;
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length) ;
+ IF matching THEN into bulletin FI
+ PER .
+
+matching :
+ INT CONST p :: pos (object name, pattern) ;
+ SELECT function OF
+ CASE 1 : p <> 0 AND p = LENGTH object name - pattern length
+ CASE 2 : p = 1
+ CASE 3 : p <> 0
+ OTHERWISE FALSE
+ ENDSELECT .
+
+into bulletin :
+ object names into bulletin (BOOL PROC not end of chain)
+ENDPROC help ;
+
+BOOL PROC not end of chain :
+ permanent pointer <> 0
+ENDPROC not end of chain ;
+
+PROC write packet name :
+ indentation := 0 ;
+ write line ;
+ write bulletin line ("PACKET ") ;
+ indentation := 7 ;
+ object name := packet name ;
+ write bulletin line (object name) ;
+ write bulletin line (":") ;
+ writeline (2)
+ENDPROC write packet name ;
+
+PROC put specifications (TEXT CONST proc name) :
+ put obj name (proc name) ;
+ to first param ;
+ IF NOT end of params THEN put param list FI ;
+ put result ;
+ writeline .
+
+to first param :
+ param link := permanent pointer + word length ;
+ set end marker if end of list .
+
+put result :
+ INT VAR type;
+ get type and mode (type) ;
+ IF type <> void THEN type and mode := " --> " ;
+ name of type (type) ;
+ write bulletin line (type and mode)
+ FI
+ENDPROC put specifications ;
+
+PROC put param list :
+ write bulletin line (" (") ;
+ REP
+ INT VAR type, param mode;
+ get type and mode (type) ;
+ param mode := mode ;
+ put type and mode ;
+ maybe param proc ;
+ next pt param ;
+ IF end of params THEN write bulletin line (")") ;
+ LEAVE put param list
+ FI ;
+ write bulletin line (", ") ;
+ PER .
+
+put type and mode :
+ type and mode := "" ;
+ name of type (type) ;
+ type and mode CAT name of mode ;
+ write bulletin line (type and mode) .
+
+name of mode :
+ IF param mode = const THEN " CONST"
+ ELIF param mode = var THEN " VAR"
+ ELSE " PROC"
+ FI .
+
+maybe param proc :
+ IF mode = permanent param proc THEN put virtual params FI .
+
+put virtual params :
+ skip over result type if complex type ;
+ IF NOT end of virtual params THEN put param list FI.
+
+skip over result type if complex type :
+ next pt param .
+
+end of virtual params :
+ end of params
+ENDPROC put param list ;
+
+PROC next packet :
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word = permanent packet THEN true return
+ ELIF end of permanents THEN false return
+ FI ;
+ ENDREP .
+
+true return :
+ found := TRUE ;
+ LEAVE next packet .
+
+false return :
+ found := FALSE ;
+ LEAVE next packet .
+
+end of permanents :
+ word = permanent end OR packet link > end of permanent table
+ENDPROC next packet ;
+
+PROC prep bulletin :
+ forget (bulletin ds) ;
+ bulletin ds := nilspace ;
+ bulletin file := sequential file (output, bulletin ds) ;
+ line number := 0 ;
+ buffer := ""
+ENDPROC prep bulletin ;
+
+PROC show bulletin file :
+ IF within editor THEN ueberschrift neu FI ;
+ DATASPACE VAR local ds :: bulletin ds ;
+ FILE VAR local file :: sequential file (modify, local ds) ;
+ show (local file) ;
+ forget (local ds)
+ENDPROC show bulletin file ;
+
+PROC write bulletin line (TEXT CONST line) :
+ IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ;
+ buffer CAT line
+ENDPROC write bulletin line ;
+
+PROC writeline :
+ write (bulletin file, buffer) ;
+ line (bulletin file) ;
+ line number INCR 1 ;
+ cout (line number) ;
+ buffer := indentation * " "
+ENDPROC writeline ;
+
+PROC writeline (INT CONST times) :
+ IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
+ writeline
+ ELSE index := times
+ FI ;
+ line (bulletin file, index) ;
+ line number INCR index;
+ indentation := 0 ;
+ cout (line number)
+ENDPROC writeline ;
+
+PROC bulletin (TEXT CONST packet name) :
+ prep bulletin ;
+ scan (packet name) ;
+ next symbol (pattern) ;
+ to packet ;
+ IF found THEN list packet ;
+ show bulletin file
+ ELSE error stop (packet name + " ist kein Paketname")
+ FI .
+
+to packet :
+ last packet entry := 0 ;
+ get nametab link of packet name ;
+ packet link := before first pt entry ;
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word < 0 THEN IF word = permanent packet THEN packet found
+ ELIF word = permanent end THEN return
+ FI
+ FI
+ ENDREP .
+
+get nametab link of packet name :
+ to object (pattern) ;
+ IF NOT found THEN error stop ("unbekanntes Paket :" + packet name) ;
+ LEAVE to packet
+ FI .
+
+packet found :
+ IF cdb int (packet link + wordlength) = nt link
+ THEN last packet entry := packet link FI .
+
+return :
+ IF last packet entry <> 0 THEN found := TRUE ;
+ packet link := last packet entry
+ ELSE found := FALSE
+ FI ;
+ LEAVE to packet
+ENDPROC bulletin ;
+
+PROC list packet :
+ begin of packet := packet link + word length ;
+ write packet name ;
+ find end of packet ;
+ run through nametab and list all packet objects .
+
+find end of packet :
+ last packet entry := begin of packet ;
+ REP
+ last packet entry INCR wordlength ;
+ word := cdb int (last packet entry) ;
+ UNTIL end of packet entries PER .
+
+end of packet entries :
+ word = permanent packet OR word = permanent end .
+
+run through nametab and list all packet objects :
+ hashtable pointer := begin of hashtable ;
+ REP
+ nt link := hashtable pointer ;
+ list objects of current packet in this chain ;
+ next hash entry
+ UNTIL end of hashtable reached ENDREP .
+
+list objects of current packet in this chain :
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ put objects of this name
+ PER .
+
+put objects of this name :
+ IF there is at least one object of this name in the current packet
+ THEN into bulletin FI .
+
+there is at least one object of this name in the current packet :
+ REP
+ IF permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ THEN LEAVE there is at least one object of this name
+ in the current packet WITH TRUE FI ;
+ next procedure
+ UNTIL permanent pointer = 0 PER ;
+ FALSE .
+
+into bulletin :
+ object name := cdb text (nt link + two word length) ;
+ object names into bulletin (BOOL PROC within packet)
+ENDPROC list packet ;
+
+BOOL PROC within packet :
+ permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ENDPROC within packet ;
+
+PROC object names into bulletin (BOOL PROC link ok) :
+ scan (object name) ;
+ next symbol (object name, mode) ;
+ IF type definition THEN put type definition
+ ELSE put object definitions
+ FI .
+
+type definition :
+ mode = bold AND no params .
+
+no params :
+ cdb int (permanent pointer + word length) >= permanent type .
+
+put type definition :
+ put obj name (object name) ;
+ write bulletin line ("TYPE ") ;
+ writeline (1) .
+
+put object definitions :
+ WHILE link ok REP
+ put specifications (object name) ;
+ next procedure
+ ENDREP
+ENDPROC object names into bulletin ;
+
+PROC bulletin :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ list packet ;
+ write line (4) ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC bulletin ;
+
+PROC put obj name (TEXT CONST name) :
+ buffer := " " ;
+ bulletin name := point line ;
+ change (bulletin name, 1, end of line or name, name) ;
+ buffer CAT bulletin name ;
+ indentation := LENGTH buffer + 1 .
+
+end of line or name :
+ min (LENGTH name, LENGTH bulletin name)
+ENDPROC put obj name ;
+
+PROC packets :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ object name := packet name ;
+ put obj name (object name) ;
+ write line ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC packets ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 11. ELAN Run-Interface 09.01.1986 *)
+(* *)
+(* Uebersetzen von ELAN-Programmen *)
+(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *)
+(* *)
+(**************************************************************************)
+
+
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ warning option := FALSE ,
+ listing enabled := FALSE ;
+
+FILE VAR listing file ;
+
+TEXT VAR listing file name := "" ;
+
+
+PROC run (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, no ins)
+END PROC run;
+
+PROC run :
+ run (last param)
+ENDPROC run ;
+
+PROC run again :
+ IF run again mod nr <> 0
+ THEN elan (run again mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+ ELSE errorstop ("'run again' nicht moeglich")
+ FI
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, ins)
+ENDPROC insert ;
+
+PROC insert :
+ insert (last param)
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+ FILE VAR source := sequential file (modify, file name) ;
+ IF listing enabled
+ THEN open listing file
+ FI ;
+
+ disable stop ;
+ no do again ;
+ elan (compile file mode, source, "" , run again mod nr,
+ insert option, list option, check option, sermon) ;
+
+ IF anything noted AND command dialogue
+ THEN ignore halt during compiling ;
+ note edit (source) ;
+ last param (file name) ;
+ errorstop ("")
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+open listing file :
+ listing file := sequential file (output, listing file name) ;
+ max line length (listing file, 130)
+
+ENDPROC run elan ;
+
+PROC out text (TEXT CONST text, INT CONST out type) :
+ INTERNAL 257 ;
+ IF online
+ THEN out (text)
+ FI ;
+ IF out type = error message OR (warning option AND out type = warning message)
+ THEN note (text) ;
+ FI ;
+ IF listing enabled
+ THEN write (listing file, text)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+ INTERNAL 258 ;
+ IF online
+ THEN out (""13""10"")
+ FI ;
+ IF out type = error message
+ OR (warning option AND out type = warning message)
+ THEN note line
+ ELIF listing enabled
+ THEN line (listing file)
+ FI
+ENDPROC out line ;
+
+PROC prot (TEXT CONST file name) :
+ list option := TRUE ;
+ listing file name := file name ;
+ listing enabled := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE ;
+ listing enabled := FALSE
+ENDPROC prot off ;
+
+BOOL PROC prot :
+ list option
+ENDPROC prot ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+BOOL PROC check :
+ check option
+ENDPROC check ;
+
+PROC warnings on :
+ warning option := TRUE
+ENDPROC warnings on ;
+
+PROC warnings off :
+ warning option := FALSE
+ENDPROC warnings off ;
+
+BOOL PROC warnings :
+ warning option
+ENDPROC warnings ;
+
+ENDPACKET eumel coder part 1 ;
+
diff --git a/system/base/1.7.5/src/file b/system/base/1.7.5/src/file
new file mode 100644
index 0000000..530dcb3
--- /dev/null
+++ b/system/base/1.7.5/src/file
@@ -0,0 +1,2122 @@
+(* ------------------- VERSION 35 02.06.86 ------------------- *)
+PACKET file handling DEFINES (* Autoren: J.Liedtke, D.Martinek *)
+ (***********)
+
+ FILE,
+ :=,
+ sequential file,
+ reorganize,
+ input,
+ output,
+ modify,
+ close,
+ putline,
+ getline,
+ put,
+ get,
+ write ,
+ line,
+ reset,
+ down,
+ up,
+ downety,
+ uppety,
+ pattern found,
+ to first record,
+ to line,
+ to eof,
+ insert record,
+ delete record,
+ read record,
+ write record,
+ is first record,
+ eof,
+ line no,
+ FRANGE,
+ set range,
+ reset range ,
+ remove,
+ clear removed,
+ reinsert,
+ max line length,
+ edit info,
+ line type ,
+ copy attributes ,
+ headline,
+ put tabs,
+ get tabs,
+ col,
+ word,
+ at,
+ removed lines,
+ exec,
+ pos ,
+ len ,
+ subtext ,
+ change ,
+ lines ,
+ segments ,
+ mark ,
+ mark line no ,
+ mark col ,
+ set marked range ,
+ split line ,
+ concatenate line ,
+ prefix ,
+ sort ,
+ lexsort :
+
+
+(**********************************************************************)
+(* *)
+(* Terminologie: *)
+(* *)
+(* *)
+(* ATOMROW Menge aller Atome eines FILEs. *)
+(* Die einzelnen Atome haben zwar eine Position *)
+(* im Row, aber in dieser Betrachtung keine *)
+(* logische Reihenfolge. *)
+(* *)
+(* ATOM Basiselement, kann eine Zeile der Datei und die *)
+(* zugehoerige Verwaltungsinformation aufnehmen *)
+(* *)
+(* CHAIN Zyklisch geschlossene Kette von Segmenten. *)
+(* *)
+(* SEGMENT Teilbereich des Atomrows, enthaelt 1 oder mehr *)
+(* zusammenhaengende Atoms. *)
+(* Jedes Segment hat ein Vorgaenger- und ein *)
+(* Nachfolgersegment. *)
+(* Jedes Segment enthaelt einen logisch zumsammen- *)
+(* haengenden Teile einer Sequence. *)
+(* *)
+(* SEQUENCE Logische Folge von Lines. *)
+(* Jede Sequence ist Teil einer Chain oder besteht *)
+(* vollstaendig daraus: *)
+(* *)
+(* SEG1--SEG2--SEG3--SEG4--SEG5 *)
+(* :----sequence----: *)
+(* *)
+(* Die 'Reihenfolge' ebenso wie die 'Anzahl' der *)
+(* Lines ist eine wesentliche Eigenschaft einer *)
+(* Sequence. *)
+(* *)
+(* LINE Ein Atom als Element ein Sequence betrachtet. *)
+(* *)
+(* *)
+(**********************************************************************)
+(* *)
+(* Eigenschaften: *)
+(* *)
+(* Folgende Mengen bilden eine Zerlegung (im math. Sinn) einer *)
+(* gesamten Datei: *)
+(* used segment chain *)
+(* scratch segment chain *)
+(* free segment chain *)
+(* unused tail *)
+(* *)
+(* Fuer jedes X aus (used, scratch, free) gelten: *)
+(* *)
+(* 'X sequence' ist echte Teilmenge von 'X segment chain'. *)
+(* *)
+(* (Daraus folgt, es gibt keine leere 'chain'.) *)
+(* *)
+(* 'X segment chain' ist zyklisch gekettet. *)
+(* *)
+(* Alle Atome von 'X segment chain' haben definierten Inhalt. *)
+(* *)
+(**********************************************************************)
+
+
+LET file size = 4075 ,
+ nil = 0 ,
+
+ free root = 1 ,
+ scratch root = 2 ,
+ used root = 3 ,
+ first unused = 4 ;
+
+
+LET SEQUENCE = STRUCT (INT index, segment begin, segment end,
+ INT line no, lines),
+ SEGMENT = STRUCT (INT succ, pred, end),
+ ATOM = STRUCT (SEGMENT seg, INT type, TEXT line),
+ ATOMROW = ROW filesize ATOM,
+
+ LIST = STRUCT (SEQUENCE used, INT prefix lines, postfix lines,
+ SEQUENCE scratch, free, INT unused tail,
+ INT mode, col, limit, edit info, mark line, mark col,
+ ATOMROW atoms);
+
+TYPE FILE = BOUND LIST ;
+
+TYPE FRANGE = STRUCT (INT pre, post, BOOL pre was split, post was split);
+
+
+OP := (FRANGE VAR left, FRANGE CONST right):
+ CONCR (left) := CONCR (right)
+ENDOP := ;
+
+
+OP := (FILE VAR left, FILE CONST right):
+ EXTERNAL 260
+END OP :=;
+
+
+PROC becomes (INT VAR a, b) :
+ INTERNAL 260 ;
+ a := b
+END PROC becomes;
+
+
+PROC initialize (FILE VAR f) :
+
+ f.used := SEQUENCE : (used root, used root, used root, 1, 0);
+ f.prefix lines := 0;
+ f.postfix lines := 0;
+ f.free := SEQUENCE : (free root, free root, free root, 1, 0);
+ f.scratch := SEQUENCE : (scratch root, scratch root, scratch root, 1, 0);
+ f.unused tail := first unused;
+
+ f.limit := 77;
+ f.edit info := 0;
+ f.col := 1 ;
+ f.mark line := 0 ;
+ f.mark col := 0 ;
+
+ INT VAR i;
+ FOR i FROM 1 UPTO 3 REP
+ root (i).seg := SEGMENT : (i, i, i);
+ root (i).line := ""
+ PER;
+ put tabs (f, "") .
+
+root : f.atoms .
+
+END PROC initialize;
+
+
+(**********************************************************************)
+(* *)
+(* Segment Handler (SEGMENTs & CHAINs) *)
+(* *)
+(**********************************************************************)
+
+INT PROC segs (SEQUENCE CONST s, ATOMROW CONST atom) :
+
+ INT VAR number of segments := 0 ,
+ actual segment := s.segment begin ;
+ REP
+ number of segments INCR 1 ;
+ actual segment := atom (actual segment).seg.succ
+ UNTIL actual segment = s.segment begin PER ;
+ number of segments .
+
+ENDPROC segs ;
+
+
+PROC next segment (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ disable stop;
+ s.line no INCR (s.segment end - s.index + 1);
+ INT CONST new segment index := actual segment.succ;
+ s.segment begin := new segment index;
+ s.segment end := new segment.end;
+ s.index := new segment index .
+
+actual segment : atom (s.segment begin).seg .
+new segment : atom (new segment index).seg .
+
+END PROC next segment;
+
+
+PROC previous segment (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ disable stop;
+ s.line no DECR (s.index - s.segment begin + 1);
+ INT CONST new segment index := actual segment.pred;
+ s.segment begin := new segment index;
+ s.segment end := new segment.end;
+ s.index := s.segment end .
+
+actual segment : atom (s.segment begin).seg .
+new segment : atom (new segment index).seg .
+
+END PROC previous segment;
+
+
+PROC split segment (SEQUENCE VAR s, ATOMROW VAR atom) :
+
+ disable stop;
+ IF not at segment top
+ THEN split segment at actual position
+ FI .
+
+split segment at actual position :
+ INT CONST pred index := s.segment begin,
+ actual index := s.index,
+ succ index := pred.succ;
+
+ actual.pred := pred index;
+ actual.succ := succ index;
+ actual.end := s.segment end;
+
+ pred.succ := actual index;
+ pred.end := actual index - 1;
+
+ succ.pred := actual index;
+
+ s.segment begin := actual index .
+
+not at segment top : s.index > s.segment begin .
+
+pred : atom (pred index).seg .
+
+actual : atom (actual index).seg .
+
+succ : atom (succ index).seg .
+
+END PROC split segment;
+
+
+PROC join segments (ATOMROW VAR atom,
+ INT CONST first index, INT VAR second index) :
+
+ disable stop;
+ IF first seg.end + 1 = second index
+ THEN attach second to first segment
+ ELSE link first to second segment
+ FI .
+
+attach second to first segment :
+ first seg.end := second seg.end;
+ INT VAR successor of second := second seg.succ;
+ IF successor of second = second index
+ THEN first seg.succ := first index
+ ELSE join segments (atom, first index, successor of second)
+ FI;
+ second index := first index .
+
+link first to second segment :
+ first seg.succ := second index;
+ second seg.pred := first index .
+
+first seg : atom (first index).seg .
+second seg : atom (second index).seg .
+
+END PROC join segments;
+
+
+PROC delete segments (SEQUENCE VAR from, ATOMROW VAR atom,
+ INT CONST first index, last index, lines) :
+
+ determine surrounding segments and new atom index;
+ join surrounding segments;
+ update sequence descriptor .
+
+determine surrounding segments and new atom index :
+ INT VAR pred index := first seg.pred,
+ actual index := last seg.succ;
+ from.index := actual index .
+
+join surrounding segments :
+ join segments (atom, pred index, actual index) .
+
+update sequence descriptor :
+ from.segment begin := actual index;
+ from.segment end := actual seg.end;
+ from.lines DECR lines .
+
+actual seg : atom (actual index).seg .
+first seg : atom (first index).seg .
+last seg : atom (last index).seg .
+
+END PROC delete segments;
+
+
+PROC insert segments (SEQUENCE VAR into, ATOMROW VAR atom,
+ INT CONST first index, last index, lines) :
+
+ join into sequence and new segments;
+ update sequence descriptor .
+
+join into sequence and new segments :
+ INT VAR actual index := into.index,
+ pred index := actual seg.pred;
+ join segments (atom, last index, actual index);
+ actual index := first index;
+ join segments (atom, pred index, actual index) .
+
+update sequence descriptor :
+ into.index := first index;
+ into.segment begin := actual index;
+ into.segment end := actual seg.end;
+ into.lines INCR lines .
+
+actual seg : atom (actual index).seg .
+
+END PROC insert segments;
+
+
+PROC next atom (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ IF s.line no <= s.lines
+ THEN to next atom
+ ELSE errorstop ("'down' nach Dateiende")
+ FI .
+
+to next atom :
+ disable stop;
+ IF s.index = s.segment end
+ THEN next segment (s, atom)
+ ELSE s.index INCR 1;
+ s.line no INCR 1
+ FI
+
+END PROC next atom;
+
+
+PROC next atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) :
+
+ INT CONST destination line := min (s.line no + times, s.lines + 1);
+ jump upto destination segment;
+ position within destination segment .
+
+jump upto destination segment :
+ WHILE s.line no + length of actual segments tail < destination line REP
+ next segment (s, atom);
+ PER .
+
+position within destination segment :
+ disable stop;
+ s.index INCR (destination line - s.line no);
+ s.line no := destination line .
+
+length of actual segments tail : s.segment end - s.index .
+
+END PROC next atoms;
+
+
+PROC previous atom (SEQUENCE VAR s, ATOMROW CONST atom) :
+
+ IF s.line no > 1
+ THEN to previous atom
+ ELSE errorstop ("'up' am Dateianfang")
+ FI .
+
+to previous atom :
+ disable stop;
+ IF s.index = s.segment begin
+ THEN previous segment (s, atom)
+ ELSE s.index DECR 1;
+ s.line no DECR 1
+ FI
+
+END PROC previous atom;
+
+
+PROC previous atoms (SEQUENCE VAR s, ATOMROW CONST atom, INT CONST times) :
+
+ INT CONST destination line := max (1, s.line no - times);
+ jump back to destination segment;
+ position within destination segment .
+
+jump back to destination segment :
+ WHILE s.line no - length of actual segments head > destination line REP
+ previous segment (s, atom);
+ PER .
+
+position within destination segment :
+ disable stop;
+ s.index DECR (s.line no - destination line);
+ s.line no := destination line .
+
+length of actual segments head : s.index - s.segment begin .
+
+END PROC previous atoms;
+
+
+TEXT VAR pre, pat, pattern0;
+INT VAR last search line ;
+
+PROC search down (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT CONST max lines, INT VAR column) :
+
+ INT CONST start col := column ,
+ start line := s.lineno ;
+ last search line := min (s.lines, s.lineno + max lines) ;
+ pre:= somefix (pattern) ;
+ pattern0 := pattern ** 0 ;
+ down in atoms (s, atom, pre, column);
+ IF NOT (last search succeeded CAND like pattern)
+ THEN try again
+ FI;
+ last search succeeded := TRUE ;
+ column := matchpos (0) .
+
+try again:
+ WHILE s.line no < last search line
+ REP next atom (s, atom) ;
+ column := 1 ;
+ down in atoms (s, atom, pre, column);
+ IF last search succeeded CAND like pattern
+ THEN LEAVE try again
+ FI
+ PER;
+ column := 1 + LENGTH record;
+ last search succeeded := FALSE ;
+ LEAVE search down.
+
+like pattern :
+ correct position ;
+ pat := any (column-1) ;
+ pat CAT any ;
+ pat CAT pattern0 ;
+ pat CAT any ;
+ record LIKE pat .
+
+correct position :
+ IF s.lineno = start line
+ THEN column := start col
+ ELSE column := 1
+ FI .
+
+record : atom (s.index).line .
+
+ENDPROC search down ;
+
+PROC down in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT VAR column) :
+
+ last search succeeded := FALSE ;
+ search forwards in actual line ;
+ IF NOT found AND s.line no < last search line
+ THEN search in following lines
+ FI ;
+ IF found
+ THEN last search succeeded := TRUE
+ ELSE set column behind last char
+ FI .
+
+set column behind last char :
+ column := LENGTH atom (s.index).line + 1 .
+
+search forwards in actual line :
+ IF pattern <> ""
+ THEN column := pos (atom (s.index).line, pattern, column)
+ ELIF column > LENGTH atom (s.index).line
+ THEN column := 0
+ FI .
+
+search in following lines :
+ next atom (s, atom) ;
+ IF pattern = ""
+ THEN column := 1 ;
+ LEAVE search in following lines
+ FI ;
+ REP
+ search forwards through segment ;
+ update file position forwards ;
+ IF found OR s.line no = last search line
+ THEN LEAVE search in following lines
+ ELSE next segment (s, atom)
+ FI
+ PER .
+
+search forwards through segment :
+ INT VAR search index := s.index ,
+ last index := min (s.segment end, s.index+(last search line-s.line no));
+ REP
+ column := pos (atom (search index).line, pattern) ;
+ IF found OR search index = last index
+ THEN LEAVE search forwards through segment
+ FI ;
+ search index INCR 1
+ PER .
+
+update file position forwards :
+ disable stop ;
+ s.line no INCR (search index - s.index) ;
+ s.index := search index ;
+ enable stop .
+
+found : column > 0 .
+
+ENDPROC down in atoms ;
+
+TEXT PROC prefix (TEXT CONST pattern) :
+
+ INT VAR invalid char pos := pos (pattern, ""0"", ""31"", 1) ;
+ SELECT invalid char pos OF
+ CASE 0 : pattern
+ CASE 1 : ""
+ OTHERWISE : subtext (pattern, 1, invalid char pos - 1)
+ ENDSELECT .
+
+ENDPROC prefix ;
+
+PROC search up (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT CONST max lines, INT VAR column) :
+
+ last search line := max (1, s.lineno - max lines) ;
+ pre:= prefix (pattern);
+ pattern0 := pattern ** 0;
+ remember start point ;
+ up in atoms (s, atom, pre, column);
+ IF NOT (last search succeeded CAND last pattern in line found)
+ THEN try again
+ FI;
+ last search succeeded := TRUE ;
+ column := matchpos (0) .
+
+ try again:
+ WHILE s.lineno > last search line OR column > 1
+ REP previous atom (s, atom);
+ column := LENGTH record ;
+ up in atoms (s, atom, pre, column);
+ IF last search succeeded CAND last pattern in line found
+ THEN LEAVE try again
+ FI
+ PER;
+ column := 1;
+ last search succeeded := FALSE ;
+ LEAVE search up.
+
+ remember start point :
+ INT VAR c:= column, r:= s.lineno;.
+
+ last pattern in line found :
+ column := 2 ;
+ WHILE like pattern CAND right of start REP
+ column := matchpos (0) +1
+ PER ;
+ column DECR 1 ;
+ like pattern CAND right of start .
+
+ like pattern :
+ pat := any (column-1) ;
+ pat CAT any ;
+ pat CAT pattern0 ;
+ pat CAT any ;
+ record LIKE pat .
+
+ right of start : (r > s.lineno COR c >= matchpos(0)) .
+ record : atom (s.index).line .
+
+ENDPROC search up ;
+
+PROC up in atoms (SEQUENCE VAR s, ATOMROW CONST atom, TEXT CONST pattern,
+ INT VAR column) :
+
+ last search succeeded := FALSE ;
+ search backwards in actual line ;
+ IF NOT found AND s.line no > last search line
+ THEN search in preceeding lines
+ FI ;
+ IF found
+ THEN last search succeeded := TRUE
+ ELSE column := 1
+ FI .
+
+search backwards in actual line :
+ IF pattern = ""
+ THEN LEAVE search backwards in actual line
+ FI ;
+ INT VAR last pos , new pos := 0 ;
+ REP
+ last pos := new pos ;
+ new pos := pos (atom (s.index).line, pattern, last pos+1) ;
+ UNTIL new pos = 0 OR new pos > column PER ;
+ column := last pos .
+
+search in preceeding lines :
+ previous atom (s, atom) ;
+ IF pattern = ""
+ THEN column := LENGTH atom (s.index).line + 1 ;
+ last search succeeded := TRUE ;
+ LEAVE search in preceeding lines
+ FI ;
+ REP
+ search backwards through segment ;
+ update file position backwards ;
+ IF found OR s.line no = last search line
+ THEN LEAVE search in preceeding lines
+ ELSE previous segment (s, atom)
+ FI
+ PER .
+
+search backwards through segment :
+ INT VAR search index := s.index ,
+ last index := max (s.segment begin, s.index-(s.line no-last search line));
+ REP
+ new pos := 0 ;
+ REP
+ column := new pos ;
+ new pos := pos (atom (search index).line, pattern, column+1) ;
+ UNTIL new pos = 0 PER ;
+ IF found OR search index = last index
+ THEN LEAVE search backwards through segment
+ FI ;
+ search index DECR 1
+ PER .
+
+update file position backwards :
+ disable stop ;
+ s.line no DECR (s.index - search index) ;
+ s.index := search index ;
+ enable stop .
+
+found : column > 0 .
+
+ENDPROC up in atoms ;
+
+BOOL VAR last search succeeded ;
+
+BOOL PROC pattern found :
+ last search succeeded
+ENDPROC pattern found ;
+
+
+
+PROC delete atom (SEQUENCE VAR used, free, ATOMROW VAR atom) :
+
+ disable stop;
+ IF used.line no <= used.lines
+ THEN delete actual atom
+ ELSE errorstop ("'delete' am Dateiende")
+ FI .
+
+delete actual atom :
+ position behind actual free segment;
+ split segment (used, atom);
+ INT VAR actual index := used.index;
+ cut off tail of actual used segment;
+ delete segments (used, atom, actual index, actual index, 1);
+ insert segments (free, atom, actual index, actual index, 1) .
+
+position behind actual free segment :
+ IF free.line no <= free.lines
+ THEN next segment (free, atom)
+ FI .
+
+cut off tail of actual used segment :
+ IF actual index <> used.segment end
+ THEN used.index INCR 1;
+ split segment (used, atom);
+ used.index DECR 1
+ FI .
+
+END PROC delete atom;
+
+
+PROC insert atom (SEQUENCE VAR used, free,INT VAR unused, ATOMROW VAR atom) :
+
+ disable stop;
+ split segment (used, atom);
+ IF free.lines > 0
+ THEN insert new atom from free sequence
+ ELIF unused <= file size
+ THEN insert new atom from unused tail
+ ELSE errorstop ("FILE-Ueberlauf")
+ FI .
+
+insert new atom from free sequence :
+ get a free segments head;
+ make this atom to actual segment;
+ transfer from free to used chain .
+
+get a free segments head :
+ IF actual free segment is root segment
+ THEN previous segment (free, atom)
+ FI;
+ position to actual segments head .
+
+position to actual segments head :
+ INT VAR actual index := free.segment begin;
+ free.line no DECR (free.index - actual index);
+ free.index := actual index .
+
+make this atom to actual segment :
+ IF free.segment end > actual index
+ THEN free.index INCR 1;
+ split segment (free, atom);
+ free.index DECR 1
+ FI .
+
+transfer from free to used chain :
+ delete segments (free, atom, actual index, actual index, 1);
+ insert segments (used, atom, actual index, actual index, 1);
+ atom (actual index).line := "" .
+
+insert new atom from unused tail :
+ actual index := unused;
+ atom (actual index).seg :=
+ SEGMENT:(actual index, actual index, actual index);
+ atom (actual index).line := "";
+ insert segments (used, atom, actual index, actual index, 1);
+ unused INCR 1 .
+
+actual free segment is root segment : free.segment begin = free root .
+
+END PROC insert atom;
+
+
+PROC insert next (SEQUENCE VAR used, free, INT VAR unused, ATOMROW VAR atom,
+ TEXT CONST record) :
+
+ IF used.line no > used.lines
+ THEN insert atom (used, free, unused, atom)
+ ELIF actual position before unused nonempty atomrow part
+ THEN forward and insert atom by simple extension of used atomrow part
+ ELSE next atom (used, atom);
+ insert atom (used, free, unused, atom)
+ FI;
+ atom (used.index).line := record .
+
+forward and insert atom by simple extension of used atomrow part :
+ used.line no INCR 1;
+ used.lines INCR 1;
+ used.index INCR 1;
+ used.segment end INCR 1;
+ atom (used.segment begin).seg.end INCR 1;
+ unused INCR 1 .
+
+actual position before unused nonempty atomrow part :
+ used.index = unused - 1 AND unused part not empty .
+
+unused part not empty : unused <= file size .
+
+END PROC insert next;
+
+
+PROC transfer subsequence (SEQUENCE VAR source, dest,
+ ATOMROW VAR atom, INT CONST size) :
+
+ IF size > 0
+ THEN INT VAR subsequence size := min (size, source.line no);
+ mark begin of source part;
+ mark end of source part;
+ split destination sequence;
+ transfer part
+ FI .
+
+mark begin of source part :
+ previous atoms (source, atom, subsequence size - 1);
+ split segment (source, atom);
+ INT CONST first := source.segment begin .
+
+mark end of source part :
+ next atoms (source, atom, subsequence size - 1);
+ INT CONST last := source.segment begin;
+ next atom (source, atom);
+ split segment (source, atom) .
+
+split destination sequence :
+ split segment (dest, atom) .
+
+transfer part :
+ disable stop;
+ delete segments (source, atom, first, last, subsequence size);
+ source.line no DECR subsequence size;
+ insert segments (dest, atom, first, last, subsequence size);
+ next atoms (dest, atom, subsequence size - 1) .
+
+END PROC transfer subsequence;
+
+
+
+(********************************************************************)
+(***** *****)
+(***** FILE handler *****)
+(***** *****)
+(********************************************************************)
+
+
+
+LET file type = 1003 ,
+ file type 16 = 1002 ,
+
+ closed = 0,
+ inp = 1,
+ outp = 2,
+ mod = 3,
+ end = 4,
+
+ max limit = 16000,
+ super limit = 16001;
+
+
+TYPE TRANSPUTDIRECTION = INT;
+
+
+TRANSPUTDIRECTION PROC input :
+ TRANSPUTDIRECTION : (inp)
+END PROC input;
+
+
+TRANSPUTDIRECTION PROC output :
+ TRANSPUTDIRECTION : (outp)
+END PROC output;
+
+
+TRANSPUTDIRECTION PROC modify :
+ TRANSPUTDIRECTION : (mod)
+END PROC modify;
+
+
+FILE VAR result file;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ DATASPACE CONST ds) :
+ IF type (ds) = file type
+ THEN result := ds
+ ELIF type (ds) < 0
+ THEN result := ds; type (ds, file type); initialize (result file)
+ ELSE enable stop; errorstop ("Datenraum hat falschen Typ")
+ FI;
+ reset (result file, mode);
+ result file .
+
+result : CONCR (result file) .
+
+END PROC sequential file;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode, TEXT CONST name) :
+
+ IF exists (name)
+ THEN get dataspace if file
+ ELIF CONCR (mode) <> inp
+ THEN get new file space
+ ELSE errorstop (""""+name+""" gibt es nicht") ; enable stop
+ FI;
+ update status if necessary;
+ reset (result file, mode);
+ result file .
+
+get dataspace if file :
+ IF type (old (name)) = file type 16
+ THEN reorganize (name)
+ FI ;
+ result := old (name, file type) ;
+ IF is 170 file
+ THEN result.col := 1 ;
+ result.mark line := 0 ;
+ result.mark col := 0
+ FI .
+
+is 170 file : result.mark col < 0 .
+
+get new file space :
+ result := new (name);
+ IF NOT is error
+ THEN type (old (name), file type); initialize (result file)
+ FI .
+
+update status if necessary :
+ IF CONCR (mode) <> inp
+ THEN status (name, ""); headline (result file, name)
+ FI .
+
+result : CONCR (result file) .
+
+END PROC sequential file;
+
+
+PROC reset (FILE VAR f) :
+
+ IF f.mode = end
+ THEN reset (f, input)
+ ELSE reset (f, TRANSPUTDIRECTION:(f.mode))
+ FI .
+
+ENDPROC reset ;
+
+PROC reset (FILE VAR f, TRANSPUTDIRECTION CONST mode) :
+
+ IF f.mode <> mod OR new mode <> mod
+ THEN f.mode := new mode ;
+ initialize file index
+ FI .
+
+initialize file index :
+ IF new mode = outp
+ THEN to line without check (f, f.used.lines);
+ col := super limit
+ ELSE to line without check (f, 1);
+ col := 1 ;
+ IF new mode = inp AND file is empty
+ THEN f.mode := end
+ FI
+ FI .
+
+file is empty : f.used.lines = 0 .
+
+new mode : CONCR (mode) .
+
+col : CONCR (CONCR (f)).col .
+
+END PROC reset;
+
+
+PROC input (FILE VAR f) :
+
+ reset (f, input) .
+
+END PROC input;
+
+
+PROC output (FILE VAR f) :
+
+ reset (f, output)
+
+END PROC output;
+
+
+PROC modify (FILE VAR f) :
+
+ reset (f, modify)
+
+END PROC modify;
+
+
+PROC close (FILE VAR f) :
+
+ f.mode := closed .
+
+END PROC close;
+
+
+PROC check mode (FILE CONST f, INT CONST mode) :
+
+ IF f.mode = mode
+ THEN LEAVE check mode
+ ELIF f.mode = closed
+ THEN errorstop ("Datei zu!")
+ ELIF f.mode = mod
+ THEN errorstop ("unzulaessiger Zugriff auf modify-FILE")
+ ELIF mode = mod
+ THEN errorstop ("Zugriff nur auf modify-FILE zulaessig")
+ ELIF f.mode = end
+ THEN errorstop ("Leseversuch nach Dateiende")
+ ELIF mode = inp
+ THEN errorstop ("Leseversuch auf output-FILE")
+ ELIF mode = outp
+ THEN errorstop ("Schreibversuch auf input-FILE")
+ FI .
+
+END PROC check mode;
+
+
+PROC to line without check (FILE VAR f, INT CONST destination line) :
+
+ INT CONST distance := destination line - f.used.line no;
+ IF distance > 0
+ THEN next atoms (f.used, f.atoms, distance)
+ ELIF distance < 0
+ THEN previous atoms (f.used, f.atoms, - distance)
+ FI .
+
+END PROC to line without check;
+
+
+PROC to line (FILE VAR f, INT CONST destination line) :
+
+ check mode (f, mod);
+ to line without check (f, destination line)
+
+END PROC to line;
+
+
+PROC to first record (FILE VAR f) :
+
+ to line (f, 1)
+
+END PROC to first record;
+
+
+PROC to eof (FILE VAR f) :
+
+ to line (f, f.used.lines + 1) .
+
+END PROC to eof;
+
+
+PROC putline (FILE VAR f, TEXT CONST word) :
+
+ write (f, word);
+ col := super limit .
+
+col : CONCR (CONCR (f)).col .
+
+END PROC putline;
+
+
+PROC delete record (FILE VAR f) :
+
+ check mode (f, mod);
+ delete atom (f.used, f.free, f.atoms) .
+
+END PROC delete record;
+
+
+PROC insert record (FILE VAR f) :
+
+ check mode (f, mod);
+ insert atom (f.used, f.free, f.unused tail, f.atoms) .
+
+END PROC insert record;
+
+
+PROC down (FILE VAR f) :
+
+ check mode (f, mod);
+ next atom (f.used, f.atoms) .
+
+END PROC down ;
+
+PROC up (FILE VAR f) :
+
+ check mode (f, mod);
+ previous atom (f.used, f.atoms) .
+
+END PROC up ;
+
+PROC down (FILE VAR f, INT CONST n) :
+
+ to line (f, lineno (f) + n)
+
+ENDPROC down ;
+
+PROC up (FILE VAR f, INT CONST n) :
+
+ to line (f, lineno (f) - n)
+
+ENDPROC up ;
+
+
+PROC write record (FILE VAR f, TEXT CONST record) :
+
+ check mode (f, mod);
+ IF not at eof
+ THEN f.atoms (f.used.index).line := record
+ ELSE errorstop ("'write' nach Dateiende")
+ FI .
+
+not at eof : f.used.line no <= f.used.lines .
+
+END PROC write record;
+
+
+PROC read record (FILE CONST f, TEXT VAR record) :
+
+ check mode (f, mod);
+ record := f.atoms (f.used.index).line .
+
+END PROC read record;
+
+
+PROC line (FILE VAR f) :
+
+ IF mode = end
+ THEN errorstop ("Leseversuch nach Dateiende")
+ ELIF mode = inp
+ THEN next atom (f.used, f.atoms); col := 1; check eof
+ ELIF mode = outp
+ THEN IF col <= max limit
+ THEN col := super limit
+ ELSE append empty line
+ FI
+ FI .
+
+append empty line :
+ insert next (f.used, f.free, f.unused tail, f.atoms, "") .
+
+col : CONCR (CONCR (f)).col .
+
+mode : CONCR (CONCR (f)).mode .
+
+check eof :
+ IF eof (f) THEN mode := end FI .
+
+END PROC line;
+
+
+PROC line (FILE VAR f, INT CONST lines) :
+
+ INT VAR i; FOR i FROM 1 UPTO lines REP line (f) PER
+
+END PROC line;
+
+
+PROC getline (FILE VAR f, TEXT VAR text) :
+
+ check mode (f, inp);
+ text := subtext (record, f.col);
+ IF f.used.line no >= f.used.lines
+ THEN f.mode := end ;
+ set end of file
+ ELSE to next line ;
+ f.col := 1
+ FI .
+
+to next line :
+ next atom (f.used, f.atoms) .
+
+set end of file :
+ f.col := LENGTH record + 1 .
+
+record : f.atoms (f.used.index).line .
+
+END PROC getline;
+
+
+BOOL PROC is first record (FILE CONST f) :
+
+ check mode (f, mod);
+ f.used.line no = 1 .
+
+END PROC is first record;
+
+
+BOOL PROC eof (FILE CONST f) :
+
+ IF line no < lines THEN FALSE
+ ELIF line no = lines THEN col > LENGTH record
+ ELSE TRUE
+ FI .
+
+line no : f.used.line no .
+lines : f.used.lines .
+col : f.col .
+record : f.atoms (f.used.index).line .
+
+END PROC eof;
+
+
+INT PROC line no (FILE CONST f) :
+
+ f.used.line no .
+
+END PROC line no;
+
+
+PROC line type (FILE VAR f, INT CONST t) :
+
+ f.atoms (f.used.index).type := t .
+
+ENDPROC line type ;
+
+INT PROC line type (FILE CONST f) :
+
+ f.atoms (f.used.index).type .
+
+ENDPROC line type ;
+
+
+PROC put (FILE VAR f, TEXT CONST word) :
+
+ check mode (f, outp);
+ IF col + LENGTH word > f.limit
+ THEN append new line
+ ELSE record CAT word
+ FI;
+ record CAT " ";
+ col := LENGTH record + 1 .
+
+append new line :
+ insert next (f.used, f.free, f.unused tail, f.atoms, word) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+END PROC put;
+
+
+PROC put (FILE VAR f, INT CONST value) :
+
+ put (f, text (value))
+
+END PROC put;
+
+
+PROC put (FILE VAR f, REAL CONST real) :
+
+ put (f, text (real))
+
+END PROC put;
+
+
+PROC write (FILE VAR f, TEXT CONST word) :
+
+ check mode (f, outp);
+ IF col + LENGTH word - 1 > f.limit
+ THEN append new line
+ ELSE record CAT word
+ FI;
+ col := LENGTH record + 1 .
+
+append new line :
+ insert next (f.used, f.free, f.unused tail, f.atoms, word) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+END PROC write;
+
+
+PROC get (FILE VAR f, TEXT VAR word, TEXT CONST separator) :
+
+ check mode (f, inp);
+ skip separators;
+ IF word found
+ THEN get word
+ ELSE try to find word in next line
+ FI .
+
+skip separators :
+ INT CONST separator length := LENGTH separator;
+ WHILE is separator REP col INCR separator length PER .
+
+is separator :
+ subtext (record, col, col + separator length - 1) = separator .
+
+word found : col <= LENGTH record .
+
+get word :
+ INT VAR end of word := pos (record, separator, col) - 1;
+ IF separator found
+ THEN get text upto separator
+ ELSE get rest of record
+ FI .
+
+separator found : end of word >= 0 .
+
+get text upto separator :
+ word := subtext (record, col, end of word);
+ col := end of word + separator length + 1;
+ IF col > LENGTH record THEN line (f) FI .
+
+get rest of record :
+ word := subtext (record, col); line (f) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+try to find word in next line :
+ line (f); IF eof (f) THEN word := "" ELSE get (f, word, separator) FI .
+
+END PROC get;
+
+
+PROC get (FILE VAR f, TEXT VAR word, INT CONST max length) :
+
+ check mode (f, inp);
+ IF word is only a part of record
+ THEN get text of certain length
+ ELSE get rest of record
+ FI .
+
+word is only a part of record :
+ col <= LENGTH record - max length .
+
+get text of certain length :
+ word := text (record, max length, col);
+ col INCR max length .
+
+get rest of record :
+ word := subtext (record, col); line (f) .
+
+record : f.atoms (f.used.index).line .
+col : f.col .
+
+END PROC get;
+
+
+PROC get (FILE VAR f, TEXT VAR word) :
+
+ get (f, word, " ")
+
+END PROC get;
+
+
+TEXT VAR number word;
+
+
+PROC get (FILE VAR f, INT VAR number) :
+
+ get (f, number word);
+ number := int (number word)
+
+END PROC get;
+
+
+PROC get (FILE VAR f, REAL VAR number) :
+
+ get (f, number word);
+ number := real (number word)
+
+END PROC get;
+
+
+TEXT VAR split record ;
+INT VAR indentation ;
+
+PROC split line (FILE VAR f, INT CONST split col) :
+
+ split line (f, split col, TRUE)
+
+ENDPROC split line ;
+
+PROC split line (FILE VAR f, INT CONST split col, BOOL CONST note indentation ) :
+
+ IF note indentation
+ THEN get indentation
+ ELSE indentation := 0
+ FI ;
+ get split record ;
+ insert split record and indentation ;
+ cut off old record .
+
+get indentation :
+ indentation := pos (actual record,""33"",""254"",1) - 1 ;
+ IF indentation < 0 OR indentation >= split col
+ THEN indentation := split col - 1
+ FI .
+
+get split record :
+ split record := subtext (actual record, split col, max limit) .
+
+insert split record and indentation :
+ down (f) ;
+ insert record (f) ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO indentation REP
+ actual record CAT " "
+ PER ;
+ actual record CAT split record ;
+ up (f) .
+
+cut off old record :
+ actual record := subtext (actual record, 1, split col-1) .
+
+actual record : f.atoms (f.used.index).line .
+
+ENDPROC split line ;
+
+PROC concatenate line (FILE VAR f, BOOL CONST delete blanks) :
+
+ down (f) ;
+ split record := actual record ;
+ IF delete blanks
+ THEN delete leading blanks
+ FI ;
+ delete record (f) ;
+ up (f) ;
+ actual record CAT split record .
+
+delete leading blanks :
+ INT CONST non blank col := pos (split record, ""33"", ""254"", 1) ;
+ IF non blank col > 0
+ THEN split record := subtext (split record, non blank col)
+ FI .
+
+actual record : f.atoms (f.used.index).line .
+
+ENDPROC concatenate line ;
+
+PROC concatenate line (FILE VAR f) :
+ concatenate line (f, TRUE)
+ENDPROC concatenate line ;
+
+PROC reorganize :
+
+ reorganize (last param)
+
+END PROC reorganize;
+
+
+TEXT VAR file record ;
+
+PROC reorganize (TEXT CONST file name) :
+
+ enable stop ;
+ FILE VAR input file, output file;
+ DATASPACE VAR scratch space;
+ INT CONST type of dataspace := type (old (file name)) ;
+ INT VAR counter;
+
+ last param (file name);
+ IF type of dataspace = file type
+ THEN reorganize new to new
+ ELIF type of dataspace = file type 16
+ THEN reorganize old to new
+ ELSE errorstop ("Datenraum hat falschen Typ")
+ FI;
+ replace file space by scratch space .
+
+reorganize new to new :
+ input file := sequential file (input, file name);
+ disable stop ;
+ scratch space := nilspace ;
+ output file := sequential file (output, scratch space);
+ copy attributes (input file, output file) ;
+
+ FOR counter FROM 1 UPTO 9999
+ WHILE NOT eof (input file) REP
+ cout (counter);
+ getline (input file, file record);
+ putline (output file, file record);
+ check for interrupt
+ PER .
+
+reorganize old to new :
+ LET OLDRECORD = STRUCT (INT succ, pred, x, y, TEXT record);
+ LET OLDFILE = BOUND ROW 4075 OLDRECORD;
+ LET dateianker = 2, freianker = 1;
+ INT VAR index := dateianker;
+
+ OLDFILE VAR old file := old (file name);
+ disable stop;
+ scratch space := nilspace;
+ output file := sequential file (output, scratch space);
+ get old attributes ;
+
+ say ("Datei wird in 1.7-Format gewandelt: ") ;
+
+ FOR counter FROM 1 UPTO 9999
+ WHILE NOT end of old file REP
+ cout (counter);
+ index := next record;
+ file record := record of old file ;
+ IF pos (file record, ""128"", ""250"", 1) > 0
+ THEN change special chars
+ FI ;
+ putline (output file, file record);
+ check for interrupt
+ PER .
+
+get old attributes :
+ get old headline ;
+ get old limit and tabs .
+
+get old headline :
+ headline (output file, old file (dateianker).record) .
+
+get old limit and tabs :
+ file record := old file (freianker).record ;
+ max line length (output file, int (subtext (file record, 11, 15))) ;
+ put tabs (output file, subtext (file record, 16)) .
+
+change special chars :
+ change all (file record, ""193"", ""214"") (* Ae *) ;
+ change all (file record, ""207"", ""215"") (* Oe *) ;
+ change all (file record, ""213"", ""216"") (* Ue *) ;
+ change all (file record, ""225"", ""217"") (* ae *) ;
+ change all (file record, ""239"", ""218"") (* oe *) ;
+ change all (file record, ""245"", ""219"") (* ue *) ;
+ change all (file record, ""235"", ""220"") (* k *) ;
+ change all (file record, ""173"", ""221"") (* - *) ;
+ change all (file record, ""163"", ""222"") (* fis *) ;
+ change all (file record, ""160"", ""223"") (* blank *) ;
+ change all (file record, ""194"", ""251"") (* eszet *) .
+
+end of old file : next record = dateianker .
+
+next record : old file (index).succ .
+
+record of old file : old file (index).record .
+
+check for interrupt :
+ INT VAR size, used ;
+ storage (size, used) ;
+ IF used > size
+ THEN errorstop ("Speicherengpass")
+ FI ;
+ IF is error
+ THEN forget (scratch space) ; LEAVE reorganize
+ FI .
+
+replace file space by scratch space :
+ headline (output file, file name);
+ forget (file name, quiet) ;
+ type (scratch space, file type);
+ copy (scratch space, file name);
+ forget (scratch space) .
+
+END PROC reorganize;
+
+
+PROC set range (FILE VAR f, INT CONST start line, start col,
+ FRANGE VAR old range) :
+
+ check mode (f, mod);
+ IF valid restriction parameters
+ THEN prepare last line ;
+ prepare first line ;
+ save old range ;
+ set new range
+ ELSE errorstop ("FRANGE ungueltig")
+ FI .
+
+valid restriction parameters :
+ start line > 0 AND start col > 0 AND start before or at actual point .
+
+start before or at actual point :
+ start line < line no (f) OR
+ start line = line no (f) AND start col <= col (f) .
+
+prepare last line :
+ INT VAR last line ;
+ IF col (f) > 1
+ THEN split line (f, col(f), FALSE)
+ FI .
+
+prepare first line :
+ IF start col > 1
+ THEN split start line ;
+ FI .
+
+split start line :
+ INT VAR old line no := line no (f) ;
+ to line (f, start line) ;
+ split line (f, start col, FALSE) ;
+ to line (f, old line no + 1) .
+
+save old range :
+ old range.pre := f.prefix lines ;
+ old range.post:= f.postfix lines .
+
+set new range :
+ get pre lines ;
+ get post lines ;
+ disable stop ;
+ f.prefix lines INCR pre lines ;
+ f.postfix lines INCR post lines ;
+ f.used.lines DECR (post lines + pre lines) ;
+ f.used.line no DECR pre lines .
+
+get pre lines :
+ INT VAR pre lines ;
+ IF start col = 1
+ THEN old range.pre was split := FALSE ;
+ pre lines := start line - 1
+ ELSE old range.pre was split := TRUE ;
+ pre lines := start line
+ FI .
+
+get post lines :
+ INT VAR post lines ;
+ IF col (f) = 1
+ THEN old range.post was split := FALSE ;
+ post lines := lines (f) - line no (f) + 1
+ ELSE old range.post was split := TRUE ;
+ post lines := lines (f) - line no (f)
+ FI .
+
+END PROC set range;
+
+
+PROC set range (FILE VAR f, FRANGE VAR new range) :
+
+ check mode (f, mod);
+ INT CONST pre add := prefix - new range.pre,
+ post add := postfix - new range.post;
+ IF pre add < 0 OR post add < 0
+ THEN errorstop ("FRANGE ungueltig")
+ ELSE set new range;
+ undo splitting if necessary ;
+ make range var invalid
+ FI .
+
+set new range :
+ disable stop;
+ prefix DECR pre add;
+ postfix DECR post add;
+ used.line no INCR pre add;
+ used.lines INCR (pre add + post add) .
+
+undo splitting if necessary :
+ IF new range.pre was split
+ THEN concatenate first line
+ FI ;
+ IF new range.post was split
+ THEN concatenate last line
+ FI .
+
+concatenate first line :
+ INT VAR old line := line no (f) ;
+ to line (f, pre add) ;
+ concatenate line (f, FALSE) ;
+ to line (f, old line - 1) .
+
+concatenate last line :
+ old line := line no (f) ;
+ to line (f, lines (f) - post add) ;
+ concatenate line (f, FALSE) ;
+ to line (f, old line) .
+
+make range var invalid :
+ new range.pre := maxint .
+
+used : f.used .
+prefix : f.prefix lines .
+postfix : f.postfix lines .
+
+END PROC set range;
+
+PROC reset range (FILE VAR f) :
+
+ FRANGE VAR complete ;
+ complete.pre := 0 ;
+ complete.post:= 0 ;
+ complete.pre was split := FALSE ;
+ complete.post was split:= FALSE ;
+ set range (f, complete)
+
+ENDPROC reset range ;
+
+PROC remove (FILE VAR f, INT CONST size) :
+
+ check mode (f, mod);
+ transfer subsequence (f.used, f.scratch, f.atoms, size) .
+
+END PROC remove;
+
+
+PROC clear removed (FILE VAR f) :
+
+ check mode (f, mod);
+ transfer subsequence (f.scratch, f.free, f.atoms, f.scratch.lines) .
+
+END PROC clear removed;
+
+
+PROC reinsert (FILE VAR f) :
+
+ check mode (f, mod);
+ transfer subsequence (f.scratch, f.used, f.atoms, f.scratch.lines) .
+
+END PROC reinsert;
+
+
+PROC copy attributes (FILE CONST source file, FILE VAR dest file) :
+
+ dest.limit := source.limit ;
+ dest.atoms (free root).line := source.atoms (free root).line ;
+ dest.atoms (scratch root).line := source.atoms (scratch root).line ;
+ dest.edit info := source.edit info .
+
+dest : CONCR (CONCR (dest file)) .
+source : CONCR (CONCR (source file)) .
+
+ENDPROC copy attributes ;
+
+
+INT PROC max line length (FILE CONST f) :
+
+ f.limit .
+
+END PROC max line length;
+
+
+PROC max line length (FILE VAR f, INT CONST new limit) :
+
+ IF new limit > 0 AND new limit <= max limit
+ THEN f.limit := new limit
+ FI .
+
+END PROC max line length;
+
+
+TEXT PROC headline (FILE CONST f) :
+
+ f.atoms (free root).line .
+
+END PROC headline;
+
+
+PROC headline (FILE VAR f, TEXT CONST head) :
+
+ f.atoms (free root).line := head .
+
+END PROC headline;
+
+
+PROC get tabs (FILE CONST f, TEXT VAR tabs) :
+
+ tabs := f.atoms (scratch root).line .
+
+END PROC get tabs;
+
+
+PROC put tabs (FILE VAR f, TEXT CONST tabs) :
+
+ f.atoms (scratch root).line := tabs .
+
+END PROC put tabs;
+
+
+INT PROC edit info (FILE CONST f) :
+
+ f.edit info .
+
+END PROC edit info;
+
+
+PROC edit info (FILE VAR f, INT CONST info) :
+
+ f.edit info := info .
+
+END PROC edit info;
+
+
+INT PROC lines (FILE CONST f) :
+
+ f.used.lines .
+
+END PROC lines;
+
+
+INT PROC removed lines (FILE CONST f) :
+
+ f.scratch.lines .
+
+END PROC removed lines;
+
+
+INT PROC segments (FILE CONST f) :
+
+ segs(f.used,f.atoms) + segs(f.scratch,f.atoms) + segs(f.free,f.atoms) - 2 .
+
+ENDPROC segments ;
+
+
+INT PROC col (FILE CONST f) :
+
+ f.col
+
+ENDPROC col ;
+
+PROC col (FILE VAR f, INT CONST new column) :
+
+ IF new column > 0
+ THEN f.col := new column
+ FI
+
+ENDPROC col ;
+
+TEXT PROC word (FILE CONST f) :
+
+ word (f, " ")
+
+ENDPROC word ;
+
+TEXT PROC word (FILE CONST f, TEXT CONST delimiter) :
+
+ INT VAR del pos := pos (f, delimiter, col (f)) ;
+ IF del pos = 0
+ THEN del pos := len (f) + 1
+ FI ;
+ subtext (f, col (f), del pos - 1)
+
+ENDPROC word ;
+
+TEXT PROC word (FILE CONST f, INT CONST max length) :
+
+ subtext (f, col (f), col (f) + max length - 1)
+
+ENDPROC word ;
+
+BOOL PROC at (FILE CONST f, TEXT CONST word) :
+
+ pat := any (column-1) ;
+ pat CAT word ;
+ pat CAT any ;
+ record LIKE pat .
+
+column : f.col .
+record : f.atoms (f.used.index).line .
+
+ENDPROC at ;
+
+
+PROC exec (PROC (TEXT VAR, TEXT CONST) proc, FILE VAR f, TEXT CONST t) :
+
+ proc (record, t) .
+
+record : f.atoms (f.used.index).line .
+
+END PROC exec;
+
+
+PROC exec (PROC (TEXT VAR, INT CONST) proc, FILE VAR f, INT CONST i) :
+
+ proc (record, i) .
+
+record : f.atoms (f.used.index).line .
+
+END PROC exec;
+
+INT PROC pos (FILE CONST f, TEXT CONST pattern, INT CONST i) :
+
+ pos (record, pattern, i) .
+
+record : f.atoms (f.used.index).line .
+
+END PROC pos ;
+
+PROC down (FILE VAR f, TEXT CONST pattern) :
+
+ down (f, pattern, file size)
+
+ENDPROC down ;
+
+PROC down (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col + 1 ;
+ search down (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC down ;
+
+PROC downety (FILE VAR f, TEXT CONST pattern) :
+
+ downety (f, pattern, file size)
+
+ENDPROC downety ;
+
+PROC downety (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col ;
+ search down (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC downety ;
+
+PROC up (FILE VAR f, TEXT CONST pattern) :
+
+ up (f, pattern, file size)
+
+ENDPROC up ;
+
+PROC up (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col - 1 ;
+ search up (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC up ;
+
+PROC uppety (FILE VAR f, TEXT CONST pattern) :
+
+ uppety (f, pattern, file size)
+
+ENDPROC uppety ;
+
+PROC uppety (FILE VAR f, TEXT CONST pattern, INT CONST max line) :
+
+ check mode (f,mod) ;
+ INT VAR pattern pos := f.col ;
+ search up (f.used, f.atoms, pattern, max line, pattern pos) ;
+ f.col := pattern pos
+
+ENDPROC uppety ;
+
+
+INT PROC len (FILE CONST f) :
+
+ length (record) .
+
+record : f.atoms (f.used.index).line .
+
+ENDPROC len ;
+
+TEXT PROC subtext (FILE CONST f, INT CONST from, to) :
+
+ subtext (record, from, to) .
+
+record : f.atoms (f.used.index).line .
+
+ENDPROC subtext ;
+
+PROC change (FILE VAR f, INT CONST from, to, TEXT CONST new) :
+
+ check mode (f, mod) ;
+ change (record, from, to, new) .
+
+record : f.atoms (f.used.index).line .
+
+ENDPROC change ;
+
+
+BOOL PROC mark (FILE CONST f) :
+
+ f.mark line > 0
+
+ENDPROC mark ;
+
+PROC mark (FILE VAR f, INT CONST line no, col) :
+
+ IF line no > 0
+ THEN f.mark line := line no + f.prefix lines ;
+ f.mark col := col
+ ELSE f.mark line := 0 ;
+ f.mark col := 0
+ FI
+
+ENDPROC mark ;
+
+INT PROC mark line no (FILE CONST f) :
+
+ IF f.mark line = 0
+ THEN 0
+ ELSE max (1, f.mark line - f.prefix lines)
+ FI
+
+ENDPROC mark line no ;
+
+INT PROC mark col (FILE CONST f) :
+
+ IF f.mark line = 0
+ THEN 0
+ ELIF f.mark line <= f.prefix lines
+ THEN 1
+ ELSE f.mark col
+ FI
+
+ENDPROC mark col ;
+
+PROC set marked range (FILE VAR f, FRANGE VAR old range) :
+
+ IF mark (f)
+ THEN set range (f, mark line no (f), mark col (f), old range)
+ ELSE old range := previous range of file
+ FI .
+
+previous range of file :
+ FRANGE : (f.prefix lines, f.postfix lines, FALSE, FALSE) .
+
+ENDPROC set marked range ;
+
+
+(*****************************************************************)
+
+ (* Autor: P.Heyderhoff *)
+ (* Stand: 11.10.83 *)
+
+BOUND LIST VAR datei;
+INT VAR sortierstelle, sortanker;
+BOOL VAR ascii sort;
+TEXT VAR median, tausch , links, rechts;
+
+PROC sort (TEXT CONST dateiname) :
+ sort (dateiname, 1)
+END PROC sort;
+
+PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) :
+ ascii sort := TRUE ;
+ sortierstelle := sortieranfang; sortiere (dateiname)
+END PROC sort;
+
+PROC lex sort (TEXT CONST dateiname) :
+ lex sort (dateiname, 1)
+ENDPROC lex sort ;
+
+PROC lex sort (TEXT CONST dateiname, INT CONST sortieranfang) :
+ ascii sort := FALSE ;
+ sortierstelle := sortieranfang; sortiere (dateiname)
+ENDPROC lex sort ;
+
+PROC sortiere (TEXT CONST dateiname) :
+
+ reorganize file if necessary ;
+ sort file .
+
+reorganize file if necessary :
+ FILE VAR f := sequential file (modify, dateiname) ;
+ IF segments (f) > 1
+ THEN reorganize (dateiname)
+ FI .
+
+sort file :
+ f := sequential file (modify, dateiname) ;
+ INT CONST sortende := lines (f) + 3 ;
+ sortanker := 1 + 3 ;
+ datei := old (dateiname) ;
+ quicksort(sortanker, sortende) .
+
+END PROC sortiere;
+
+PROC quicksort ( INT CONST anfang, ende ) :
+ IF anfang < ende
+ THEN INT VAR p,q;
+ spalte (anfang, ende, p, q);
+ quicksort (anfang, q);
+ quicksort (p, ende) FI
+END PROC quicksort;
+
+PROC spalte (INT CONST anfang, ende, INT VAR p, q):
+ fange an der seite an und waehle den median;
+ ruecke p und q so dicht wie moeglich zusammen;
+ hole ggf median in die mitte .
+
+ fange an der seite an und waehle den median :
+ p := anfang; q := ende ;
+ INT CONST m :: (p + q) DIV 2 ;
+ median := subtext(datei m, sortierstelle) .
+
+ ruecke p und q so dicht wie moeglich zusammen :
+ REP schiebe p und q so weit wie moeglich auf bzw ab;
+ IF p < q THEN vertausche die beiden FI
+ UNTIL p > q END REP .
+
+ vertausche die beiden :
+ tausch := datei p; datei p := datei q; datei q := tausch;
+ p INCR 1; q DECR 1 .
+
+ schiebe p und q so weit wie moeglich auf bzw ab :
+ WHILE p kann groesser werden REP p INCR 1 END REP;
+ WHILE q kann kleiner werden REP q DECR 1 END REP .
+
+ p kann groesser werden :
+ IF p <= ende
+ THEN links := subtext (datei p, sortierstelle) ;
+ IF ascii sort
+ THEN median >= links
+ ELSE median LEXGREATEREQUAL links
+ FI
+ ELSE FALSE
+ FI .
+
+ q kann kleiner werden :
+ IF q >= anfang
+ THEN rechts := subtext(datei q, sortierstelle) ;
+ IF ascii sort
+ THEN rechts >= median
+ ELSE rechts LEXGREATEREQUAL median
+ FI
+ ELSE FALSE
+ FI .
+
+ hole ggf median in die mitte :
+ IF m < q THEN vertausche m und q
+ ELIF m > p THEN vertausche m und p FI .
+
+ vertausche m und q :
+ tausch := datei m; datei m := datei q; datei q := tausch; q DECR 1 .
+
+ vertausche m und p :
+ tausch := datei m; datei m := datei p; datei p := tausch; p INCR 1 .
+
+ datei m : datei.atoms (m).line .
+ datei p : datei.atoms (p).line .
+ datei q : datei.atoms (q).line .
+
+END PROC spalte;
+
+END PACKET file handling;
+
diff --git a/system/base/1.7.5/src/functions b/system/base/1.7.5/src/functions
new file mode 100644
index 0000000..9f338ff
--- /dev/null
+++ b/system/base/1.7.5/src/functions
@@ -0,0 +1,760 @@
+PACKET editor functions DEFINES (* FUNCTIONS - 052 *)
+ (**************) (* 17.07.85 -bk- *)
+ (* 10.09.85 -ws- *)
+ edit, (* 25.04.86 -sh- *)
+ show, (* 27.05.86 -wk- *)
+ U,
+ D,
+ T,
+ up,
+ down,
+ downety,
+ uppety,
+ to line,
+ PUT,
+ GET,
+ P,
+ G,
+ limit,
+ len,
+ eof,
+ C,
+ change to,
+ CA,
+ change all,
+ lines,
+ line no,
+ col,
+ mark,
+ at,
+ word,
+ std kommando interpreter,
+ note,
+ note line,
+ note edit,
+ anything noted,
+ note file:
+
+
+LET marker = "^",
+ ersatzmarker = "'",
+ schritt = 50,
+ file size = 4072,
+ write acc = TRUE,
+ read acc = FALSE;
+
+LET bold = 2,
+ integer = 3,
+ string = 4,
+ end of file = 7;
+
+LET std res = "eqvw19dpgn"9"";
+
+FILE VAR edfile;
+BOOL VAR from scratchfile :: FALSE;
+TEXT VAR kommandotext, tabulator, zeile;
+
+
+PROC std kommando interpreter (TEXT CONST taste) :
+ enable stop ;
+ edfile := editfile;
+ set busy indicator;
+ SELECT pos (std res, taste) OF
+ CASE 1 (*e*) : edit
+ CASE 2 (*q*) : quit
+ CASE 3 (*v*) : quit last
+ CASE 4 (*w*) : open editor (next editor)
+ CASE 5 (*1*) : toline (1); col (1)
+ CASE 6 (*9*) : toline (lines); col (len+1)
+ CASE 7 (*d*) : d case
+ CASE 8 (*p*) : p case
+ CASE 9 (*g*) : g case
+ CASE 10(*n*) : note edit
+ CASE 11(*tab*): change tabs
+ OTHERWISE : echtes kommando analysieren
+ END SELECT .
+
+d case :
+ IF mark
+ THEN PUT ""; mark (FALSE); from scratchfile := TRUE
+ ELSE textzeile auf taste legen
+ FI .
+
+p case :
+ IF mark (*sh*)
+ THEN IF write permission
+ THEN PUT ""; push(""27""12""); from scratchfile := TRUE
+ ELSE out (""7"")
+ FI
+ ELSE textzeile auf taste legen
+ FI .
+
+g case :
+ IF write permission (*sh*)
+ THEN IF from scratchfile
+ THEN GET ""
+ ELSE IF is editget
+ THEN push (lernsequenz auf taste ("g")); nichts neu
+ FI
+ FI
+ ELSE out (""7"")
+ FI .
+
+textzeile auf taste legen :
+ read record (edfile, zeile);
+ zeile := subtext (zeile, col);
+ lernsequenz auf taste legen ("g", zeile);
+ from scratchfile := FALSE; zeile neu .
+
+next editor :
+ (aktueller editor MOD groesster editor) + 1 .
+
+change tabs :
+ get tabs (edfile, tabulator) ;
+ IF pos (tabulator, marker) <> 0
+ THEN change all (tabulator, marker, ersatzmarker)
+ ELSE change all (tabulator, ersatzmarker, marker)
+ FI ;
+ put tabs (edfile, tabulator) ;
+ ueberschrift neu .
+
+echtes kommando analysieren :
+ kommandotext := kommando auf taste (taste);
+ IF kommandotext = ""
+ THEN nichts neu; LEAVE std kommando interpreter
+ FI ;
+ scan (kommandotext);
+ TEXT VAR s1; INT VAR t1; next symbol (s1, t1);
+ TEXT VAR s2; INT VAR t2; next symbol (s2, t2);
+ IF t1 = integer AND t2 = end of file THEN toline (int (s1))
+ ELIF t1 = string AND t2 = end of file THEN down (s1)
+ ELIF perhaps simple up or down THEN
+ ELIF perhaps simple changeto THEN
+ ELSE do (kommandotext)
+ FI .
+
+perhaps simple up or down :
+ IF t1 = bold
+ THEN TEXT VAR s3; INT VAR t3; next symbol (s3, t3);
+ IF t3 <> end of file THEN FALSE
+ ELIF s1 = "U" THEN perhaps simple up
+ ELIF s1 = "D" THEN perhaps simple down
+ ELSE FALSE
+ FI
+ ELSE FALSE
+ FI .
+
+perhaps simple up :
+ IF t2 = string THEN up (s2); TRUE
+ ELIF t2 = integer THEN up (int (s2)); TRUE
+ ELSE FALSE
+ FI .
+
+perhaps simple down :
+ IF t2 = string THEN down (s2); TRUE
+ ELIF t2 = integer THEN down (int (s2)); TRUE
+ ELSE FALSE
+ FI .
+
+perhaps simple changeto :
+ IF t1 = string AND s2 = "C" AND t3 is string AND t4 is eof
+ THEN s1 C s3; TRUE
+ ELSE FALSE
+ FI .
+
+t3 is string :
+ next symbol (s3, t3);
+ t3 = string .
+
+t4 is eof :
+ TEXT VAR s4; INT VAR t4;
+ next symbol (s4, t4);
+ t4 = end of file .
+END PROC std kommando interpreter;
+
+
+PROC edit (FILE VAR f) :
+ enable stop;
+ IF aktueller editor > 0 (*wk*)
+ THEN ueberschrift neu
+ FI ;
+ open editor (f, write acc);
+ edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter)
+END PROC edit;
+
+
+PROC edit (FILE VAR f, INT CONST x, y, x size, y size) :
+ enable stop;
+ open editor (groesster editor + 1, f, write acc, x, y, x size, y size);
+ edit (groesster editor, std res, PROC(TEXT CONST) std kommando interpreter)
+END PROC edit;
+
+
+PROC edit (FILE VAR f, TEXT CONST res, PROC (TEXT CONST) kdo interpreter) :
+ enable stop;
+ open editor (f, write acc);
+ edit (groesster editor, res, PROC(TEXT CONST) kdo interpreter)
+END PROC edit;
+
+
+PROC edit :
+ IF aktueller editor > 0
+ THEN dateiname einlesen;
+ edit (dateiname)
+ ELSE edit (last param)
+ FI .
+
+dateiname einlesen :
+ INT VAR x, y; get editcursor (x, y);
+ IF x < x size - 17 (*sh*)
+ THEN cursor (x, y);
+ out (""15"Dateiname:"14"");
+ (x size-14-x) TIMESOUT " ";
+ (x size-14-x) TIMESOUT ""8"";
+ TEXT VAR dateiname := std;
+ editget (dateiname);
+ trailing blanks entfernen;
+ quotes entfernen
+ ELSE errorstop ("Fenster zu klein")
+ FI .
+
+trailing blanks entfernen:
+ INT VAR i := LENGTH dateiname;
+ WHILE (dateiname SUB i) = " " REP i DECR 1 PER;
+ dateiname := subtext (dateiname, 1, i) .
+
+quotes entfernen :
+ IF (dateiname SUB 1) = """" AND (dateiname SUB LENGTH dateiname) = """"
+ THEN dateiname := subtext (dateiname, 2, LENGTH dateiname - 1)
+ FI .
+END PROC edit;
+
+
+PROC edit (TEXT CONST filename) :
+ IF filename <> ""
+ THEN edit named file
+ ELSE errorstop ("Name ungueltig")
+ FI .
+
+edit named file :
+ last param (filename);
+ IF exists (filename) COR yes ("""" + filename + """ neu einrichten")
+ THEN IF aktueller editor > 0 THEN ueberschrift neu FI; (*sh*)
+ FILE VAR f := sequential file (modify, filename);
+ headline (f, filename); edit (f); last param (filename)
+ ELSE errorstop ("")
+ FI .
+END PROC edit;
+
+
+PROC edit (TEXT CONST filename, INT CONST x, y, x size, y size) :
+ last param (filename);
+ IF exists (filename) COR yes ("""" + filename + """ neu einrichten")
+ THEN FILE VAR f := sequential file (modify, filename);
+ headline (f, filename); edit (f, x, y, x size, y size);
+ last param (filename)
+ ELSE errorstop ("")
+ FI
+END PROC edit;
+
+
+PROC edit (INT CONST i) :
+ edit (i, std res, PROC (TEXT CONST) std kommando interpreter)
+END PROC edit;
+
+
+PROC show (FILE VAR f) :
+ enable stop;
+ open editor (f, read acc);
+ edit(groesster editor, std res, PROC(TEXT CONST) std kommando interpreter);
+END PROC show;
+
+
+PROC show (TEXT CONST filename) : (*sh*)
+ last param (filename);
+ IF exists (filename)
+ THEN FILE VAR f := sequential file (modify, filename);
+ show (f); last param (filename)
+ ELSE errorstop ("""" + filename + """ gibt es nicht")
+ FI
+END PROC show;
+
+
+PROC show :
+ show (last param)
+END PROC show;
+
+
+DATASPACE VAR local space;
+INT VAR zeilenoffset;
+TEXT VAR kopierzeile;
+
+
+OP PUT (TEXT CONST filename) :
+ nichts neu;
+ IF mark
+ THEN markierten bereich in datei schreiben
+ FI .
+
+markierten bereich in datei schreiben :
+ disable stop;
+ zieldatei vorbereiten;
+ quelldatei oeffnen;
+ IF noch genuegend platz in der zieldatei (*sh*)
+ THEN zeilenweise kopieren
+ ELSE errorstop ("FILE-Ueberlauf")
+ FI ;
+ quelldatei schliessen;
+ zieldatei schliessen;
+ set busy indicator .
+
+zieldatei vorbereiten :
+ FRANGE VAR ganze zieldatei;
+ IF exists (filename) THEN forget (filename); ueberschrift neu FI;
+ FILE VAR destination;
+ IF filename = ""
+ THEN forget (local space); local space := nilspace;
+ destination := sequential file (output, local space)
+ ELSE destination := sequential file (modify, filename) ;
+ INT CONST groesse der zieldatei := lines (destination); (*sh*)
+ set marked range (destination, ganze zieldatei) ;
+ output (destination)
+ FI .
+
+quelldatei oeffnen :
+ zeilenoffset := mark line no (edfile) - 1;
+ INT CONST old line := line no, old col := col;
+ FRANGE VAR ganze datei;
+ set range (edfile, mark lineno (edfile), mark col (edfile), ganze datei);
+ input (edfile) .
+
+noch genuegend platz in der zieldatei :
+ lines + groesse der zieldatei < file size .
+
+zeilenweise kopieren :
+ enable stop;
+ satznr neu;
+ INT VAR zeile;
+ FOR zeile FROM 1 UPTO lines (edfile) REP
+ getline (edfile, kopierzeile);
+ putline (destination, kopierzeile);
+ satznr zeigen
+ PER .
+
+quelldatei schliessen :
+ modify (edfile);
+ set range (edfile, ganze datei);
+ to line (old line);
+ col (old col) .
+
+zieldatei schliessen :
+ IF filename <> ""
+ THEN INT CONST last line written := line no (destination) ;
+ modify (destination) ;
+ to line (destination, last line written) ;
+ col (destination, len (destination) + 1) ;
+ bild neu (destination) ;
+ set range (destination, ganze zieldatei)
+ FI .
+END OP PUT;
+
+
+OP P (TEXT CONST filename) :
+ PUT filename
+END OP P ;
+
+
+OP GET (TEXT CONST filename) : (*sh*)
+ IF NOT write permission
+ THEN errorstop ("Schreibversuch auf 'show'-Datei")
+ FI ;
+ quelldatei oeffnen;
+ IF nicht mehr genuegend platz im editfile
+ THEN quelldatei schliessen; errorstop ("FILE-Ueberlauf")
+ FI ;
+ disable stop;
+ zieldatei oeffnen;
+ zeilenweise kopieren ;
+ zieldatei schliessen;
+ quelldatei schliessen;
+ set busy indicator .
+
+quelldatei oeffnen :
+ FILE VAR source;
+ FRANGE VAR ganze quelldatei;
+ IF filename = ""
+ THEN source := sequential file (input, local space)
+ ELSE IF NOT exists (filename)
+ THEN errorstop ("""" + filename + """ gibt es nicht")
+ FI ;
+ source := sequential file (modify, filename);
+ INT CONST old line := line no (source),
+ old col := col (source);
+ set marked range (source, ganze quelldatei);
+ input (source)
+ FI .
+
+nicht mehr genuegend platz im editfile :
+ lines (source) + lines >= file size .
+
+zeilenweise kopieren :
+ enable stop;
+ satznr neu;
+ INT VAR zeile;
+ FOR zeile FROM 1 UPTO lines (source) REP
+ getline (source, kopierzeile);
+ putline (edfile, kopierzeile);
+ satznr zeigen
+ PER .
+
+zieldatei oeffnen :
+ zeilenoffset := line no - 1;
+ leere datei in editfile einschachteln;
+ output (edfile) .
+
+leere datei in editfile einschachteln :
+ INT CONST range start col := col;
+ FRANGE VAR ganze datei;
+ set range (edfile, line no, col, ganze datei);
+ IF lines = 1 THEN delete record (edfile) FI .
+
+quelldatei schliessen :
+ IF filename <> ""
+ THEN modify (source);
+ set range (source, ganze quelldatei);
+ to line (source, old line);
+ col (source, old col)
+ FI .
+
+zieldatei schliessen :
+ modify (edfile);
+ to line (lines);
+ col (range start col);
+ set range (edfile, ganze datei);
+ abschnitt neu (zeilenoffset + 1, lines) .
+END OP GET;
+
+
+OP G (TEXT CONST filename) :
+ GET filename
+END OP G;
+
+
+INT PROC len :
+ len (edfile)
+END PROC len;
+
+
+PROC col (INT CONST stelle) :
+ nichts neu; col (edfile, stelle)
+END PROC col;
+
+
+INT PROC col :
+ col (edfile)
+END PROC col;
+
+
+PROC limit (INT CONST limit) :
+ nichts neu; max line length (edfile, limit)
+END PROC limit;
+
+
+INT PROC limit :
+ max line length (edfile)
+END PROC limit;
+
+
+INT PROC lines :
+ lines (edfile)
+END PROC lines;
+
+
+INT PROC line no :
+ line no (edfile)
+END PROC line no;
+
+
+PROC to line (INT CONST satz nr) :
+ satznr neu;
+ edfile := editfile;
+ IF satz nr > lines
+ THEN toline (edfile, lines); col (len + 1)
+ ELSE to line (edfile, satz nr)
+ FI
+END PROC to line;
+
+
+OP T (INT CONST satz nr) :
+ to line (satz nr)
+END OP T;
+
+
+PROC down (INT CONST anz) :
+ nichts neu; down (edfile, anz)
+END PROC down;
+
+
+OP D (INT CONST anz) :
+ down (anz)
+END OP D;
+
+
+PROC up (INT CONST anz) :
+ nichts neu; up (edfile, anz)
+END PROC up;
+
+
+OP U (INT CONST anz) :
+ up (anz)
+END OP U;
+
+
+PROC down (TEXT CONST muster) :
+ nichts neu;
+ REP
+ down (muster, schritt - line no MOD schritt);
+ IF pattern found
+ THEN LEAVE down
+ ELSE satznr zeigen
+ FI
+ UNTIL eof PER
+END PROC down;
+
+
+OP D (TEXT CONST muster) :
+ down (muster)
+END OP D;
+
+
+PROC down (TEXT CONST muster, INT CONST anz) :
+ nichts neu; down (edfile, muster, anz)
+END PROC down;
+
+
+PROC up (TEXT CONST muster) :
+ nichts neu;
+ REP
+ up (muster, (line no - 1) MOD schritt + 1);
+ IF pattern found
+ THEN LEAVE up
+ ELSE satznr zeigen
+ FI
+ UNTIL line no = 1 PER
+END PROC up;
+
+
+OP U (TEXT CONST muster) :
+ up (muster)
+END OP U;
+
+
+PROC up (TEXT CONST muster, INT CONST anz) :
+ nichts neu; up (edfile, muster, anz)
+END PROC up;
+
+
+PROC downety (TEXT CONST muster) :
+ nichts neu;
+ IF NOT at (muster)
+ THEN down (muster)
+ FI
+END PROC downety;
+
+
+PROC downety (TEXT CONST muster, INT CONST anz) :
+ nichts neu; downety (edfile, muster, anz)
+END PROC downety;
+
+
+PROC uppety (TEXT CONST muster) :
+ nichts neu;
+ IF NOT at (muster)
+ THEN up (muster)
+ FI
+END PROC uppety;
+
+
+PROC uppety (TEXT CONST muster, INT CONST anz) :
+ nichts neu; uppety (edfile, muster, anz)
+END PROC uppety;
+
+
+OP C (TEXT CONST old, new) :
+ change to (old, new)
+END OP C;
+
+OP C (TEXT CONST replacement) :
+ IF NOT write permission (*sh*)
+ THEN errorstop ("Schreibversuch auf 'show'-Datei")
+ FI ;
+ IF at (edfile, match(0))
+ THEN zeile neu; change (edfile, matchpos(0), matchend(0), replacement)
+ FI
+END OP C;
+
+PROC change to (TEXT CONST old, new) :
+ IF NOT write permission (*sh*)
+ THEN errorstop ("Schreibversuch auf 'show'-Datei")
+ FI ;
+ nichts neu;
+ REP
+ downety (old, schritt - line no MOD schritt);
+ IF pattern found
+ THEN change (edfile, matchpos(0), matchend(0), new);
+ col (col + LENGTH new); zeile neu;
+ LEAVE changeto
+ ELSE satznr zeigen
+ FI
+ UNTIL eof PER
+END PROC change to;
+
+
+OP CA (TEXT CONST old, new) :
+ change all (old, new)
+END OP CA;
+
+
+PROC change all (TEXT CONST old, new) :
+ WHILE NOT eof REP old C new PER
+END PROC change all;
+
+
+BOOL PROC eof :
+ eof (edfile)
+END PROC eof;
+
+
+BOOL PROC mark :
+ mark (edfile)
+END PROC mark;
+
+
+PROC mark (BOOL CONST mark on) :
+ nichts neu;
+ IF mark on
+ THEN mark (edfile, line no, col)
+ ELSE mark (edfile, 0, 0)
+ FI
+END PROC mark;
+
+
+BOOL PROC at (TEXT CONST pattern) :
+ at (edfile, pattern)
+END PROC at;
+
+TEXT PROC word :
+ word (edfile)
+END PROC word;
+
+
+TEXT PROC word (TEXT CONST sep) :
+ word (edfile, sep)
+END PROC word;
+
+
+TEXT PROC word (INT CONST len) :
+ word (edfile, len)
+END PROC word;
+
+
+LET no access = 0,
+ edit access = 1,
+ output access = 2;
+
+INT VAR last note file mode;
+FILE VAR notebook;
+INITFLAG VAR this packet := FALSE;
+DATASPACE VAR note ds;
+
+
+PROC note (TEXT CONST text) :
+ access note file (output access);
+ write (notebook, text)
+END PROC note;
+
+
+PROC note (INT CONST number) :
+ access note file (output access);
+ put (notebook, number)
+END PROC note;
+
+
+PROC note line :
+ access note file (output access);
+ line (notebook)
+END PROC note line;
+
+
+BOOL PROC anything noted :
+ access note file (no access);
+ last note file mode = output access
+END PROC anything noted;
+
+
+FILE PROC note file :
+ access note file (output access);
+ notebook
+END PROC note file;
+
+
+PROC note edit (FILE VAR context) : (*sh*)
+ access note file (edit access);
+ make notebook erasable;
+ IF aktueller editor = 0
+ THEN open editor (1, context, write acc, 1, 1, x size - 1, y size)
+ FI ;
+ get window size;
+ IF window large enough
+ THEN include note editor;
+ edit (aktueller editor-1, aktueller editor, aktueller editor-1,
+ std res, PROC (TEXT CONST) std kommando interpreter)
+ FI .
+
+get window size :
+ INT VAR x, y, windows x size, windows y size;
+ get window (x, y, windows x size, windows y size) .
+
+window large enough :
+ windows y size > 4 .
+
+include note editor :
+ open editor (aktueller editor + 1, notebook, write acc,
+ x, y + (windows y size + 1) DIV 2,
+ windows x size, windows y size DIV 2) .
+
+make notebook erasable :
+ last note file mode := edit access .
+END PROC note edit;
+
+
+PROC note edit :
+ access note file (edit access);
+ make notebook erasable;
+ edit (notebook) .
+
+make notebook erasable :
+ last note file mode := edit access .
+END PROC note edit;
+
+
+PROC access note file (INT CONST new mode) :
+ disable stop;
+ initialize note ds if necessary;
+ IF last note file mode < new mode
+ THEN forget (note ds);
+ note ds := nilspace;
+ notebook := sequential file (output, note ds);
+ headline (notebook, "notebook");
+ last note file mode := new mode
+ FI .
+
+initialize note ds if necessary :
+ IF NOT initialized (this packet)
+ THEN note ds := nilspace;
+ last note file mode := no access
+ FI .
+END PROC access note file;
+
+END PACKET editor functions;
+
diff --git a/system/base/1.7.5/src/init b/system/base/1.7.5/src/init
new file mode 100644
index 0000000..471a717
--- /dev/null
+++ b/system/base/1.7.5/src/init
@@ -0,0 +1,251 @@
+ "run again impossible"
+ "recursive run"
+ " "
+ " Compiler Error : "
+" "
+" |"
+" Fehler entdeckt "
+"Keine Fehler gefunden, "
+" "
+" ******* ENDE DER UEBERSETZUNG *******"
+"FEHLER bei >> "
+" << "
+"weiter bei "
+"TEXTende (Anfuehrungszeichen) fehlt irgendwo"
+"Kommentarende fehlt irgendwo"
+"nach dem Hauptprogramm darf kein Paket folgen"
+"ungueltiger Name fuer ein DEFINES-Objekt"
+"':' fehlt"
+"nach ENDPACKET folgt nicht der Paketname"
+"ENDPACKET fehlt"
+"CONST oder VAR fehlt"
+"ungueltiger Name"
+" ',' in Deklarationsliste fehlt"
+"ist nicht der PROC Name"
+"fehlerhaftes Ende des Hauptprogramms"
+"ENDPROC fehlt"
+"PROC/OP Schachtelung unzulaessig"
+"OP darf kein Parameter sein"
+"steht mehrfach im PACKET Interface"
+" ist mehrfach deklariert"
+"ist schon als Datenobjekt deklariert"
+"ist schon als PROC/OP deklariert"
+"')' nach Parameterliste erwartet"
+"Standard-Schluesselwort kann nicht redefiniert werden"
+"ungueltig als BOLD"
+"'(' fehlt"
+"CONST bzw VAR nicht bei Strukturfeldern"
+"'=' fehlt"
+"Schluesselwort wird im Paket schon andersartig verwandt"
+"Datentyp fehlt"
+"ungueltiger OP Name"
+"OP muss monadisch oder dyadisch sein"
+"ist nicht der OP Name"
+"ENDOP fehlt"
+"Name nach ENDPROC fehlt"
+"Name nach ENDOP fehlt"
+"';' fehlt"
+"END END ist Unsinn"
+"Dieses END... kenne ich nicht"
+"ROW Groesse ist kein INT"
+"ROW Groesse ist kein Denoter"
+"Ein ROW muss mindestens ein Element haben"
+"ROW Groesse fehlt"
+"Parameter kann man nicht initialisieren"
+"Konstanten muessen initialisiert werden"
+"'::' verwenden"
+"')' fehlt"
+"Exponent fehlt"
+"Undefinierter Typ"
+"Rekursiv definierter Typ"
+"Mehrfach definierter Selektor"
+"Variable bzw. Abkuerzung in der Paket-Schnittstelle"
+"undefinierte ROW Groesse"
+"Typ Deklarationen nur im Paketrumpf"
+"CONST bzw. VAR ohne Zusammenhang"
+"ist nicht deklariert, steht aber in der Paket-Schnittstelle"
+"ist nicht deklariert"
+"unbekanntes Kommando"
+"THIS IS NO CORRECT EXTERNAL NUMBER."
+"Schluesselwort unzulaessig"
+"Name erwartet"
+"Denoter erwartet"
+"ENDPROC ohne Zusammenhang"
+"ENDOP ohne Zusammenhang"
+"Refinement ohne Zusammenhang"
+"Delimiter zwischen Paket-Refinement und Deklaration fehlt"
+"unzulaessiges Selektor-Symbol (kein Name)"
+"BOUND Schachtelungen unzulaessig"
+"BOUND-Objekte unzulaessig als Parameter"
+"Textende fehlt"
+"TEXT-Denoter zu lang"
+
+"Denoter-Wert wird fuer diese Maschine zu gross"
+"Compiler-Fehler, wenden Sie sich an Ihren Systemberater!"
+"ist ein zusammenhangloses Schluesselwort"
+"'::' nur fuer Initialisierungen, sonst ':='"
+"welches Objekt soll verlassen werden?"
+"du bist gar nicht innerhalb dieses Refinements"
+"nur die eigene PROC / OP kann verlassen werden"
+"THEN fehlt"
+"FI fehlt"
+"BOOL-Ausdruck erwartet"
+"ELSE-Teil ist notwendig, da ein Wert geliefert wird"
+"INT-Ausdruck erwartet"
+"OF fehlt"
+"Keine Typanpassung moeglich"
+"CASE-Label fehlt"
+"mindestens eine CASE-Anweisung geben"
+"CASE-Label ist zu gross (skipped)"
+"mehrfach definiertes CASE-Label"
+"ungueltiges Zeichen nach CASE-Label"
+"OTHERWISE-Teil fehlt"
+"END SELECT fehlt"
+"rekursiver Aufruf eines Refinements"
+" wird nicht benutzt"
+"';' oder Operator ('+','-',...) fehlt"
+"undefinierter monadischer Operator"
+"undefinierter dyadischer Operator"
+"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen"
+"fuer diesen Typ nicht definierter Selektor"
+"INT,REAL,BOOL,TEXT koennen nicht selektiert werden"
+"bei ROWs nur Subscription"
+"nicht selektierbar"
+"unzulaessiger Index fuer Subscription"
+"'[' ohne Zusammenhang"
+"']' ohne Zusammenhang"
+"']' nach Subscription fehlt"
+"ungueltig zwischen Anweisungen"
+"nur die letzte Anweisung eines Abschnitts darf einen Wert liefern"
+"Der Paketrumpf kann keinen Wert liefern"
+"anstelle des letzten Symbols wurde ein Operand erwartet"
+"Der Schleifenrumpf darf keinen Wert liefern"
+"die Laufvariable muss eine INT VAR sein"
+"wird schon in einer aeusseren Schleife als Laufvariable benutzt"
+"FROM erwartet"
+"UPTO bzw DOWNTO fehlt"
+"REPEAT fehlt"
+"END REP fehlt"
+"die Konstante darf nicht veraendert werden"
+"in einer FOR-Schleife darf die Laufvariable nicht veraendert werden"
+"falscher Typ des Resultats"
+"ist CONST, es wird aber ein VAR Parameter verlangt"
+"unbekannte Prozedur"
+"Parameter-Prozedur liefert falsches Resultat"
+"Anzahl bzw. Typen der Parameter sind falsch"
+"unbekannte Parameter-Prozedur"
+"aktuelle Parameter-Prozedur hat CONST-, formale hat VAR-Parameter"
+"Kein Konstruktor moeglich, da die Feinstruktur hier unbekannt ist"
+"zu wenig Felder angegeben"
+"zu viele Felder angegeben"
+"unzulaessiger Trenner zwischen Feldern"
+"Feld hat falschen Typ"
+"falsche Element-Anzahl im ROW-Konstruktor"
+"Dieser Typ kann nicht noch mehr konkretisiert werden"
+"BOUND-Objekt zu gross"
+
+"Warnung in Zeile "
+" Zeile "
+"in Zeile "
+" <----+---> "
+" TYPE undefiniert "
+" MODE undefiniert "
+"Parameter spezifiziert: "
+"Parameter Typ(en) sind: "
+" B Code, "
+" B Paketdaten generiert"
+"Operand: "
+"Operanden: "
+", "
+"erwartet "
+"gefunden "
+" "
+
+(* 001 *) END
+(* 002 *) ENDPACKET
+(* 003 *) ENDOP
+(* 004 *) ENDOPERATOR
+(* 005 *) ENDPROC
+(* 006 *) ENDPROCEDURE
+(* 007 *) PACKET
+(* 008 *) OP
+(* 009 *) OPERATOR
+(* 010 *) PROC
+(* 011 *) PROCEDURE
+(* 012 *) FI
+(* 013 *) ENDIF
+(* 014 *) ENDREP
+(* 015 *) ENDREPEAT
+(* 016 *) PER
+(* 017 *) ELIF
+(* 018 *) ELSE
+(* 019 *) UNTIL
+(* 020 *) CASE
+(* 021 *) OTHERWISE
+(* 022 *) ENDSELECT
+(* 023 *) INTERNAL
+(* 024 *) DEFINES
+(* 025 *) LET
+(* 026 *) TYPE
+(* 027 *) INT
+(* 028 *) REAL
+(* 029 *) DATASPACE
+(* 030 *) TEXT
+(* 031 *) BOOL
+(* 032 *) BOUND
+(* 033 *) ROW
+(* 034 *) STRUCT
+(* 035 *) CONST
+(* 036 *) VAR
+(* 037 INIT CONTROL *) INTERNAL
+(* 038 *) CONCR
+(* 039 *) REP
+(* 040 *) REPEAT
+(* 041 *) SELECT
+(* 042 *) EXTERNAL
+(* 043 *) IF
+(* 044 *) THEN
+(* 045 *) OF
+(* 046 *) FOR
+(* 047 *) FROM
+(* 048 *) UPTO
+(* 049 *) DOWNTO
+(* 050 *) WHILE
+(* 051 *) LEAVE
+(* 052 *) WITH
+(* 053 *) TRUE
+(* 054 *) FALSE
+(* 055 *) :: SBL := INCR DECR
+(* 056 *) + - * / DIV MOD
+ **
+ AND
+ CAND
+ OR
+ COR
+ NOT
+ = <> > >= < <=
+(*040 *) MAIN
+(*043*) ENDOFFILE
+
+PACKET a :
+
+PROC out (TEXT CONST t) :
+ EXTERNAL 60
+ENDPROC out ;
+
+PROC out text (TEXT CONST t, INT CONST typ) :
+ INTERNAL 257 ;
+ IF typ = typ
+ THEN out (t)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST typ) :
+ INTERNAL 258 ;
+ IF typ = typ
+ THEN out (""13""10"")
+ FI
+ENDPROC out line ;
+
+ENDPACKET a ;
+
diff --git a/system/base/1.7.5/src/integer b/system/base/1.7.5/src/integer
new file mode 100644
index 0000000..aefb77f
--- /dev/null
+++ b/system/base/1.7.5/src/integer
@@ -0,0 +1,265 @@
+(* ------------------- STAND : 23.10.85 --------------------*)
+PACKET integer DEFINES text, int, MOD,
+ sign, SIGN, abs, ABS, **, min, max, minint, maxint,
+ random, initialize random ,
+ last conversion ok, set conversion :
+
+INT PROC minint : -32767 - 1 ENDPROC minint ;
+
+INT PROC maxint : 32767 ENDPROC maxint ;
+
+
+TEXT PROC text (INT CONST number) :
+
+ IF number = minint THEN "-32768"
+ ELIF number < 0 THEN "-" + text(-number)
+ ELIF number <= 9 THEN code (number + 48)
+ ELSE text (number DIV 10) + digit
+ FI .
+
+digit :
+ code ( number MOD 10 + 48 ) .
+
+ENDPROC text ;
+
+TEXT PROC text (INT CONST number, length) :
+
+ TEXT VAR result := text (number) ;
+ INT CONST number length := LENGTH result ;
+ IF number length < length
+ THEN (length - number length) * " " + result
+ ELIF number length > length
+ THEN length * "*"
+ ELSE result
+ FI
+
+ENDPROC text ;
+
+INT PROC int (TEXT CONST number) :
+
+ skip blanks and sign ;
+ get value ;
+ result .
+
+skip blanks and sign :
+ BOOL VAR number is positive ;
+ INT VAR pos := 1 ;
+ skip blanks ;
+ IF (number SUB pos) = "-"
+ THEN number is positive := FALSE ;
+ pos INCR 1
+ ELIF (number SUB pos) = "+"
+ THEN number is positive := TRUE ;
+ pos INCR 1
+ ELSE number is positive := TRUE
+ FI .
+
+get value :
+ INT VAR value ;
+ get first digit ;
+ WHILE is digit REP
+ value := value * 10 + digit ;
+ pos INCR 1
+ PER ;
+ set conversion ok result .
+
+get first digit :
+ IF is digit
+ THEN value := digit ;
+ pos INCR 1
+ ELSE set conversion (FALSE) ;
+ LEAVE int WITH 0
+ FI .
+
+is digit : 0 <= digit AND digit <= 9 .
+
+digit : code (number SUB pos) - 48 .
+
+result :
+ IF number is positive
+ THEN value
+ ELSE - value
+ FI .
+
+set conversion ok result :
+ skip blanks ;
+ conversion ok := (pos > LENGTH number) .
+
+skip blanks :
+ WHILE (number SUB pos) = " " REP
+ pos INCR 1
+ PER .
+
+ENDPROC int ;
+
+INT OP MOD (INT CONST left, right) :
+
+ EXTERNAL 43
+
+ENDOP MOD ;
+
+INT PROC sign (INT CONST argument) :
+
+ IF argument < 0 THEN -1
+ ELIF argument > 0 THEN 1
+ ELSE 0
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (INT CONST argument) :
+ sign (argument)
+ENDOP SIGN ;
+
+INT PROC abs (INT CONST argument) :
+
+ IF argument > 0 THEN argument
+ ELSE - argument
+ FI
+
+ENDPROC abs ;
+
+INT OP ABS (INT CONST argument) :
+ abs (argument)
+ENDOP ABS ;
+
+INT OP ** (INT CONST arg, exp) :
+
+ INT VAR x := arg , z := 1 ,
+ counter := exp ;
+
+ IF exp = 0
+ THEN LEAVE ** WITH 1
+ ELIF exp < 0
+ THEN LEAVE ** WITH 1 DIV arg
+ FI ;
+
+ WHILE counter >= 2 REP
+ calculate new x and z ;
+ counter := counter DIV 2 ;
+ ENDREP ;
+ z * x .
+
+calculate new x and z :
+ IF counter is not even
+ THEN z := z * x
+ FI ;
+ x := x * x .
+
+counter is not even :
+ counter MOD 2 = 1 .
+
+ENDOP ** ;
+
+INT PROC min (INT CONST first, second) :
+
+ IF first < second THEN first ELSE second FI
+
+ENDPROC min ;
+
+INT PROC max (INT CONST first, second) :
+
+ IF first > second THEN first ELSE second FI
+
+ENDPROC max ;
+
+
+
+BOOL VAR conversion ok := TRUE ;
+
+BOOL PROC last conversion ok :
+ conversion ok
+ENDPROC last conversion ok ;
+
+PROC set conversion (BOOL CONST success) :
+ conversion ok := success
+ENDPROC set conversion ;
+
+
+
+(*******************************************************************)
+(* *)
+(* Autor: A. Flammenkamp *)
+(* RANDOM GENERATOR *)
+(* *)
+(* x := 4095 * x MOD (4095*4096+4093) *)
+(* n+1 n *)
+(* *)
+(* Periode: 2**24-4 > 16.0e6 *)
+(* *)
+(* Beachte: x = 4096 * x1 + x0, 0 <= x0,x1 < 4096 *)
+(* *)
+(*******************************************************************)
+
+
+INT VAR high := 1, low := 0 ;
+
+PROC initialize random (INT CONST start) :
+
+ low := start MOD 4096 ;
+ IF start < 0
+ THEN high := 256 + 16 + start DIV 4096 ;
+ IF low <> 0 THEN high DECR 1 FI
+ ELSE high := 256 + start DIV 4096
+ FI
+
+ENDPROC initialize random ;
+
+INT PROC random (INT CONST lower bound, upper bound) :
+
+ compute new random value ;
+ normalize high ;
+ normalize low ;
+ map into interval .
+
+compute new random value :
+ (* (high,low) := (low-high , 3*high-low) *)
+ high := low - high ;
+ low INCR low - 3 * high .
+
+normalize high :
+ IF high < 0
+ THEN high INCR 4096 ; low DECR 3
+ FI .
+
+normalize low :
+ (* high INCR low DIV 4096 ;
+ low := low MOD 4096
+ *)
+ IF low >= 4096 THEN low overflow
+ ELIF low < 0 THEN low underflow
+ FI .
+
+low overflow :
+ IF low >= 8192
+ THEN low DECR 8192 ; high INCR 2
+ ELSE low DECR 4096 ; high INCR 1 ; post normalization
+ FI .
+
+post normalization :
+ (* IF (high,low) >= (4095,4093)
+ THEN (high,low) DECR (4095,4093)
+ FI
+ *)
+ IF high >= 4095
+ THEN IF low >= 4093 THEN high DECR 4095 ; low DECR 4093
+ ELIF high = 4096 THEN high := 0 ; low INCR 3
+ FI
+ FI .
+
+low underflow :
+ low INCR 4096 ; high DECR 1 .
+
+map into interval :
+ INT VAR number := high MOD 16 - 8 ;
+ number INCR 4095 * number + low ;
+ IF lower bound <= upper bound
+ THEN lower bound + number MOD (upper bound - lower bound + 1)
+ ELSE upper bound + number MOD (lower bound - upper bound + 1)
+ FI .
+
+ENDPROC random ;
+
+
+ENDPACKET integer ;
+
diff --git a/system/base/1.7.5/src/local manager b/system/base/1.7.5/src/local manager
new file mode 100644
index 0000000..48d024b
--- /dev/null
+++ b/system/base/1.7.5/src/local manager
@@ -0,0 +1,373 @@
+(* ------------------- VERSION 2 24.02.86 ------------------- *)
+PACKET local manager (* Autor: J.Liedtke *)
+
+ DEFINES
+ create, (* neue lokale Datei einrichten *)
+ new, (* 'create' und Datei liefern *)
+ old, (* bestehende Datei liefern *)
+ forget, (* lokale Datei loeschen *)
+ exists, (* existiert Datei (lokal) ? *)
+ status, (* setzt und liefert Status *)
+ rename, (* Umbenennung *)
+ copy , (* Datenraum in Datei kopieren *)
+ enter password,(* Passwort einfuehren *)
+ write password ,
+ read password ,
+ write permission ,
+ read permission ,
+ begin list ,
+ get list entry ,
+ all :
+
+
+
+LET size = 200 ,
+ nil = 0 ;
+
+INT VAR index ;
+
+TEXT VAR system write password := "" ,
+ system read password := "" ,
+ actual password ;
+
+INITFLAG VAR this packet := FALSE ;
+
+DATASPACE VAR password space ;
+
+BOUND ROW size STRUCT (TEXT write, read) VAR passwords ;
+
+
+THESAURUS VAR dir := empty thesaurus ;
+
+ROW size STRUCT (DATASPACE ds,
+ BOOL protected,
+ TEXT status) VAR crowd ;
+
+
+PROC initialize if necessary :
+
+ IF NOT initialized (this packet)
+ THEN system write password := "" ;
+ system read password := "" ;
+ dir := empty thesaurus ;
+ password space := nilspace ;
+ passwords := password space
+ FI
+
+ENDPROC initialize if necessary ;
+
+
+
+PROC create (TEXT CONST name) :
+
+IF exists (name )
+ THEN error (name, "existiert bereits") ;
+ index := nil
+ ELSE insert and initialize entry
+FI .
+
+insert and initialize entry :
+ disable stop ;
+ insert (dir, name, index) ;
+ IF index <> nil
+ THEN crowd (index).ds := nilspace ;
+ IF is error
+ THEN delete (dir, name, index) ;
+ LEAVE create
+ FI ;
+ status (name, "") ;
+ crowd (index).protected := FALSE
+ ELIF NOT is error
+ THEN errorstop ("zu viele Dateien")
+ FI .
+
+ENDPROC create ;
+
+DATASPACE PROC new (TEXT CONST name) :
+
+ create (name) ;
+ IF index <> nil
+ THEN crowd (index).ds
+ ELSE nilspace
+ FI
+
+ENDPROC new ;
+
+DATASPACE PROC old (TEXT CONST name) :
+
+ initialize if necessary ;
+ index := link (dir, name) ;
+ IF index = 0
+ THEN error (name, "gibt es nicht") ;
+ nilspace
+ ELSE space
+ FI .
+
+space : crowd (index).ds .
+
+ENDPROC old ;
+
+DATASPACE PROC old (TEXT CONST name, INT CONST expected type) :
+
+ initialize if necessary ;
+ index := link (dir, name) ;
+ IF index = 0
+ THEN error (name, "gibt es nicht") ;
+ nilspace
+ ELIF type (space) <> expected type
+ THEN errorstop ("Datenraum hat falschen Typ") ;
+ nilspace
+ ELSE space
+ FI .
+
+space : crowd (index).ds .
+
+ENDPROC old ;
+
+BOOL PROC exists (TEXT CONST name) :
+
+ initialize if necessary ;
+ dir CONTAINS name
+
+ENDPROC exists ;
+
+PROC forget (TEXT CONST name ) :
+
+ initialize if necessary ;
+ say ("""") ;
+ say (name) ;
+ IF NOT exists (name) THEN say (""" existiert nicht")
+ ELIF yes (""" loeschen") THEN forget (name, quiet)
+ FI .
+
+ENDPROC forget ;
+
+PROC forget (TEXT CONST name, QUIET CONST q) :
+
+ initialize if necessary ;
+ disable stop ;
+ delete (dir, name, index) ;
+ IF index <> nil
+ THEN forget ( crowd (index).ds ) ;
+ crowd (index).status := ""
+ FI .
+
+ENDPROC forget ;
+
+PROC forget :
+
+ BOOL VAR status := command dialogue ;
+ command dialogue (TRUE) ;
+ forget (last param) ;
+ command dialogue (status)
+
+ENDPROC forget ;
+
+PROC status (TEXT CONST name, status text) :
+
+ initialize if necessary ;
+ INT VAR index := link (dir, name) ;
+ IF index > 0
+ THEN crowd (index).status := date + " " + text (status text, 4)
+ FI
+
+ENDPROC status ;
+
+TEXT PROC status (TEXT CONST name) :
+
+ initialize if necessary ;
+ INT VAR index := link (dir, name) ;
+ IF index > 0
+ THEN crowd (index).status
+ ELSE ""
+ FI
+
+ENDPROC status ;
+
+PROC status (INT CONST pos, TEXT CONST status pattern) :
+
+ initialize if necessary ;
+ INT VAR index := 0 ;
+ WHILE index < highest entry (dir) REP
+ index INCR 1 ;
+ replace (actual status, pos , status pattern)
+ PER .
+
+actual status : crowd (index).status .
+
+ENDPROC status ;
+
+PROC copy (DATASPACE CONST source, TEXT CONST dest name) :
+
+ IF exists (dest name)
+ THEN error (dest name, "existiert bereits")
+ ELSE copy file
+ FI .
+
+copy file :
+ disable stop ;
+ create ( dest name ) ;
+ INT VAR index := link (dir, dest name) ;
+ IF index > nil
+ THEN forget (crowd (index).ds) ;
+ crowd (index).ds := source
+ FI
+
+ENDPROC copy ;
+
+PROC copy (TEXT CONST source name, dest name) :
+
+ copy (old (source name), dest name)
+
+ENDPROC copy ;
+
+PROC rename (TEXT CONST old name, new name) :
+
+ IF exists (new name)
+ THEN error (new name, "existiert bereits")
+ ELIF exists (old name)
+ THEN rename (dir, old name, new name) ;
+ last param (new name)
+ ELSE error (old name, "gibt es nicht")
+ FI .
+
+ENDPROC rename ;
+
+
+PROC begin list :
+
+ initialize if necessary ;
+ index := 0
+
+ENDPROC begin list ;
+
+PROC get list entry (TEXT VAR entry, status text) :
+
+ get (dir, entry, index) ;
+ IF found
+ THEN status text := crowd (index).status ;
+ ELSE status text := "" ;
+ FI .
+
+found : index > 0 .
+
+ENDPROC get list entry ;
+
+
+TEXT PROC write password :
+
+ system write password
+
+ENDPROC write password ;
+
+TEXT PROC read password :
+
+ system read password
+
+ENDPROC read password ;
+
+
+PROC enter password (TEXT CONST password) :
+
+ initialize if necessary ;
+ say (""3""5"") ;
+ INT CONST slash pos := pos (password, "/") ;
+ IF slash pos = 0
+ THEN system write password := password ;
+ system read password := password
+ ELSE system write password := subtext (password, 1, slash pos-1) ;
+ system read password := subtext (password, slash pos+1)
+ FI .
+
+ENDPROC enter password ;
+
+PROC enter password (TEXT CONST file name, write pass, read pass) :
+
+ INT CONST index := link (dir, file name) ;
+ IF index > 0
+ THEN set protect password
+ FI .
+
+set protect password :
+ IF write pass = "" AND read pass = ""
+ THEN crowd (index).protected := FALSE
+ ELSE crowd (index).protected := TRUE ;
+ passwords (index).write := write pass ;
+ passwords (index).read := read pass
+ FI .
+
+ENDPROC enter password ;
+
+INT PROC password index (TEXT CONST file name) :
+
+ initialize if necessary ;
+ INT CONST index := link (dir, file name) ;
+ IF index > 0 CAND crowd (index).protected
+ THEN index
+ ELSE 0
+ FI
+
+ENDPROC password index ;
+
+BOOL PROC read permission (TEXT CONST name, supply password) :
+
+ (****************************************************************)
+ (* for reasons of data security the password check algorithm *)
+ (* must not copy parts of the file password into variables *)
+ (* located in the standard dataspace! *)
+ (****************************************************************)
+
+ access file password ;
+ file has no password COR (supply password <> "-" AND read password match) .
+
+read password match :
+ file password.read = supply password OR file password.read = "" .
+
+access file password :
+ INT CONST pw index := password index (name) .
+
+file password : passwords (pw index) .
+
+file has no password : pw index = 0 .
+
+ENDPROC read permission ;
+
+BOOL PROC write permission (TEXT CONST name, supply password) :
+
+ (****************************************************************)
+ (* for reasons of data security the password check algorithm *)
+ (* must not copy parts of the file password into variables *)
+ (* located in the standard dataspace! *)
+ (****************************************************************)
+
+ access file password ;
+ file has no password COR (supply password <> "-" AND write password match).
+
+write password match :
+ file password.write = supply password OR file password.write = "" .
+
+access file password :
+ INT CONST pw index := password index (name) .
+
+file password : passwords (pw index) .
+
+file has no password : pw index = 0 .
+
+ENDPROC write permission ;
+
+THESAURUS PROC all :
+
+ initialize if necessary ;
+ THESAURUS VAR result := dir ; (*ueberfluessig ab naechstem Compiler *)
+ result
+
+ENDPROC all ;
+
+PROC error (TEXT CONST file name, error text) :
+
+ errorstop ("""" + file name + """ " + error text)
+
+ENDPROC error ;
+
+ENDPACKET local manager ;
+
diff --git a/system/base/1.7.5/src/local manager 2 b/system/base/1.7.5/src/local manager 2
new file mode 100644
index 0000000..8f70301
--- /dev/null
+++ b/system/base/1.7.5/src/local manager 2
@@ -0,0 +1,41 @@
+
+PACKET local manager part 2 DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 25.02.85 *)
+ list :
+
+
+TEXT VAR file name, status text;
+
+
+PROC list :
+
+ disable stop ;
+ DATASPACE VAR ds := nilspace ;
+ FILE VAR list file := sequential file (output, ds) ;
+ headline (list file, "list") ;
+ list (list file) ;
+ show (list file) ;
+ forget (ds) .
+
+ENDPROC list ;
+
+PROC list (FILE VAR f) :
+
+ enable stop ;
+ begin list ;
+ putline (f, "") ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE list
+ FI ;
+ write (f, status text + " """ ) ;
+ write (f, file name) ;
+ write (f, """") ;
+ line (f)
+ PER .
+
+ENDPROC list ;
+
+ENDPACKET local manager part 2 ;
+
diff --git a/system/base/1.7.5/src/mathlib b/system/base/1.7.5/src/mathlib
new file mode 100644
index 0000000..c726495
--- /dev/null
+++ b/system/base/1.7.5/src/mathlib
@@ -0,0 +1,268 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PACKET mathlib DEFINES sqrt, **, exp, ln, log2, log10, e, pi,
+ sin, cos, tan, sind, cosd, tand,
+ arctan, arctand, random, initializerandom :
+
+LET pii = 3.141592653589793238462,
+ pi2 = 1.570796326794896619231,
+ pi3 = 1.047197551196597746154,
+ pi6 = 0.523598775598298873077,
+ pi4 = 1.273239544735162686151,
+ ln2 = 0.693147180559945309417,
+ lg2 = 0.301029995663981195213,
+ ln10 = 2.302585092994045684018,
+ lge = 0.434294481903251827651,
+ ei = 2.718281828459045235360,
+ pi180 = 57.295779513082320876798,
+ sqrt3 = 1.732050807568877293527,
+ sqr3 = 0.577350269189625764509,
+ sqr3p2= 3.732050807568877293527,
+ sqr3m2= 0.267949192431122706473,
+ sqr2 = 0.707106781186547524400;
+
+REAL VAR rdg::0.4711;
+
+REAL PROC pi: pii END PROC pi;
+REAL PROC e : ei END PROC e;
+
+REAL PROC ln ( REAL CONST x ):
+ log2(x) * ln2
+END PROC ln;
+
+REAL PROC log10( REAL CONST x ):
+ log2(x) * lg2
+END PROC log10;
+
+REAL PROC log2 ( REAL CONST z ):
+ REAL VAR t, summe::0.0, x::z;
+ IF x=1.0 THEN 0.0
+ ELIF x>0.0 THEN normal
+ ELSE errorstop("log2: " + text (x,20)); 0.0 FI.
+
+normal:
+ IF x >= 0.5 THEN normalise downwards
+ ELSE normalise upwards FI;
+ IF x < sqr2 THEN summe := summe - 0.75; t := trans8
+ ELSE summe := summe - 0.25; t := trans2 FI;
+ summe + reihenentwicklung.
+
+ normalise downwards:
+ WHILE x >= 8.0 REP x := 0.0625 * x; summe:=summe+4.0 PER;
+ WHILE x >= 1.0 REP x := 0.5 * x; summe:=summe+1.0 PER.
+
+ normalise upwards:
+ WHILE x<=0.0625 REP x := 16.0 * x; summe:=summe-4.0 PER;
+ WHILE x<= 0.5 REP x := 2.0 * x; summe:=summe-1.0 PER.
+
+ trans8: (x - 0.5946035575013605)/(x + 0.5946035575013605).
+ trans2: (x - 0.8408964152537145)/(x + 0.8408964152537145).
+
+ reihenentwicklung: x := t * t; t * 0.06405572387119384648 *
+ ((((((3.465*x+4.095)*x+5.005)*x+6.435)*x+9.009)*x+15.015)*x+45.045)
+END PROC log2;
+
+REAL PROC sqrt ( REAL CONST z ):
+ REAL VAR y0, y1, x::z;
+ INT VAR p :: decimal exponent(x) DIV 2;
+ IF p <= -64 THEN 0.0
+ ELIF x < 0.0 THEN errorstop("sqrt: " + text (x,20)); 0.0
+ ELSE nontrivial FI.
+
+ nontrivial:
+ set exp (decimal exponent (x) -p-p, x);
+ IF x<10.0 THEN x := 5.3176703 - 40.760905/( 8.408065 + x )
+ ELSE x := 16.81595 - 1288.973 /( 84.08065 + x ) FI;
+ y0 := x;
+ set exp (decimal exponent (x) + p, y0);
+ y1 := 0.5 * ( y0 + z/y0 );
+ y0 := 0.5 * ( y1 + z/y1 );
+ y1 := 0.5 * ( y0 + z/y0 );
+ 0.5 * ( y1 + z/y1 )
+END PROC sqrt;
+
+REAL PROC exp ( REAL CONST z ):
+ REAL VAR x::z, a::1.0; BOOL VAR negativ :: x<0.0;
+ IF negativ THEN x := -x FI;
+ IF x>292.42830676
+ THEN IF NOT negativ THEN errorstop ("REAL-Ueberlauf") FI ; 0.0
+ ELIF x<=0.0001
+ THEN ( 0.5*z + 1.0 ) * z + 1.0
+ ELSE approx
+ FI.
+
+ approx:
+ IF x > ln10
+ THEN x := lge*x;
+ a := 1.0;
+ set exp (int(x), a);
+ x := frac(x)*ln10
+ FI;
+ IF x >= 2.0 THEN a := 7.389056098930650227230*a; x := x-2.0 FI;
+ IF x >= 1.0 THEN a := 2.718281828459045235360*a; x := x-1.0 FI;
+ IF x >= 0.5 THEN a := 1.648721270700128146848*a; x := x-0.5 FI;
+ IF x >= 0.25 THEN a := 1.284025416687741484073*a; x := x-0.25 FI;
+ IF x >= 0.125 THEN a := 1.133148453066826316829*a; x := x-0.125 FI;
+ IF x >= 0.0625THEN a := 1.064494458917859429563*a; x := x-0.0625FI;
+ a:=a/50.4*(((((((0.01*x+0.07)*x+0.42)*x+2.1)*x+8.4)*x+25.2)*x+50.4)*x+50.4);
+ IF negativ THEN 1.0/a ELSE a FI .
+
+ENDPROC exp ;
+
+REAL PROC tan (REAL CONST x):
+ IF x < 0.0 THEN - tg( -x * pi4)
+ ELSE tg( x * pi4) FI
+END PROC tan;
+
+REAL PROC tand (REAL CONST x):
+ IF x < 0.0 THEN - tg( -x / 45.0)
+ ELSE tg( x / 45.0) FI
+END PROC tand;
+
+REAL PROC tg (REAL CONST x ):
+ REAL VAR q::floor(x), s::x-q; INT VAR n;
+ q := q - floor(0.25*q) * 4.0 ;
+ IF q < 2.0
+ THEN IF q < 1.0
+ THEN n:=0;
+ ELSE n:=1; s := 1.0 - s FI
+ ELSE IF q < 3.0
+ THEN n:=2;
+ ELSE n:=3; s := 1.0 - s FI
+ FI;
+ q := s * s;
+ q := (((((((((-5.116186989653120e-11*q-5.608325022830701e-10)*q-
+ 9.526170109403018e-9)*q-1.517906721393745e-7)*q-2.430939946375515e-6)*q-
+ 3.901461426385464e-5)*q-6.324811612385572e-4)*q-1.076606829172646e-2)*q-
+ 0.2617993877991508)*q+pi4);
+
+ SELECT n OF
+ CASE 0 : s/q
+ CASE 1 : q/s
+ CASE 2 : -q/s
+ OTHERWISE : -s/q ENDSELECT .
+
+END PROC tg;
+
+REAL PROC sin ( REAL CONST x ):
+ REAL VAR y, r, q;
+ IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI;
+ y := y * pi4;
+ r := floor(y);
+ sincos( q+r , y-r )
+END PROC sin;
+
+REAL PROC sind ( REAL CONST x ):
+ REAL VAR y, r, q;
+ IF x < 0.0 THEN y := -x; q := 4.0 ELSE y := x; q := 0.0 FI;
+ y := y / 45.0;
+ r := floor(y);
+ sincos( q+r , y-r )
+END PROC sind;
+
+REAL PROC cos ( REAL CONST x ):
+ REAL VAR y, q;
+ IF x < 0.0 THEN y := -x ELSE y := x FI;
+ y := y * pi4;
+ q := floor(y);
+ sincos( q+2.0, y-q )
+END PROC cos;
+
+REAL PROC cosd ( REAL CONST x ):
+ REAL VAR y, q;
+ IF x < 0.0 THEN y := -x ELSE y := x FI;
+ y := y / 45.0;
+ q := floor(y);
+ sincos( q+2.0, y-q )
+END PROC cosd;
+
+REAL PROC sincos ( REAL CONST q, y ):
+ REAL VAR r :: q - floor( 0.125*q + 0.1 ) * 8.0;
+ IF r >= 4.0 THEN IF r >= 6.0 THEN IF r >= 7.0 THEN - sin approx(1.0-y)
+ ELSE - cos approx(y) FI
+ ELSE IF r >= 5.0 THEN - cos approx(1.0-y)
+ ELSE - sin approx(y) FI FI
+ ELSE IF r >= 2.0 THEN IF r >= 3.0 THEN sin approx(1.0-y)
+ ELSE cos approx(y) FI
+ ELSE IF r >= 1.0 THEN cos approx(1.0-y)
+ ELSE sin approx(y) FI FI FI
+END PROC sincos;
+
+REAL PROC sin approx ( REAL CONST x ):
+ REAL VAR z::x*x;
+ x*((((((0.6877101540593035e-11*z-0.1757149296873372e-8)*z+0.3133616216672568
+ e-6)*z-0.3657620415845891e-4)*z+0.2490394570188737e-2)*z-0.807455121882e-1)*
+ z+0.7853981633974483)
+END PROC sin approx;
+
+REAL PROC cos approx ( REAL CONST x ):
+ REAL VAR z::x*x;
+ ((((((-0.3857761864560276e-12*z+0.115004970178141e-9)*z-0.246113638267419e-7
+ )*z+0.3590860445885748e-5)*z-0.3259918869266875e-3)*z+0.1585434424381541e-1)
+ *z-0.3084251375340425)*z+1.0
+END PROC cos approx;
+
+REAL PROC arctan ( REAL CONST y ):
+ REAL VAR f, z, x; BOOL VAR neg :: y < 0.0;
+ IF neg THEN x := -y ELSE x := y FI;
+ IF x>1.0 THEN f := a ELSE f := -b; neg := NOT neg FI;
+ z := x * x;
+ x := x/(((((((0.0107090276046822*z-0.01647757182108040)*z
+ +0.02177846332482151)*z-0.03019339673273880)*z+0.04656083561183398)*z
+ -0.0888888888888888)*z+0.3333333333333333)*z+1.0);
+ IF neg THEN x - f ELSE f - x FI.
+
+ a:IF x>sqr3p2 THEN x := 1.0/x; pi2 ELSE x := 4.0/(sqrt3+x+x+x)-sqr3; pi3 FI.
+ b:IF x<sqr3m2 THEN 0.0 ELSE x := sqrt3 - 4.0/(sqrt3+x); pi6 FI
+END PROC arctan;
+
+REAL PROC arctand ( REAL CONST x ):
+ arctan(x) * pi180
+END PROC arctand;
+
+REAL OP ** ( REAL CONST b, e ):
+ IF b=0.0
+ THEN IF e=0.0 THEN 1.0 ELSE 0.0 FI
+ ELIF b < 0.0
+ THEN errorstop("("+text(b,20)+") ** "+text(e)); (-b) ** e
+ ELSE exp( e * log2( b ) * ln2 )
+ FI
+END OP **;
+
+REAL OP ** ( REAL CONST a, INT CONST b ) :
+
+ REAL VAR p := 1.0 ,
+ r := a ;
+ INT VAR n := ABS b ,
+ m ;
+ IF (a = 0.0 OR a = -0.0)
+ THEN IF b = 0
+ THEN 1.0
+ ELSE 0.0
+ FI
+ ELSE WHILE n>0 REP
+ m := n DIV 2 ;
+ IF m + m = n
+ THEN n := m ;
+ r := r*r
+ ELSE n DECR 1 ;
+ p := p*r
+ FI
+ END REP ;
+ IF b>0
+ THEN p
+ ELSE 1.0 / p
+ FI
+ FI .
+
+END OP ** ;
+
+REAL PROC random:
+ rdg:=rdg+pii;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=frac(rdg);rdg
+END PROC random;
+
+PROC initializerandom ( REAL CONST z ):
+ rdg := frac(z)
+END PROC initializerandom;
+
+END PACKET mathlib;
+
diff --git a/system/base/1.7.5/src/pattern match b/system/base/1.7.5/src/pattern match
new file mode 100644
index 0000000..f6190d8
--- /dev/null
+++ b/system/base/1.7.5/src/pattern match
@@ -0,0 +1,768 @@
+PACKET pattern match DEFINES (* Author: P.Heyderhoff *)
+ (* Date: 09.06.1986 *)
+ -,
+ OR,
+ **,
+ any,
+ notion,
+ bound,
+ match,
+ matchpos,
+ matchend,
+ somefix,
+ UNLIKE,
+ LIKE :
+
+(*------- Operation codes of the internal intermeadiate language: --------*)
+
+LET
+ z = ""0"",
+ stopz = ""1""0"",
+ closez = ""2""0"",
+ closor = ""2""0""3""0"",
+ or = ""3"",
+ oralpha = ""3""5"",
+ open2 = ""4""0""4""0"",
+ alpha = ""5"",
+ alphaz = ""5""0"",
+ lenz = ""6""0"",
+ nilz = ""6""0""0""0""7""0"", (* = any (0) *)
+ starz = ""7""0"",
+ star = ""8""0""2""7""0""1""0"", (* = any ** 1 *)
+ powerz = ""8""0"",
+ powerz0 = ""8""0""1"",
+ notionz = ""9""0"",
+ fullz = ""10""0"",
+ boundz = ""11""0"";
+(*------------------------------------------------------------------------*)
+
+LET undefined = 0, (* fixleft value *)
+ forcer = 0, (* vaHue parameter *)
+ delimiter = " !""#$%&'()*+,-./:;<=>?§^_`­"; (* for 'PROC notion' *)
+
+TEXT OP - (TEXT CONST alphabet ):
+ p:= "";
+ INT VAR j;
+ FOR j FROM 0 UPTO 255
+ REP IF pos(alphabet,code(j)) = 0
+ THEN p CAT code(j)
+ FI
+ PER;
+ p
+ ENDOP -;
+
+TEXT OP OR (TEXT CONST a, b):
+ open2 + notnil (a) + closor + notnil (b) + closez
+ ENDOP OR;
+
+TEXT OP ** (TEXT CONST p, INT CONST x):
+ powerz + code (1+x) + notnil (p) + stopz
+ ENDOP **;
+
+TEXT CONST any:= starz;
+
+TEXT PROC any (INT CONST n):
+ TEXT VAR t:= " ";
+ replace (t, 1, ABSn);
+ lenz + t + starz
+ ENDPROC any;
+
+TEXT PROC any (TEXT CONST a): alphaz + a + starz ENDPROC any;
+
+TEXT PROC any (INT CONST n, TEXT CONST a):
+ TEXT VAR t:= " ";
+ replace (t, 1, ABSn);
+ lenz + t + alphaz + a + starz
+ ENDPROC any;
+
+TEXT PROC notion (TEXT CONST t): notionz + notnil(t) + stopz ENDPROC notion;
+
+TEXT PROC notnil (TEXT CONST t):
+ IF t = ""
+ THEN nilz
+ ELSE t
+ FI
+ ENDPROC notnil;
+
+TEXT CONST bound := boundz;
+
+TEXT PROC full (TEXT CONST t): fullz + t + stopz ENDPROC full;
+
+TEXT PROC match (INT CONST x):
+ subtext (p, matchpos(x), matchend(x))
+ ENDPROC match;
+
+INT PROC matchpos (INT CONST x): mapos (1 + x MOD 256) ENDPROC matchpos;
+
+INT PROC matchend (INT CONST x): maend (1 + x MOD 256) - 1
+ ENDPROC matchend;
+
+(*----------------- GLOBAL VARIABLES: -----------------------------------*)
+
+ROW 256 INT VAR
+ (* Table of match registers. Each entry consists of two *)
+ (* pointers, which points to the TEXT object 't' *)
+ mapos, (* points to the beginning of the match *)
+ maend; (* points to the position after the end of match *)
+
+INT VAR ppos, tpos, (* workpositions in pattern 'p' and text 't' *)
+ floatpos, (* accumulation of all pending floatlengths *)
+ failpos, (* result of 'PROC in alpha' *)
+ plen, tlen, (* length of pattern 'p' and length of text 't' *)
+ skipcount, (* for track forward skipping *)
+ multi, vari; (* for handling of nonexclusive alternatives *)
+
+TEXT VAR p, (* the pattern to be find or some result *)
+ stack, (* stack of pending assignments *)
+ alphabet:=""; (* result of 'PROC find alpha', reset to nil *)
+ (* after its usage by 'find any' *)
+
+BOOL VAR fix, (* text position is fixed and not floating *)
+ no vari; (* not variing the order of alternatives *)
+
+TEXT PROC somefix (TEXT CONST pattern):
+
+ (* delivers the first text occuring unconditionally in the pattern *)
+
+ p:= pattern;
+ INT VAR j:= 1, n:= 0, k, len:= LENGTH p;
+ REP
+ SELECT text( subtext (p, j, j+1), 2) ISUB 1 OF
+ CASE 1,3,7,9,10,11: j INCR 2
+ CASE 2: j INCR 2; n DECR 1 (* condition closed *)
+ CASE 4: j INCR 2; n INCR 1 (* condition opened *)
+ CASE 5: j := pos (p, starz, j+2) + 2
+ CASE 6: j INCR 4
+ CASE 8: j INCR 3
+ OTHERWISE k:= pos(p, z, j+1) - 1;
+ IF k <= 0 THEN k:= 1+len FI;
+ IF star found
+ THEN change (p, starpos, starpos, star);
+ len:= LENGTH p;
+ k:= starpos
+ FI;
+ IF n = 0 CAND ( p SUB k ) <> or CAND k > j
+ THEN LEAVE somefix WITH subtext(p,j,k-1)
+ ELSE j:=k
+ FI
+ ENDSELECT
+ UNTIL j > len
+ PER;
+ "" .
+
+ star found:
+ INT VAR starpos:= pos (p, "*", j);
+ starpos > 0 CAND starpos <= k .
+
+ ENDPROC somefix;
+
+PROC skip (TEXT CONST p, BOOL CONST upto or):
+
+ (* skips 'ppos' upto the end of the opened nest, n = nesting level *)
+
+ INT VAR n:= 0;
+ REP
+ SELECT text (subtext (p, ppos, ppos+1), 2) ISUB 1 OF
+ CASE 1,2: IF n = 0
+ THEN LEAVE skip
+ FI;
+ ppos INCR 2;
+ nDECR1
+ CASE 3: IF n = 0 CAND upto or
+ THEN LEAVE skip
+ FI;
+ ppos INCR 2
+ CASE 7: ppos INCR 2
+ CASE 4,9,10,11: ppos INCR 2;
+ n INCR 1
+ CASE 5: ppos:= pos (p, starz, ppos+2) + 2
+ CASE 6: ppos INCR 4
+ CASE 8: ppos INCR 3;
+ n INCR 1
+ OTHERWISE ppos:= pos(p, z, ppos+1) - 1;
+ IF ppos < 0
+ THEN ppos:= plen;
+ LEAVE skip
+ FI
+ ENDSELECT
+ PER
+ ENDPROC skip;
+
+BOOL OP UNLIKE (TEXT CONST t, p): NOT ( t LIKE p ) ENDOP UNLIKE;
+
+BOOL OP LIKE (TEXT CONST t, pattern):
+ init;
+ BOOL CONST found:= find (t,1,1, fixresult, floatresult);
+ save;
+ found.
+
+ init: no vari:= TRUE;
+ vari:= 0;
+ tlen:= 1 + LENGTH t;
+ p:= full (pattern);
+ IF pos (p, bound) > 0
+ THEN
+ IF subtext (p, 14, 15) = bound
+ THEN p:= subtext (p, 1, 8) + powerz0 + subtext (p, 16)
+ FI;
+ plen:= LENGTH p - 7;
+ IF subtext (p, plen, plen+1) = bound
+ THEN p:= subtext (p, 1, plen - 1) + stopz + stopz
+ FI;
+ FI;
+ plen:= LENGTH p + 1;
+ INT VAR fixresult, floatresult;
+ tpos:= 1;
+ floatpos:= 0;
+ stack:= "";
+ alphabet:= "";
+ fix:= TRUE;
+ skipcount:= 0;
+ multi:= 0.
+
+ save: p:= t
+
+ ENDOP LIKE;
+
+(*-------- Realisation of the pattern matching algorithms 'find' --------*)
+
+BOOL PROC find
+ (TEXT CONST t, INT CONST unit, from, INT VAR fixleft, floatlen):
+
+ initialize;
+ BOOL CONST found:= pattern unit;
+ SELECT next command * unit OF
+ CASE 0,1,2: found
+ CASE 3: next;
+ find alternative
+ OTHERWISE find concatenation
+ ENDSELECT .
+
+ find alternative:
+ IF found
+ THEN save left position;
+ backtrack;
+ IF find pattern CAND better
+ THEN note multiplicity
+ ELSE back to first one
+ FI
+ ELSE backtrack multi
+ FI.
+
+ better: permutation XOR more left.
+
+ permutation: vari MOD 2 = 1.
+
+ save left position: j:= fixleft.
+
+ more left: j > fixleft.
+
+ backtrack multi: multi:= 2 * backmulti + 1;
+ vari:= backvari DIV 2;
+ find pattern.
+
+ note multiplicity: multi:= 2 * multi + 1;
+ vari:= vari DIV 2;
+ TRUE.
+
+ back to first one: backtrack;
+ IF find first subpattern
+ THEN skip (p, FALSE);
+ note multiplicity
+ ELSE errorstop ("pattern");
+ FALSE
+ FI.
+
+ find concatenation:
+ IF found
+ THEN IF ppos=plen COR find pattern COR track forward
+ COR ( multi > backmulti CAND vari = 0 CAND find variation )
+ THEN TRUE
+ ELSE backtrack; FALSE
+ FI
+ ELSE skip (p, TRUE); FALSE
+ FI.
+
+ track forward: (* must be performed before variation *)
+ j:=0;
+ last multi:= multi;
+ last vari:= vari;
+ WHILE skipcount = 0
+ REP IF tlen = tpos
+ THEN LEAVE track forward WITH FALSE
+ FI;
+ backtrack;
+ j INCR 1;
+ skipcount:= j
+ UNTIL find first subpattern CAND find pattern
+ PER;
+ j:= skipcount;
+ skipcount:=0;
+ j=0.
+
+ find variation:
+ multi:= last multi;
+ vari:= last vari;
+ FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1
+ REP backtrack with variation;
+ IF find first subpattern CAND find pattern
+ THEN vari:=0;
+ LEAVE find variation WITH TRUE
+ FI
+ PER;
+ FALSE.
+
+ backtrack with variation:
+ backtrack;
+ vari:= k.
+
+ find pattern:
+ find (t, 1, ppos+forcer, fixresult, floatresult) CAND keep result.
+
+ find first subpattern:
+ find (t, 0, from, fixresult, floatresult) CAND keep result .
+
+ initialize:
+ INT VAR j,
+ k,
+ fixresult,
+ floatresult,
+ last multi,
+ last vari;
+ BOOL CONST backfix:= fix;
+ TEXT CONST backstack:= stack;
+ floatlen:= 0;
+ INT CONST back:= tpos,
+ backfloat:= floatpos,
+ backskip:= skipcount,
+ backmulti:= multi,
+ backvari:= vari;
+ fixleft:= fixleft0.
+
+ fixleft0: IF fix THEN back ELSE undefined FI.
+
+ backtrack:
+ fix:= backfix;
+ tpos:= back;
+ fixleft:= fixleft0;
+ floatlen:= 0;
+ floatpos:= backfloat;
+ stack:= backstack;
+ skipcount:= backskip;
+ multi:= backmulti;
+ vari:= backvari.
+
+ keep result:
+ IF fixleft = undefined
+ THEN IF fixresult = undefined
+ THEN floatlen INCR floatresult
+ ELSE fixleft := fixresult - floatlen;
+ floatpos DECR floatlen;
+ floatlen:= 0
+ FI
+ FI;
+ TRUE.
+
+ pattern unit:
+ init ppos;
+ SELECT command OF
+ CASE 1,2: find end
+ CASE 3: find nil
+ CASE 4: find choice
+ CASE 5: find alphabet
+ CASE 6: find fixlength any
+ CASE 7: find varlength any
+ CASE 8: find and store match
+ CASE 9: find notion
+ CASE 10: find full
+ CASE 11: next; find nil
+ OTHERWISE find plain text END SELECT.
+
+ init ppos: ppos:= from + 2.
+
+ command: text (subtext (p, from, from+1), 2) ISUB 1.
+
+ next command: text (subtext (p, ppos, ppos+1), 2) ISUB 1.
+
+ next: ppos INCR 2.
+
+ find end: ppos DECR 2;
+ fixleft:= tpos;
+ LEAVE find WITH TRUE;
+ TRUE.
+
+ find nil: ppos DECR 2;
+ fixleft:= tpos;
+ TRUE.
+
+ find choice: IF find pattern
+ THEN next; TRUE
+ ELSE next; FALSE
+ FI.
+
+ find plain text: find text upto next command;
+ IF fix THEN allow fix position only
+ ELIF text found THEN allow variable position
+ ELSE allow backtrack
+ FI.
+
+ find text upto next command:
+ ppos:= pos (p, z, from + 1);
+ IF ppos = 0
+ THEN ppos:= plen
+ ELSE ppos DECR 1
+ FI;
+ IF star found
+ THEN change (p, starpos, starpos, star);
+ plen:= 1 + LENGTH p;
+ ppos:= starpos
+ FI;
+ tpos:= pos (t, subtext (p, from, ppos - 1), tpos).
+
+ star found:
+ INT VAR starpos:= pos (p, "*", from);
+ starpos > 0 CAND starpos <= ppos .
+
+ text found:
+ WHILE skipcount > 0 CAND tpos > 0
+ REP skipcount DECR 1;
+ tpos:= pos (t, subtext(p,from,ppos-1), tpos+1)
+ PER;
+ tpos > 0 .
+
+ allow fix position only:
+ IF tpos = back
+ THEN tpos INCR (ppos-from); TRUE
+ ELSE tpos:= back;
+ from = ppos
+ FI.
+
+ allow variable position:
+ IF alphabet = "" COR in alpha (t, back, tpos)
+ THEN fix it;
+ tpos INCR (ppos-from);
+ TRUE
+ ELSE tpos:= back;
+ FALSE
+ FI.
+
+ allow backtrack:
+ tpos:= back;
+ IF from = ppos
+ THEN fix it;
+ TRUE
+ ELSE FALSE
+ FI .
+
+ find alphabet:
+ j:= pos (p, starz, ppos);
+ alphabet:= subtext (p, ppos, j-1);
+ ppos := j;
+ TRUE.
+
+ find fixlength any:
+ get length value;
+ find alpha attribut;
+ IF alphabet = ""
+ THEN find any with fix length
+ ELSE find any in alphabet with fix length
+ FI.
+
+ get length value:
+ floatlen:= subtext(p, ppos, ppos+1) ISUB 1;
+ ppos INCR 4.
+
+ find alpha attribut:
+ IF (p SUB (ppos-2)) = alpha CAND find alphabet
+ THEN next
+ FI.
+
+ find any with fix length:
+ tpos INCR floatlen;
+ IF tpos > tlen
+ THEN tpos:= back;
+ floatlen:=0;
+ FALSE
+ ELSE IF fix THEN floatlen:= 0
+ ELIF floatlen = 0
+ THEN fix it (* unlike niltext 6.6. *)
+ ELSE floatpos INCR floatlen
+ FI;
+ TRUE
+ FI.
+
+ find any in alphabet with fix length:
+ IF first character in alpha
+ THEN IF NOT fix THEN fix it FI;
+ set fix found
+ ELSE set fix not found
+ FI.
+
+ first character in alpha:
+ (fix COR advance) CAND in alpha (t, tpos, tpos+floatlen).
+
+ advance:
+ FOR tpos FROM back UPTO tlen
+ REP IF pos (alphabet, t SUB tpos) > 0
+ THEN LEAVE advance WITH TRUE
+ FI
+ PER;
+ FALSE.
+
+ fix it:
+ fixleft:= back-floatpos;
+ make fix (back);
+ fixleft:= tpos.
+
+ set fix found:
+ tpos INCR floatlen;
+ floatlen:= 0;
+ alphabet:= "";
+ TRUE.
+
+ set fix not found: tpos:= back;
+ alphabet:= "";
+ floatlen:= 0;
+ FALSE.
+
+ find varlength any: IF alphabet = ""
+ THEN really any
+ ELSE find varlength any in alphabet
+ FI.
+
+ really any: IF fix
+ THEN fix:= FALSE;
+ fixleft:= tpos
+ ELIF floatpos = 0
+ THEN fixleft:= tpos (* 6.6. *)
+ FI;
+ TRUE .
+
+ find varlength any in alphabet:
+ IF fix THEN fixleft := tpos FI;
+ IF fix CAND pos (alphabet, t SUB tpos) > 0
+ COR NOT fix CAND advance
+ THEN IF NOT fix THEN fix it FI;
+ set var found
+ ELSE set var not found
+ FI.
+
+ set var found: tpos:= end of varlength any;
+ alphabet:= "";
+ TRUE.
+ set var not found: tpos:= back;
+ alphabet:= "";
+ FALSE.
+ end of varlength any: IF NOT in alpha(t,tpos,tlen)
+ THEN failpos
+ ELSE tlen
+ FI.
+
+ find and store match: get register name;
+ IF find pattern
+ THEN next;
+ store;
+ TRUE
+ ELSE next;
+ FALSE
+ FI.
+
+ store: IF fix
+ THEN mapos (reg):= fixleft;
+ maend (reg):= tpos
+ ELSE stack CAT code(floatlen) +
+ code(floatpos) + code(fixleft) + c
+ FI.
+
+ get register name: TEXT CONST c:= p SUB (ppos);
+ INT VAR reg:= code (c);
+ ppos INCR 1.
+
+ find notion: float notion;
+ exhaust notion .
+
+ float notion: j:= back;
+ REP IF find pattern
+ THEN IF is notion (t, fixleft)
+ THEN LEAVE find notion WITH TRUE
+ ELIF backfix
+ THEN LEAVE float notion
+ ELSE go ahead FI
+ ELIF j=back
+ THEN next;
+ LEAVE find notion WITH FALSE
+ ELSE LEAVE float notion
+ FI
+ PER.
+
+ go ahead: j INCR 1;
+ IF simple THEN j:= max (tpos, j) FI;
+ notion backtrack.
+
+ simple: k:= from;
+ REP k := pos (p, z, k+2);
+ IF k > ppos-3
+ THEN LEAVE simple WITH TRUE
+ ELIF pos (oralpha, p SUB k-1) > 0
+ THEN LEAVE simple WITH FALSE
+ FI
+ PER;
+ FALSE.
+
+ notion backtrack: tpos:= j;
+ fix:= backfix;
+ fixleft:= fixleft0;
+ floatlen:= 0;
+ floatpos:= backfloat + tpos - back;
+ stack:= backstack;
+ ppos:= from + 2 .
+
+ exhaust notion: IF notion expansion
+ COR multi > backmulti
+ CAND no vari
+ CAND notion variation
+ THEN TRUE
+ ELSE backtrack; FALSE
+ FI.
+
+ notion expansion: j:= 0;
+ multi:= last multi;
+ vari:= last vari;
+ WHILE skipcount = 0
+ REP skip and try PER;
+ j:= skipcount;
+ skipcount:= 0;
+ j = 0.
+
+ skip and try: backtrack;
+ j INCR 1;
+ skipcount:=j;
+ ppos:= from + 2;
+ IF find pattern
+ THEN IF is notion (t, fixleft)
+ THEN LEAVE find notion WITH TRUE
+ FI
+ ELSE next; LEAVE find notion WITH FALSE
+ FI .
+
+ notion variation: no vari:= FALSE;
+ last multi:= multi;
+ last vari:= vari;
+ FOR k FROM 1 UPTO (multi+1) DIV (backmulti+1) - 1
+ REP backtrack with variation;
+ IF find first subpattern
+ THEN no vari:= TRUE;
+ LEAVE find notion WITH TRUE
+ FI
+ PER;
+ no vari:= TRUE;
+ FALSE.
+
+ find full:
+ find pattern CAND (end of line COR exhaust line).
+
+ end of line:
+ next;
+ IF fix
+ THEN tpos = tlen
+ ELSE tpos:= tlen;
+ make fix (1);
+ TRUE
+ FI.
+
+ exhaust line:
+ IF full expansion COR multi > 0 CAND no vari CAND full variation
+ THEN TRUE ELSE backtrack;
+ FALSE
+ FI.
+
+ full expansion:
+ j:=0;
+ last multi:= multi;
+ last vari:= vari;
+ WHILE skipcount = 0
+ REP IF tlen = tpos
+ THEN LEAVE full expansion WITH FALSE
+ FI;
+ backtrack;
+ j INCR 1;
+ skipcount:= j;
+ ppos:=from + 2
+ UNTIL find pattern CAND tpos=tlen
+ PER;
+ j:= skipcount;
+ skipcount:=0;
+ j=0.
+
+ full variation:
+ no vari:= FALSE;
+ multi:= last multi;
+ vari:= last vari;
+ FOR k FROM 1 UPTO multi
+ REP backtrack with variation;
+ IF find first subpattern
+ THEN no vari:= TRUE;
+ LEAVE find WITH TRUE
+ FI
+ PER;
+ no vari:= TRUE;
+ FALSE.
+
+ ENDPROC find;
+
+BOOL PROC is notion (TEXT CONST t, INT CONST fixleft):
+ ppos INCR 2;
+ ( NOT fix
+ COR tpos = tlen
+ COR pos (delimiter, t SUB tpos) > 0
+ COR pos (delimiter, t SUB tpos-1) > 0
+ COR (t SUB tpos) <= "Z"
+ CAND (t SUB tpos-1) > "Z" )
+ CAND ( fixleft <= 1
+ COR pos (delimiter, t SUB fixleft-1) > 0
+ COR pos (delimiter, t SUB fixleft) > 0
+ COR (t SUB fixleft) > "Z"
+ CAND (t SUB fixleft-1) <= "Z" )
+
+ END PROC is notion;
+
+PROC make fix (INT CONST back):
+ WHILE stack not empty
+ REP INT VAR reg:= code (stack SUB top),
+ pos:= code (stack SUB top-1),
+ len:= code (stack SUB top-3),
+ dis:= code (stack SUB top-2) - floatpos;
+ maend(reg):= min (tpos + dis, tlen); (* 6.6. *)
+ mapos(reg):= pos or fix or float;
+ stack:= subtext (stack,1,top-4)
+ PER;
+ fix:= TRUE;
+ floatpos:= 0 .
+
+ stack not empty: INT VAR top:= LENGTH stack;
+ top > 0.
+
+ pos or fix or float:
+ IF pos = undefined
+ THEN IF len = 0
+ THEN min (back + dis, tlen)
+ ELSE maend(reg) - len
+ FI
+ ELSE pos
+ FI.
+
+ ENDPROC make fix;
+
+BOOL PROC in alpha (TEXT CONST t, INT CONST from, to):
+ FOR failpos FROM from UPTO to - 1
+ REP IF pos (alphabet, t SUB failpos) = 0
+ THEN LEAVE in alpha WITH FALSE
+ FI
+ PER;
+ TRUE
+ ENDPROC in alpha;
+
+TEXT PROC notion (TEXT CONST t, INT CONST r): notion (t) ** r ENDPROC notion;
+
+ENDPACKET pattern match;
+
diff --git a/system/base/1.7.5/src/pcb control b/system/base/1.7.5/src/pcb control
new file mode 100644
index 0000000..9bf0e2d
--- /dev/null
+++ b/system/base/1.7.5/src/pcb control
@@ -0,0 +1,79 @@
+
+PACKET pcb and init control DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 25.08.84 *)
+ session ,
+ pcb ,
+ set line nr ,
+ clock ,
+ INITFLAG ,
+ := ,
+ initialized ,
+ storage ,
+ id ,
+ ke :
+
+
+LET line number field = 1 ,
+ myself id field = 9 ;
+
+TYPE INITFLAG = INT ;
+
+
+INT PROC session :
+ EXTERNAL 126
+ENDPROC session ;
+
+INT PROC pcb (INT CONST field) :
+ EXTERNAL 80
+ENDPROC pcb ;
+
+PROC write pcb (INT CONST task nr, field, value) :
+ EXTERNAL 105
+ENDPROC write pcb ;
+
+PROC set line nr (INT CONST value) :
+ write pcb (pcb (myself id field), line number field, value)
+ENDPROC set line nr ;
+
+
+OP := (INITFLAG VAR flag, BOOL CONST flagtrue) :
+
+ IF flagtrue
+ THEN CONCR (flag) := myself no
+ ELSE CONCR (flag) := 0
+ FI .
+
+myself no : pcb (myself id field) AND 255 .
+
+ENDOP := ;
+
+BOOL PROC initialized (INITFLAG VAR flag) :
+
+ IF CONCR (flag) = myself no
+ THEN TRUE
+ ELSE CONCR (flag) := myself no ;
+ FALSE
+ FI .
+
+myself no : pcb (myself id field) AND 255 .
+
+ENDPROC initialized ;
+
+REAL PROC clock (INT CONST nr) :
+ EXTERNAL 102
+ENDPROC clock ;
+
+PROC storage (INT VAR size, used) :
+ EXTERNAL 89
+ENDPROC storage ;
+
+INT PROC id (INT CONST no) :
+ EXTERNAL 129
+ENDPROC id ;
+
+PROC ke :
+ EXTERNAL 6
+ENDPROC ke ;
+
+ENDPACKET pcb and init control ;
+
diff --git a/system/base/1.7.5/src/real b/system/base/1.7.5/src/real
new file mode 100644
index 0000000..3e3c651
--- /dev/null
+++ b/system/base/1.7.5/src/real
@@ -0,0 +1,442 @@
+(* ------------------- VERSION 6 05.05.86 ------------------- *)
+PACKET real DEFINES (* Autor: J.Liedtke *)
+
+ text ,
+ int ,
+ real ,
+ round ,
+ floor ,
+ frac ,
+ decimal exponent ,
+ set exp ,
+ INCR ,
+ DECR ,
+ abs ,
+ ABS ,
+ sign ,
+ SIGN ,
+ MOD ,
+ min ,
+ max ,
+ max real ,
+ small real :
+
+LET mantissa length = 13 ,
+ digit zero index = 1 ,
+ digit nine index = 10 ;
+INT CONST
+ decimal point index := -1 ;
+
+TEXT VAR mantissa ;
+
+ROW 10 REAL VAR real digit ;
+
+INT VAR i ; REAL VAR d := 0.0 ;
+FOR i FROM 1 UPTO 10 REP
+ real digit (i) := d ;
+ d := d + 1.0
+PER ;
+
+REAL PROC max real : 9.999999999999e126 ENDPROC max real ;
+
+REAL PROC small real : 1.0e-12 ENDPROC small real ;
+
+PROC sld (INT CONST in, REAL VAR real, INT VAR out) :
+ EXTERNAL 96
+ENDPROC sld ;
+
+INT PROC decimal exponent (REAL CONST mantissa) :
+ EXTERNAL 97
+ENDPROC decimal exponent ;
+
+PROC set exp (INT CONST exponent, REAL VAR number) :
+ EXTERNAL 98
+ENDPROC set exp ;
+
+REAL PROC tenpower (INT CONST exponent) :
+ REAL VAR result := 1.0 ;
+ set exp (exponent, result) ;
+ result
+ENDPROC tenpower ;
+
+REAL PROC floor (REAL CONST real) :
+ EXTERNAL 99
+ENDPROC floor ;
+
+REAL PROC round (REAL CONST real, INT CONST digits) :
+
+ REAL VAR result := real ;
+ IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa length)
+ THEN round result ;
+ FI ;
+ result .
+
+round result :
+ set exp (decimal exponent (result) + digits, result) ;
+ IF result >= 0.0
+ THEN result := floor (result + 0.5)
+ ELSE result := floor (result - 0.5)
+ FI ;
+ IF result <> 0.0
+ THEN set exp (decimal exponent (result) - digits, result)
+ FI .
+
+ENDPROC round ;
+
+TEXT VAR result ;
+
+TEXT PROC text (REAL CONST real) :
+
+ REAL VAR value := rounded to seven digits ;
+ IF value = 0.0
+ THEN "0.0"
+ ELSE
+ process sign ;
+ get mantissa (value) ;
+ INT CONST exponent := decimal exponent (value) ;
+ get short mantissa ;
+ IF exponent > 7 OR exponent < LENGTH short mantissa - 7
+ THEN scientific notation
+ ELSE short notation
+ FI
+ FI .
+
+rounded to seven digits :
+ round ( real * tenpower( -decimal exponent(real) ) , 6 )
+ * tenpower ( decimal exponent(real) ) .
+
+process sign :
+ IF value < 0.0
+ THEN result := "-" ;
+ value := - value
+ ELSE result := ""
+ FI .
+
+get short mantissa :
+ INT VAR i := 7 ;
+ WHILE (mantissa SUB i) = "0" REP
+ i DECR 1
+ UNTIL i=1 END REP ;
+ TEXT CONST short mantissa := subtext (mantissa, 1, i) .
+
+scientific notation :
+ result CAT (mantissa SUB 1) ;
+ result CAT "." ;
+ result CAT subtext (mantissa, 2, 7) ;
+ result + "e" + text (exponent) .
+
+short notation :
+ IF exponent < 0
+ THEN result + "0." + (-exponent - 1) * "0" + short mantissa
+ ELSE result CAT subtext (short mantissa, 1, exponent+1) ;
+ result CAT (exponent+1 - LENGTH short mantissa) * "0" ;
+ result CAT "." ;
+ result CAT subtext (short mantissa, exponent+2) ;
+ IF LENGTH short mantissa < exponent + 2
+ THEN result + "0"
+ ELSE result
+ FI
+ FI .
+
+ENDPROC text ;
+
+PROC get mantissa (REAL CONST number) :
+
+ REAL VAR real mantissa := number ;
+ mantissa := "" ;
+ INT VAR i , digit ;
+ FOR i FROM 1 UPTO mantissa length REP
+ sld (0, real mantissa, digit) ;
+ mantissa CAT code (digit + 48)
+ PER ;
+
+ENDPROC get mantissa ;
+
+TEXT PROC text (REAL CONST real, INT CONST length) :
+
+ INT CONST mantissa length := min (length - 7, 13) ;
+ IF mantissa length > 0
+ THEN construct scientific notation
+ ELSE result := length * "*"
+ FI ;
+ result .
+
+construct scientific notation :
+ REAL VAR value := rounded real ;
+ IF value = 0.0
+ THEN result := subtext (" 0.0 ", 1, length)
+ ELSE process sign ;
+ process mantissa ;
+ process exponent
+ FI .
+
+rounded real :
+ round (real * tenpower ( -decimal exponent (real)) , mantissa length - 1)
+ * tenpower (decimal exponent (real)) .
+
+process sign :
+ IF value < 0.0
+ THEN result := "-"
+ ELSE result := "+"
+ FI .
+
+process mantissa :
+ get mantissa (value) ;
+ result CAT (mantissa SUB 1) ;
+ result CAT "." ;
+ result CAT subtext (mantissa, 2, mantissa length) .
+
+process exponent :
+ IF decimal exponent (value) >= 0
+ THEN result CAT "e+"
+ ELSE result CAT "e-"
+ FI ;
+ result CAT text (ABS decimal exponent (value), 3) ;
+ change all (result, " ", "0") .
+
+ENDPROC text ;
+
+TEXT PROC text (REAL CONST real, INT CONST length, fracs) :
+
+ REAL VAR value := round (real, fracs) ;
+ INT VAR exponent := decimal exponent (value) ;
+ IF value = 0.0 THEN exponent := 0 FI ;
+ INT VAR floors := exponent + 1 ,
+ floor length := length - fracs - 1 ;
+ IF value < 0.0 THEN floor length DECR 1 FI ;
+
+ IF value too big
+ THEN length * "*"
+ ELSE transformed value
+ FI .
+
+transformed value :
+ process leading blanks and sign ;
+ get mantissa (value) ;
+ result CAT subtext (mantissa, 1, floors) ;
+ IF LENGTH mantissa < floors
+ THEN result CAT (floors - LENGTH mantissa) * "0"
+ FI ;
+ result CAT "." ;
+ IF exponent < 0
+ THEN result CAT (-floors) * "0" ;
+ result CAT subtext (mantissa, 1, length - LENGTH result)
+ ELSE result CAT subtext (mantissa, floors+1, floors + fracs)
+ FI ;
+ IF LENGTH result < length
+ THEN result CAT (length - LENGTH result) * "0"
+ FI ;
+ result .
+
+process leading blanks and sign :
+ result := (floor length - max(floors,0)) * " " ;
+ IF value < 0.0
+ THEN result CAT "-" ;
+ value := - value
+ FI .
+
+value too big :
+ floors > floor length .
+
+ENDPROC text ;
+
+REAL PROC real (TEXT CONST text) :
+
+ skip leading blanks ;
+ sign ;
+ mantissa part ;
+ exponent ;
+ result .
+
+skip leading blanks :
+ INT VAR pos := 1 ;
+ skip blanks .
+
+skip blanks :
+ WHILE (text SUB pos) = " " REP
+ pos INCR 1
+ PER .
+
+sign :
+ BOOL VAR negative ;
+ IF (text SUB pos) = "-"
+ THEN negative := TRUE ;
+ pos INCR 1
+ ELIF (text SUB pos) = "+"
+ THEN negative := FALSE ;
+ pos INCR 1
+ ELSE negative := FALSE
+ FI .
+
+mantissa part:
+ REAL VAR value ;
+ INT VAR exponent pos := 0 ;
+ get first digit ;
+ WHILE pos <= LENGTH text REP
+ digit := code (text SUB pos) - 47 ;
+ IF digit >= digit zero index AND digit <= digit nine index
+ THEN value := value * 10.0 + real digit (digit) ;
+ pos INCR 1
+ ELIF digit = decimal point index AND exponent pos = 0
+ THEN pos INCR 1 ;
+ exponent pos := pos
+ ELSE LEAVE mantissa part
+ FI
+ END REP .
+
+get first digit :
+ INT VAR digit := code (text SUB pos) - 47 ;
+ IF digit = decimal point index
+ THEN pos INCR 1 ;
+ exponent pos := pos ;
+ digit := code (text SUB pos) - 47
+ FI ;
+ IF digit >= digit zero index AND digit <= digit nine index
+ THEN value := real digit (digit) ;
+ pos INCR 1
+ ELSE set conversion (FALSE) ;
+ LEAVE real WITH 0.0
+ FI .
+
+exponent :
+ INT VAR exp ;
+ IF exponent pos > 0
+ THEN exp := exponent pos - pos
+ ELSE exp := 0
+ FI ;
+ IF (text SUB pos) = "e"
+ THEN exp INCR int (subtext(text,pos+1))
+ ELSE no more nonblank chars permitted
+ FI .
+
+no more nonblank chars permitted :
+ skip blanks ;
+ IF pos > LENGTH text
+ THEN set conversion (TRUE)
+ ELSE set conversion (FALSE)
+ FI .
+
+result :
+ value := value * tenpower (exp) ;
+ IF negative
+ THEN - value
+ ELSE value
+ FI .
+
+ENDPROC real ;
+
+
+REAL PROC abs (REAL CONST value) :
+
+ IF value >= 0.0
+ THEN value
+ ELSE -value
+ FI
+
+ENDPROC abs ;
+
+REAL OP ABS (REAL CONST value) :
+
+ abs (value)
+
+ENDOP ABS ;
+
+INT PROC sign (REAL CONST value) :
+
+ IF value < 0.0 THEN -1
+ ELIF value = 0.0 THEN 0
+ ELSE 1
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (REAL CONST value) :
+
+ sign (value)
+
+ENDOP SIGN ;
+
+REAL OP MOD (REAL CONST left, right) :
+
+ REAL VAR result := left - floor (left/right) * right ;
+ IF result < 0.0
+ THEN result + abs (right)
+ ELSE result
+ FI
+
+ENDOP MOD ;
+
+REAL PROC frac (REAL CONST value) :
+
+ value - floor (value)
+
+ENDPROC frac ;
+
+REAL PROC max (REAL CONST a, b) :
+
+ IF a > b THEN a ELSE b FI
+
+ENDPROC max ;
+
+REAL PROC min (REAL CONST a, b) :
+
+ IF a < b THEN a ELSE b FI
+
+ENDPROC min ;
+
+OP INCR (REAL VAR dest, REAL CONST increment) :
+
+ dest := dest + increment
+
+ENDOP INCR ;
+
+OP DECR (REAL VAR dest, REAL CONST decrement) :
+
+ dest := dest - decrement
+
+ENDOP DECR ;
+
+INT PROC int (REAL CONST value) :
+
+ IF value = minint value
+ THEN minint
+ ELSE compute int result ;
+ IF value < 0.0
+ THEN - result
+ ELSE result
+ FI
+ FI .
+
+compute int result :
+ INT VAR result := 0, digit ,i ;
+ REAL VAR mantissa := value ;
+
+ FOR i FROM 0 UPTO decimal exponent (value) REP
+ sld (0, mantissa, digit) ;
+ result := result * 10 + digit
+ PER .
+
+minint value : - 32768.0 .
+minint : - 32767 - 1 .
+
+ENDPROC int ;
+
+REAL PROC real (INT CONST value) :
+
+ IF value < 0
+ THEN - real (-value)
+ ELIF value < 10
+ THEN real digit (value+1)
+ ELSE split value into head and last digit ;
+ real (head) * 10.0 + real digit (last digit+1)
+ FI .
+
+split value into head and last digit :
+ INT CONST
+ head := value DIV 10 ,
+ last digit := value - head * 10 .
+
+ENDPROC real ;
+
+ENDPACKET real ;
+
diff --git a/system/base/1.7.5/src/scanner b/system/base/1.7.5/src/scanner
new file mode 100644
index 0000000..35a632c
--- /dev/null
+++ b/system/base/1.7.5/src/scanner
@@ -0,0 +1,325 @@
+(* ------------------- VERSION 4 14.05.86 ------------------- *)
+PACKET scanner DEFINES (* Autor: J.Liedtke *)
+
+ scan ,
+ continue scan ,
+ next symbol :
+
+
+LET tag = 1 ,
+ bold = 2 ,
+ number = 3 ,
+ text = 4 ,
+ operator= 5 ,
+ delimiter = 6 ,
+ end of file = 7 ,
+ within comment = 8 ,
+ within text = 9 ;
+
+LET digit 0 = 48 ,
+ digit 9 = 57 ,
+ upper case a = 65 ,
+ upper case z = 90 ,
+ lower case a = 97 ,
+ lower case z = 122;
+
+
+TEXT VAR line := "" ,
+ char := "" ,
+ chars:= "" ;
+
+INT VAR position := 0 ,
+ comment depth ;
+BOOL VAR continue text ;
+
+
+PROC scan (TEXT CONST scan text) :
+
+ comment depth := 0 ;
+ continue text := FALSE ;
+ continue scan (scan text)
+
+ENDPROC scan ;
+
+PROC continue scan (TEXT CONST scan text) :
+
+ line := scan text ;
+ position := 0 ;
+ nextchar
+
+ENDPROC continue scan ;
+
+PROC next symbol (TEXT VAR symbol) :
+
+ INT VAR type ;
+ next symbol (symbol, type)
+
+ENDPROC next symbol ;
+
+PROC next symbol (TEXT VAR symbol, INT VAR type) :
+
+ skip blanks ;
+ IF is begin comment THEN process comment
+ ELIF comment depth > 0 THEN comment depth DECR 1 ;
+ process comment
+ ELIF is quote OR continue text THEN process text
+ ELIF is lower case letter THEN process tag
+ ELIF is upper case letter THEN process bold
+ ELIF is digit THEN process number
+ ELIF is delimiter THEN process delimiter
+ ELIF is niltext THEN eof
+ ELSE process operator
+ FI .
+
+
+process comment :
+ read comment ;
+ IF comment depth = 0
+ THEN next symbol (symbol, type)
+ ELSE type := within comment ;
+ symbol := ""
+ FI .
+
+process tag :
+ type := tag ;
+ assemble chars (lower case a, lower case z) ;
+ symbol := chars ;
+ REP
+ skip blanks ;
+ IF is lower case letter
+ THEN assemble chars (lower case a, lower case z)
+ ELIF is digit
+ THEN assemble chars (digit 0, digit 9)
+ ELSE LEAVE process tag
+ FI ;
+ symbol CAT chars
+ PER ;
+ nextchar .
+
+process bold :
+ type := bold ;
+ assemble chars (upper case a, upper case z) ;
+ symbol := chars .
+
+process number :
+ type := number ;
+ assemble chars (digit 0, digit 9) ;
+ symbol := chars ;
+ IF char = "." AND ahead char is digit
+ THEN process fraction ;
+ IF char = "e"
+ THEN process exponent
+ FI
+ FI .
+
+ahead char is digit :
+ digit 0 <= code (ahead char) AND code (ahead char) <= digit 9 .
+
+process fraction :
+ symbol CAT char ;
+ nextchar ;
+ assemble chars (digit 0, digit 9) ;
+ symbol CAT chars .
+
+process exponent :
+ symbol CAT char ;
+ nextchar ;
+ IF char = "+" OR char = "-"
+ THEN symbol CAT char ;
+ nextchar
+ FI ;
+ assemble chars (digit 0, digit 9) ;
+ symbol CAT chars .
+
+process text :
+ type := text ;
+ symbol := "" ;
+ IF continue text
+ THEN continue text := FALSE
+ ELSE next char
+ FI ;
+ WHILE not end of text REP
+ assemble chars (35, 254) ;
+ symbol CAT chars ;
+ IF NOT is quote
+ THEN symbol CAT char ;
+ nextchar
+ FI
+ ENDREP .
+
+not end of text :
+ IF is niltext
+ THEN continue text := TRUE ; type := within text ; FALSE
+ ELIF is quote
+ THEN end of text or exception
+ ELSE TRUE
+ FI .
+
+end of text or exception :
+ next char ;
+ IF is quote
+ THEN get quote ; TRUE
+ ELIF is digit
+ THEN get special char ; TRUE
+ ELSE FALSE
+ FI .
+
+get quote :
+ symbol CAT char ;
+ nextchar .
+
+get special char :
+ assemble chars (digit 0, digit 9) ;
+ symbol CAT code (int (chars) ) ;
+ nextchar .
+
+process delimiter :
+ type := delimiter ;
+ symbol := char ;
+ nextchar .
+
+process operator :
+ type := operator ;
+ symbol := char ;
+ nextchar ;
+ IF symbol = ":"
+ THEN IF char = "=" OR char = ":"
+ THEN symbol := ":=" ;
+ nextchar
+ ELSE type := delimiter
+ FI
+ ELIF is relational double char
+ THEN symbol CAT char ;
+ nextchar
+ ELIF symbol = "*" AND char = "*"
+ THEN symbol := "**" ;
+ next char
+ FI .
+
+eof :
+ type := end of file ;
+ symbol := "" .
+
+is lower case letter :
+ lower case a <= code (char) AND code (char) <= lower case z .
+
+is upper case letter :
+ upper case a <= code (char) AND code (char) <= upper case z .
+
+is digit :
+ digit 0 <= code (char) AND code (char) <= digit 9 .
+
+is delimiter : pos ( "()[].,;" , char ) > 0 .
+
+is relational double char :
+ TEXT VAR double := symbol + char ;
+ double = "<>" OR double = "<=" OR double = ">=" .
+
+is quote : char = """" .
+
+is niltext : char = "" .
+
+is begin comment : char = "{" OR char = "(" AND ahead char = "*" .
+
+ENDPROC next symbol ;
+
+PROC next char :
+
+ position INCR 1 ;
+ char := line SUB position
+
+ENDPROC next char ;
+
+PROC skip blanks :
+
+ position := pos (line, ""33"", ""254"", position) ;
+ IF position = 0
+ THEN position := LENGTH line + 1
+ FI ;
+ char := line SUB position .
+
+ENDPROC skip blanks ;
+
+TEXT PROC ahead char :
+
+ line SUB position+1
+
+ENDPROC ahead char ;
+
+PROC assemble chars (INT CONST low, high) :
+
+ INT CONST begin := position ;
+ position behind valid text ;
+ chars := subtext (line, begin, position-1) ;
+ char := line SUB position .
+
+position behind valid text :
+ position := pos (line, ""32"", code (low-1), begin) ;
+ IF position = 0
+ THEN position := LENGTH line + 1
+ FI ;
+ INT CONST higher pos := pos (line, code (high+1), ""254"", begin) ;
+ IF higher pos <> 0 AND higher pos < position
+ THEN position := higher pos
+ FI .
+
+ENDPROC assemble chars ;
+
+
+PROC read comment :
+
+ TEXT VAR last char ;
+ comment depth INCR 1 ;
+ REP
+ last char := char ;
+ nextchar ;
+ IF is begin comment
+ THEN read comment
+ FI ;
+ IF char = ""
+ THEN LEAVE read comment
+ FI
+ UNTIL is end comment PER ;
+ comment depth DECR 1 ;
+ next char ;
+ skip blanks .
+
+is end comment :
+ char = "}" OR char = ")" AND last char = "*" .
+
+is begin comment :
+ char = "{" OR char = "(" AND ahead char = "*" .
+
+ENDPROC read comment ;
+
+
+PROC scan (FILE VAR f) :
+
+ getline (f, line) ;
+ scan (line)
+
+ENDPROC scan ;
+
+PROC next symbol (FILE VAR f, TEXT VAR symbol) :
+
+ INT VAR type ;
+ next symbol (f, symbol, type)
+
+ENDPROC next symbol ;
+
+TEXT VAR scanned ;
+
+PROC next symbol (FILE VAR f, TEXT VAR symbol, INT VAR type) :
+
+ next symbol (symbol, type) ;
+ WHILE type >= 7 AND NOT eof (f) REP
+ getline (f, line) ;
+ continue scan (line) ;
+ next symbol (scanned, type) ;
+ symbol CAT scanned
+ PER .
+
+ENDPROC next symbol ;
+
+ENDPACKET scanner ;
+
diff --git a/system/base/1.7.5/src/screen b/system/base/1.7.5/src/screen
new file mode 100644
index 0000000..7e64961
--- /dev/null
+++ b/system/base/1.7.5/src/screen
@@ -0,0 +1,33 @@
+
+PACKET screen description DEFINES
+
+ xsize, ysize, marksize, mark refresh line mode :
+
+
+INT VAR xs := 80, ys := 24, ms := 1;
+
+INT PROC xsize: xs END PROC xsize;
+
+INT PROC ysize: ys END PROC ysize;
+
+INT PROC marksize: ms END PROC marksize;
+
+PROC xsize (INT CONST i): xs := i END PROC xsize;
+
+PROC ysize (INT CONST i): ys := i END PROC ysize;
+
+PROC marksize (INT CONST i): ms := i END PROC marksize;
+
+
+BOOL VAR line mode := FALSE;
+
+BOOL PROC mark refresh line mode:
+ line mode
+END PROC mark refresh line mode;
+
+PROC mark refresh line mode (BOOL CONST b):
+ line mode := b
+END PROC mark refresh line mode;
+
+END PACKET screen description ;
+
diff --git a/system/base/1.7.5/src/std transput b/system/base/1.7.5/src/std transput
new file mode 100644
index 0000000..94c51db
--- /dev/null
+++ b/system/base/1.7.5/src/std transput
@@ -0,0 +1,264 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PACKET std transput DEFINES
+
+ sysout ,
+ sysin ,
+ put ,
+ putline ,
+ line ,
+ page ,
+ write ,
+ get ,
+ getline ,
+ get secret line :
+
+
+LET cr = ""13"" ,
+ cr lf = ""13""10"" ,
+ home clear = ""1""4"" ,
+ esc = ""27"" ,
+ rubout = ""12"" ,
+ bell = ""7"" ,
+ back blank back = ""8" "8"" ,
+ del line cr lf = ""5""13""10"" ;
+
+TEXT VAR number word , exit char ;
+
+BOOL VAR console output := TRUE, console input := TRUE ;
+
+FILE VAR outfile, infile ;
+TEXT VAR outfile name := "", infile name := "" ;
+
+
+PROC sysout (TEXT CONST file name) :
+
+ outfile name := file name ;
+ IF file name = ""
+ THEN console output := TRUE
+ ELSE outfile := sequential file (output, file name) ;
+ console output := FALSE
+ FI
+
+ENDPROC sysout ;
+
+TEXT PROC sysout :
+ outfile name
+ENDPROC sysout ;
+
+PROC sysin (TEXT CONST file name) :
+
+ infile name := file name ;
+ IF file name = ""
+ THEN console input := TRUE
+ ELSE infile := sequential file (input, file name) ;
+ console input := FALSE
+ FI
+
+ENDPROC sysin ;
+
+TEXT PROC sysin :
+ infile name
+ENDPROC sysin ;
+
+
+PROC put (TEXT CONST word) :
+
+ IF console output
+ THEN out (word) ; out (" ")
+ ELSE put (outfile, word)
+ FI
+
+ENDPROC put ;
+
+PROC put (INT CONST number) :
+
+ put (text (number))
+
+ENDPROC put ;
+
+PROC put (REAL CONST number) :
+
+ put (text (number))
+
+ENDPROC put ;
+
+PROC putline (TEXT CONST textline) :
+
+ IF console output
+ THEN out (textline) ; out (cr lf)
+ ELSE putline (outfile, textline)
+ FI
+
+ENDPROC putline ;
+
+PROC line :
+
+ IF console output
+ THEN out (cr lf)
+ ELSE line (outfile)
+ FI
+
+ENDPROC line ;
+
+PROC line (INT CONST times) :
+
+ INT VAR i ;
+ FOR i FROM 1 UPTO times REP
+ line
+ PER
+
+ENDPROC line ;
+
+PROC page :
+
+ IF console output
+ THEN out (home clear)
+ FI
+
+ENDPROC page ;
+
+PROC write (TEXT CONST word) :
+
+ IF console output
+ THEN out (word)
+ ELSE write (outfile, word)
+ FI
+
+ENDPROC write ;
+
+
+PROC get (TEXT VAR word) :
+
+ IF console input
+ THEN get from console
+ ELSE get (infile, word)
+ FI .
+
+get from console :
+ REP
+ word := "" ;
+ editget (word, " ", "", exit char) ;
+ echoe exit char
+ UNTIL word <> "" AND word <> " " PER ;
+ delete leading blanks .
+
+delete leading blanks :
+ WHILE (word SUB 1) = " " REP
+ word := subtext (word,2)
+ PER .
+
+ENDPROC get ;
+
+PROC get (TEXT VAR word, TEXT CONST separator) :
+
+ IF console input
+ THEN get from console
+ ELSE get (infile, word, separator)
+ FI .
+
+get from console :
+ word := "" ;
+ editget (word, separator, "", exit char) ;
+ echoe exit char .
+
+ENDPROC get ;
+
+PROC echoe exit char :
+
+ IF exit char = ""13""
+ THEN out (""13""10"")
+ ELSE out (exit char)
+ FI
+
+ENDPROC echoe exit char ;
+
+PROC get (INT VAR number) :
+
+ get (number word) ;
+ number := int (number word)
+
+ENDPROC get ;
+
+PROC get (REAL VAR number) :
+
+ get (number word) ;
+ number := real (number word)
+
+ENDPROC get ;
+
+PROC get (TEXT VAR word, INT CONST length) :
+
+ IF console input
+ THEN get from console
+ ELSE get (infile, word, length)
+ FI .
+
+get from console :
+ word := "" ;
+ editget (word, length, exit char) ;
+ echoe exit char .
+
+ENDPROC get ;
+
+PROC getline (TEXT VAR textline) :
+
+ IF console input
+ THEN get from console
+ ELSE getline (infile, textline)
+ FI .
+
+get from console :
+ textline := "" ;
+ editget (textline, "", "", exit char) ;
+ echoe exit char
+
+ENDPROC getline ;
+
+PROC get secret line (TEXT VAR textline) :
+
+ TEXT VAR char ;
+ textline := "" ;
+ get start cursor position ;
+ get line very secret ;
+ IF char = esc
+ THEN get line little secret
+ FI ;
+ cursor to start position ;
+ out (del line cr lf) .
+
+get line very secret :
+ REP
+ inchar (char) ;
+ IF char = esc OR char = cr
+ THEN LEAVE get line very secret
+ ELIF char = rubout
+ THEN delete last char
+ ELIF char >= " "
+ THEN textline CAT char ;
+ out (".")
+ ELSE out (bell)
+ FI
+ PER .
+
+delete last char :
+ IF LENGTH textline = 0
+ THEN out (bell)
+ ELSE out (back blank back) ;
+ delete char (textline, LENGTH textline)
+ FI .
+
+get line little secret :
+ cursor to start position ;
+ editget (textline, "", "", exit char) .
+
+get start cursor position :
+ INT VAR x, y;
+ get cursor (x, y) .
+
+cursor to start position :
+ cursor (x, y) .
+
+ENDPROC get secret line ;
+
+ENDPACKET std transput ;
+
diff --git a/system/base/1.7.5/src/tasten b/system/base/1.7.5/src/tasten
new file mode 100644
index 0000000..752303b
--- /dev/null
+++ b/system/base/1.7.5/src/tasten
@@ -0,0 +1,113 @@
+
+PACKET tasten verwaltung DEFINES (* #009 *)
+ (***************)
+
+ lernsequenz auf taste legen,
+ lernsequenz auf taste,
+ kommando auf taste legen,
+ kommando auf taste,
+ taste enthaelt kommando,
+ std tastenbelegung :
+
+
+
+LET kommandoidentifikation = ""0"" ,
+ esc = ""27"" ,
+ niltext = "" ,
+ hop right left up down cr tab rubin rubout mark esc
+ = ""1""2""8""3""10""13""9""11""12""16""27"" ;
+
+
+ROW 256 TEXT VAR belegung;
+INT VAR i; FOR i FROM 1 UPTO 256 REP belegung (i) := "" PER;
+
+std tastenbelegung;
+
+
+PROC lernsequenz auf taste legen (TEXT CONST taste, lernsequenz) :
+
+ belege (belegung (code (taste) + 1), taste, lernsequenz)
+
+ENDPROC lernsequenz auf taste legen ;
+
+PROC belege (TEXT VAR tastenpuffer, TEXT CONST taste, lernsequenz) :
+ tastenpuffer := lernsequenz ;
+ verhindere rekursives lernen .
+
+verhindere rekursives lernen :
+ loesche alle folgen esc taste aber nicht esc esc taste ;
+ IF taste ist freies sonderzeichen
+ THEN change all (tastenpuffer, taste, niltext)
+ FI .
+
+loesche alle folgen esc taste aber nicht esc esc taste :
+ INT VAR i := pos (tastenpuffer, esc + taste) ;
+ WHILE i > 0 REP
+ IF ist esc esc taste
+ THEN i INCR 1
+ ELSE change (tastenpuffer, i, i+1, niltext)
+ FI ;
+ i := pos (tastenpuffer, esc + taste, i)
+ PER .
+
+ist esc esc taste :
+ (tastenpuffer SUB i-1) = esc AND (tastenpuffer SUB i-2) <> esc .
+
+taste ist freies sonderzeichen :
+ taste < ""32"" AND
+ pos (hop right left up down cr tab rubin rubout mark esc, taste) = 0 .
+
+END PROC belege ;
+
+
+TEXT PROC lernsequenz auf taste (TEXT CONST taste) :
+ IF taste enthaelt kommando (taste)
+ THEN ""
+ ELSE belegung (code (taste) + 1)
+ FI
+END PROC lernsequenz auf taste;
+
+
+PROC kommando auf taste legen (TEXT CONST taste, kommando) :
+
+ belegung (code (taste) + 1) := kommandoidentifikation;
+ belegung (code (taste) + 1) CAT kommando
+
+END PROC kommando auf taste legen;
+
+
+TEXT PROC kommando auf taste (TEXT CONST taste) :
+ IF taste enthaelt kommando (taste)
+ THEN subtext (belegung (code (taste) + 1), 2)
+ ELSE ""
+ FI
+END PROC kommando auf taste;
+
+
+BOOL PROC taste enthaelt kommando (TEXT CONST taste) :
+ (belegung (code (taste) + 1) SUB 1) = kommandoidentifikation
+END PROC taste enthaelt kommando;
+
+
+PROC std tastenbelegung:
+ lernsequenz auf taste legen ("(", ""91"");
+ lernsequenz auf taste legen (")", ""93"");
+ lernsequenz auf taste legen ("<", ""123"");
+ lernsequenz auf taste legen (">", ""125"");
+ lernsequenz auf taste legen ("A", ""214"");
+ lernsequenz auf taste legen ("O", ""215"");
+ lernsequenz auf taste legen ("U", ""216"");
+ lernsequenz auf taste legen ("a", ""217"");
+ lernsequenz auf taste legen ("o", ""218"");
+ lernsequenz auf taste legen ("u", ""219"");
+ lernsequenz auf taste legen ("k", ""220"");
+ lernsequenz auf taste legen ("-", ""221"");
+ lernsequenz auf taste legen ("#", ""222"");
+ ler�sequenz auf taste legen (" ", ""223"");
+ lernsequenz auf taste legen ("B", ""251"");
+ lernsequenz auf taste legen ("s", ""251"");
+END PROC std tastenbelegung;
+
+
+END PACKET tasten verwaltung;
+
diff --git a/system/base/1.7.5/src/text b/system/base/1.7.5/src/text
new file mode 100644
index 0000000..4c659cf
--- /dev/null
+++ b/system/base/1.7.5/src/text
@@ -0,0 +1,391 @@
+(* ------------------- VERSION 3 06.03.86 ------------------- *)
+PACKET text DEFINES
+
+ max text length ,
+ SUB ,
+ subtext ,
+ text ,
+ length , LENGTH ,
+ CAT ,
+ + ,
+ * ,
+ replace ,
+ change ,
+ change all ,
+ compress ,
+ pos ,
+ code ,
+ ISUB ,
+ RSUB ,
+ delete char ,
+ insert char ,
+ delete int ,
+ insert int ,
+ heap size ,
+ collect heap garbage ,
+ stranalyze ,
+ LEXEQUAL ,
+ LEXGREATER ,
+ LEXGREATEREQUAL :
+
+
+
+TEXT VAR text buffer , tail buffer ;
+
+INT CONST max text length := 32000 ;
+
+TEXT OP SUB (TEXT CONST text, INT CONST pos ) :
+ EXTERNAL 48
+END OP SUB ;
+
+TEXT PROC subtext (TEXT CONST source, INT CONST from, to ):
+ EXTERNAL 49
+ENDPROC subtext ;
+
+TEXT PROC subtext (TEXT CONST source, INT CONST from ) :
+ EXTERNAL 50
+ENDPROC subtext ;
+
+INT PROC code (TEXT CONST text) :
+ EXTERNAL 46
+END PROC code ;
+
+TEXT PROC code (INT CONST code) :
+ EXTERNAL 47
+ENDPROC code ;
+
+INT OP ISUB (TEXT CONST text, INT CONST index) :
+ EXTERNAL 44
+ENDOP ISUB ;
+
+PROC replace (TEXT VAR text, INT CONST index, value) :
+ EXTERNAL 45
+ENDPROC replace ;
+
+REAL OP RSUB (TEXT CONST text, INT CONST index) :
+ EXTERNAL 100
+ENDOP RSUB ;
+
+PROC replace (TEXT VAR text, INT CONST index, REAL CONST code) :
+ EXTERNAL 101
+ENDPROC replace ;
+
+
+PROC replace (TEXT VAR dest, INT CONST pos, TEXT CONST source) :
+ EXTERNAL 51
+ENDPROC replace ;
+
+TEXT PROC text (TEXT CONST source, INT CONST length ) :
+
+ IF length < LENGTH source
+ THEN text buffer := subtext (source,1,length)
+ ELSE text buffer := source ;
+ mit blanks auffuellen
+ FI ;
+ text buffer .
+
+mit blanks auffuellen :
+ INT VAR i ;
+ FOR i FROM 1 UPTO length - LENGTH source REP
+ text buffer CAT " "
+ PER .
+
+ENDPROC text ;
+
+TEXT PROC text (TEXT CONST source, INT CONST length, from) :
+ text ( subtext (source, from) , length )
+ENDPROC text ;
+
+OP CAT (TEXT VAR right, TEXT CONST left ) :
+ EXTERNAL 52
+ENDOP CAT ;
+
+TEXT OP + (TEXT CONST left, right) :
+ text buffer := left ;
+ text buffer CAT right ;
+ text buffer
+ENDOP + ;
+
+TEXT OP * (INT CONST times, TEXT CONST source ) :
+
+ text buffer := "" ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO times REP
+ text buffer CAT source
+ PER ;
+ text buffer
+
+ENDOP * ;
+
+INT PROC length (TEXT CONST text ) :
+ EXTERNAL 53
+ENDPROC length ;
+
+INT OP LENGTH (TEXT CONST text ) :
+ EXTERNAL 53
+ENDOP LENGTH ;
+
+INT PROC pos (TEXT CONST source, pattern) :
+ EXTERNAL 54
+ENDPROC pos ;
+
+INT PROC pos (TEXT CONST source, pattern, INT CONST from) :
+ EXTERNAL 55
+ENDPROC pos ;
+
+INT PROC pos (TEXT CONST source, pattern, INT CONST from, to) :
+ EXTERNAL 56
+ENDPROC pos ;
+
+INT PROC pos (TEXT CONST source, low, high, INT CONST from) :
+ EXTERNAL 58
+ENDPROC pos ;
+
+TEXT PROC compress (TEXT CONST text) :
+
+ INT VAR begin, end ;
+
+ search first non blank ;
+ search last non blank ;
+ text buffer := subtext (text, begin, end) ;
+ text buffer .
+
+search first non blank :
+ begin := 1 ;
+ WHILE (text SUB begin) = " " REP
+ begin INCR 1
+ PER .
+
+search last non blank :
+ end := LENGTH text ;
+ WHILE (text SUB end) = " " REP
+ end DECR 1
+ PER .
+
+ENDPROC compress ;
+
+PROC change (TEXT VAR destination, INT CONST from, to, TEXT CONST new) :
+
+ IF LENGTH new = to - from + 1 AND to <= LENGTH destination
+ THEN replace (destination, from, new)
+ ELSE change via buffer
+ FI .
+
+change via buffer :
+ text buffer := subtext (destination, 1, from-1) ;
+ text buffer CAT new ;
+ tail buffer := subtext (destination, to + 1) ;
+ text buffer CAT tail buffer ;
+ destination := text buffer
+
+ENDPROC change ;
+
+PROC change (TEXT VAR destination, TEXT CONST old, new) :
+
+ INT CONST position := pos (destination, old) ;
+ IF position > 0
+ THEN change (destination, position, position + LENGTH old -1, new)
+ FI
+
+ENDPROC change ;
+
+PROC change all (TEXT VAR destination, TEXT CONST old, new) :
+
+ INT VAR position := pos (destination, old) ;
+ IF LENGTH old = LENGTH new
+ THEN change by replace
+ ELSE change by change
+ FI .
+
+change by replace :
+ WHILE position > 0 REP
+ replace (destination, position, new) ;
+ position := pos (destination, old, position + LENGTH new)
+ PER .
+
+change by change :
+ WHILE position > 0 REP
+ change (destination, position, position + LENGTH old - 1 , new) ;
+ position := pos (destination, old, position + LENGTH new)
+ PER .
+
+ENDPROC change all ;
+
+PROC delete char (TEXT VAR string, INT CONST delete pos) :
+
+ IF delete pos > 0
+ THEN tail buffer := subtext (string, delete pos + 1) ;
+ string := subtext (string, 1, delete pos - 1) ;
+ string CAT tail buffer
+ FI
+
+END PROC delete char ;
+
+PROC insert char (TEXT VAR string, TEXT CONST char,
+ INT CONST insert pos) :
+
+ IF insert pos > 0 AND insert pos <= LENGTH string + 1
+ THEN tail buffer := subtext (string, insert pos) ;
+ string := subtext (string, 1, insert pos - 1) ;
+ string CAT char ;
+ string CAT tail buffer
+ FI
+
+END PROC insert char ;
+
+INT PROC heap size :
+ EXTERNAL 93
+ENDPROC heap size ;
+
+PROC collect heap garbage :
+ EXTERNAL 94
+ENDPROC collect heap garbage ;
+
+PROC stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CONST max sum,
+ TEXT CONST string, INT VAR index, INT CONST to,
+ INT VAR exit code) :
+ EXTERNAL 57
+ENDPROC stranalyze ;
+
+(*******************************************************************)
+(* lexikographische Vergleiche *)
+(* Nach DIN 5007, Abschnitt 1 und Abschnitt 3.2 (Bindestrich) *)
+(* Autor: Rainer Hahn, Jochen Liedtke *)
+(* Stand: 1.7.4 (Jan. 1985) *)
+(*******************************************************************)
+LET first umlaut = ""214"" ,
+ umlauts = ""214""215""216""217""218""219""251"" ;
+
+
+TEXT VAR left letter, right letter;
+
+BOOL OP LEXEQUAL (TEXT CONST left, right) :
+
+ compare (left, right) ;
+ left letter = right letter
+
+ENDOP LEXEQUAL ;
+
+BOOL OP LEXGREATER (TEXT CONST left, right) :
+
+ compare (left, right) ;
+ left letter > right letter
+
+ENDOP LEXGREATER ;
+
+BOOL OP LEXGREATEREQUAL (TEXT CONST left, right) :
+
+ compare (left, right) ;
+ left letter >= right letter
+
+ENDOP LEXGREATEREQUAL ;
+
+PROC compare (TEXT CONST left, right) :
+
+ to begin of lex relevant text ;
+ REP
+ get left letter ;
+ get right letter
+ UNTIL NOT letter match OR both ended PER .
+
+to begin of lex relevant text :
+ INT VAR
+ left pos := pos (left, ""65"",""254"", 1) ,
+ right pos := pos (right,""65"",""254"", 1) ;
+ IF left pos = 0
+ THEN left pos := LENGTH left + 1
+ FI ;
+ IF right pos = 0
+ THEN right pos := LENGTH right + 1
+ FI .
+
+get left letter :
+ left letter := left SUB left pos ;
+ left pos INCR 1 .
+
+get right letter :
+ right letter := right SUB right pos ;
+ right pos INCR 1 .
+
+letter match :
+ IF left letter = right letter
+ THEN TRUE
+ ELSE dine (left, left letter, left pos) ;
+ dine (right, right letter, right pos) ;
+ IF exactly one letter is double letter
+ THEN expand other letter
+ FI ;
+ left letter = right letter
+ FI .
+
+exactly one letter is double letter :
+ LENGTH left letter <> LENGTH right letter.
+
+expand other letter :
+ IF LENGTH left letter = 1
+ THEN left letter CAT (left SUB left pos) ;
+ left pos INCR 1
+ ELSE right letter CAT (right SUB right pos) ;
+ right pos INCR 1
+ FI .
+
+both ended : left letter = "" .
+
+ENDPROC compare ;
+
+PROC dine (TEXT CONST string, TEXT VAR char, INT VAR string pos) :
+
+ skip non letter chars ;
+ IF is capital letter
+ THEN translate to small letter
+ ELIF char >= first umlaut
+ THEN translate umlaut
+ FI .
+
+skip non letter chars :
+ WHILE NOT (is letter OR end of string) REP
+ char := string SUB string pos ;
+ string pos INCR 1
+ PER .
+
+translate to small letter :
+ char := code (code (char) + 32) .
+
+translate umlaut :
+ SELECT pos (umlauts, char) OF
+ CASE 1,4 : char := "ae"
+ CASE 2,5 : char := "oe"
+ CASE 3,6 : char := "ue"
+ CASE 7 : char := "ss"
+ ENDSELECT .
+
+is capital letter :
+ INT VAR char code := code (char) ;
+ 65 <= char code AND char code <= 90 .
+
+is letter :
+ char code := code (char) OR 32 ;
+ (97 <= char code AND char code <= 122) OR char code >= 128 .
+
+end of string : char = "" .
+
+ENDPROC dine ;
+
+OP CAT (TEXT VAR result, INT CONST number) :
+ result CAT " ";
+ replace (result, LENGTH result DIV 2, number);
+END OP CAT;
+
+PROC insert int (TEXT VAR result, INT CONST insert pos, number) :
+ INT VAR pos := insert pos * 2 - 1;
+ change (result, pos, pos - 1, " ");
+ replace (result, insert pos, number);
+END PROC insert int;
+
+PROC delete int (TEXT VAR result, INT CONST delete pos) :
+ INT VAR pos := delete pos * 2;
+ change (result, pos - 1, pos, "")
+END PROC delete int;
+
+ENDPACKET text ;
+
diff --git a/system/base/1.7.5/src/texter errors b/system/base/1.7.5/src/texter errors
new file mode 100644
index 0000000..9c4383d
--- /dev/null
+++ b/system/base/1.7.5/src/texter errors
@@ -0,0 +1,284 @@
+(* ------------------- VERSION 66 vom 06.03.86 -------------------- *)
+PACKET texter errors and common DEFINES
+ only command line,
+ skip input,
+ char pos move,
+ begin of this char,
+ number chars,
+ display and pause,
+ report text processing error,
+ report text processing warning:
+
+(* Programm zur zentralen Haltung aller Fehlermeldungen der Textkosmetik
+ Autor: Rainer Hahn
+ Stand: 1.7.1 Febr. 1984
+ 1.7.3 Juli "
+ 1.7.4 Febr. 1985
+ *)
+
+LET escape = ""27"";
+
+TEXT VAR fehlerdummy;
+
+BOOL PROC only command line (TEXT CONST zeile):
+INT VAR anfang, ende;
+LET kommando zeichen = "#";
+ IF pos (zeile, kommando zeichen) = 1
+ THEN ende := pos (zeile, kommando zeichen, 2);
+ IF ende > 0
+ THEN zaehle kommandos durch;
+ LEAVE only command line WITH richtiges kommandoende
+ FI
+ FI;
+ FALSE.
+
+zaehle kommandos durch:
+ WHILE ende + 1 = pos (zeile, kommando zeichen, ende +1) REP
+ anfang := pos (zeile, kommando zeichen, ende + 1);
+ ende := pos (zeile, kommando zeichen, anfang + 1)
+ END REP.
+
+richtiges kommandoende:
+ ende > 0 AND
+ (ende = length (zeile) OR (ende = length (zeile) - 1 AND absatzzeile)).
+
+absatzzeile:
+ (zeile SUB length (zeile)) = " ".
+END PROC only command line;
+
+PROC skip input:
+ REP
+ TEXT CONST zeichen :: incharety;
+ IF zeichen = escape
+ THEN errorstop ("Abbruch durch ESC")
+ FI
+ UNTIL zeichen = "" END REP
+END PROC skip input;
+
+PROC char pos move (TEXT CONST ein text, INT VAR zpos, INT CONST richtung):
+ zpos INCR richtung;
+ IF within kanji (ein text, zpos)
+ THEN zpos INCR richtung
+ FI
+END PROC char pos move;
+
+PROC begin of this char (TEXT CONST ein text, INT VAR zpos):
+ IF zpos < 1 OR zpos > length (ein text)
+ THEN display and pause (7)
+ ELSE suche zeichenposition
+ FI.
+
+suche zeichenposition:
+ IF within kanji (ein text, zpos)
+ THEN zpos DECR 1
+ FI.
+END PROC begin of this char;
+
+INT PROC number chars (TEXT CONST ein text, INT CONST von pos, bis pos):
+ INT VAR index :: von pos, anz :: 0;
+ WHILE index <= bis pos REP
+ IF index > length (ein text) OR index > bis pos
+ THEN display and pause (5); LEAVE number chars WITH 0
+ FI;
+ IF is kanji esc (ein text SUB index)
+ THEN index INCR 2
+ ELSE index INCR 1
+ FI;
+ anz INCR 1
+ END REP;
+ anz
+END PROC number chars;
+
+PROC display and pause (INT CONST nr):
+ line ; put ("LINER ERROR"); put (nr); pause
+END PROC display and pause;
+
+PROC report text processing error (INT CONST error nr,
+ INT CONST line nr,
+ TEXT VAR message,
+ TEXT CONST addition):
+
+ einfache meldung aufbauen;
+ meldung in fehlerdatei ausgeben.
+
+einfache meldung aufbauen:
+ message := "FEHLER Zeile ";
+ message CAT text (line nr);
+ message CAT ": ";
+ message CAT simple message;
+ message CAT " ";
+ message CAT addition.
+
+meldung in fehlerdatei ausgeben:
+ note (message);
+ note line;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1: "Unbekannter Schriftyp ignoriert:"
+ CASE 2: "#-Zeichen fehlt"
+ CASE 3: "foot in Fußnote (ignoriert)"
+ CASE 4: "cm-Angabe fehlt (REAL) (ignoriert):"
+ CASE 5: "INT-Parameter erwartet (ignoriert):"
+ CASE 6: "(versuchte) Trennung in Macro-Text"
+ CASE 7: "ie-Anweisung fehlt bei Seitenende"
+ CASE 8: "Unbekannte Anweisung (ignoriert):"
+ CASE 9: "Nicht kompilierbares Programm:"
+ CASE 10: "Einrückung (Leerzeichen am Zeilenanfang) zu groß"
+ CASE 11: "Anweisung hier nicht erlaubt (ignoriert):"
+ CASE 12: "Tabellen-Position liegt innerhalb eines b pos:"
+ CASE 13: "free-Wert > Textteil der Seite (ignoriert)"
+ CASE 14: "Mehr als 1 Zeichen in pagenr (ignoriert)"
+ CASE 15: "Macro innerhalb eines Macros definiert (ignoriert):"
+ CASE 16: "Mehr als drei Seitenzeichen"
+ CASE 17: "Mehr als zehn Zeilen im Index"
+ CASE 18: "Index Parameter inkorrekt (ignoriert): "
+ CASE 19: "Hinter Anweisung darf nichts mehr stehen (ignoriert):"
+ CASE 20: "Doppelter Index ignoriert:"
+ CASE 21: "ib(..) fehlt:"
+ CASE 22: "Inkorrekte Anweisung:"
+ CASE 23: "2 Byte Zeichen ohne zweites Zeichen am Zeilenende"
+ CASE 24: "free-Wert größer Seitenlänge (ignoriert):"
+ CASE 25: "Seitenende in head, bottom oder foot-Bereich plaziert"
+ CASE 26: "Anzahl columns < 2 ignoriert"
+ CASE 27: "INT-Parameter <= 0 ignoriert:"
+ CASE 28: "Kein Textzeichen vor oder hinter b"
+ CASE 29: "Nochmaliges columns ohne columns end (ignoriert)"
+ CASE 30: "set count-Parameter inkorrekt (ignoriert):"
+ CASE 31: "end ohne vorangehendes head, bottom oder foot"
+ CASE 32: "Max. Anzahl von Tabellen-Positionen überschritten"
+ CASE 33: "Macro-Aufruf oder -Definition in einem Macro (ignoriert):"
+ CASE 34: "counter nicht initialisiert (ignoriert):"
+ CASE 35: "store counter Kennung bereits vorhanden (ignoriert):"
+ CASE 36: "Spaltenbreite > limit"
+ CASE 37: "Zentimeter-Angabe in limit = 0 (ignoriert)"
+ CASE 38: "Zentimeter-Angabe inkorrekt (ignoriert):"
+ CASE 39: "Zentimeter-Angabe > als eingestelltes limit (ignoriert):"
+ CASE 40: "Makro-Definition (ignoriert):"
+ CASE 41: "Nochmaliges table ohne table end (ignoriert)"
+ CASE 42: "pos bereits hier gesetzt (ignoriert):"
+ CASE 43: "Druckposition (pos) nicht vorhanden:"
+ CASE 44: "Text breiter als Spalte bei:"
+ CASE 45: "rpos überschreibt vorherige Spalte bei:"
+ CASE 46: "cpos überschreibt vorherige Spalte bei:"
+ CASE 47: "dpos überschreibt vorherige Spalte bei:"
+ CASE 48: "Geblockter Text breiter als Spalte bei:"
+ CASE 49: "table end fehlt"
+ CASE 50: "Zentrierzeichen für dpos fehlt bei:"
+ CASE 51: "e-Anweisung ohne vorangehendes d oder u"
+ CASE 52: "fehlendes e auf dieser Zeile"
+ CASE 53: "Wort mit Exponent oder Index zu lang"
+ CASE 54: "Modifikation bereits angeschaltet bei on:"
+ CASE 55: "Modifikation nicht angeschaltet bei off:"
+ CASE 56: "Index bereits angeschaltet bei ib:"
+ CASE 57: "Index nicht angeschaltet bei ie:"
+ CASE 58: "Inkorrekte direkte Drucker-Anweisung (TEXT-Denoter):"
+ CASE 59: "tableend ohne vorangehendes table"
+ CASE 60: "put counter fehlt für:"
+ CASE 61: "store counter fehlt für:"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 1: "type-Anweisung korrigieren"
+ CASE 2: "Bitte Einfügen"
+ CASE 3: "Geschachtelte Fußnoten sind nicht möglich"
+ CASE 4: "Beispiel: limit(16.0)"
+ CASE 5: "Beispiele: page(4), pagenr(""%"",4)"
+ CASE 6: "Trennung erscheint nicht im Ausdruck!"
+ CASE 7: "Index in Indexdatei ggf. vervollständigen"
+ CASE 10: "für Zeilenbreite (limit): Leerzeichen entfernen"
+ CASE 11: "(In head-, bottom- und foot-Bereichen)"
+ CASE 13: "Parameterwert verkleinern"
+ CASE 14: "Beispiel: pagenr(""$"",5)"
+ CASE 15: "Macros kontrollieren und ggf. neu laden"
+ CASE 16: "sind z.Z. nicht zugelassen"
+ CASE 17: "ie(..) vergessen?"
+ CASE 18: "1.Parameter gibt die Index-Nummer (1-10) an. Beispiel: ie(9)"
+ CASE 19: "Anweisung muß alleine oder am Zeilenende stehen"
+ CASE 24: "in einem head, bottom oder foot-Bereich"
+ CASE 25: "Vor oder hinter den Bereich plazieren"
+ CASE 26: "1.Parameter in columns korrigieren"
+ CASE 27: "Beispiel: page(20)"
+ CASE 29: "page und columnsend vorher einfügen"
+ CASE 30: "Beispiele: setcount(0); setcount(27)"
+ CASE 31: "end ggf. entfernen"
+ CASE 34: "Bitte set counter einfuegen"
+ CASE 37: "Muß positiv sein"
+ CASE 38: "Beispiel: limit(16.0)"
+ CASE 40: "pos-Anweisungen vor table plazieren"
+ CASE 41: "tableend vergessen?"
+ CASE 42: "Bitte pos-Anweisungen überprüfen"
+ CASE 43: "in clear pos-Anweisung"
+ CASE 48: "Ggf. lineform über die Spalte"
+ CASE 49: "Bitte vor Dateiende einfügen"
+ CASE 51, 52: "Bitte u und d-Anweisungen kontrollieren"
+ CASE 53: "e-Anweisung vergessen?"
+ CASE 54, 55, 56, 57: "Anweisung in angegebener Zeilennummer überprüfen"
+ CASE 60: "Bitte store counter Anweisungen überprüfen"
+ OTHERWISE "Bitte Korrigieren"
+ END SELECT.
+END PROC report text processing error;
+
+PROC report text processing warning (INT CONST error nr,
+ INT CONST line nr,
+ TEXT VAR message,
+ TEXT CONST addition):
+
+ einfache meldung aufbauen;
+ meldung in fehlerdatei ausgeben.
+
+einfache meldung aufbauen:
+ message := "WARNUNG Zeile ";
+ message CAT text (line nr);
+ message CAT ": ";
+ message CAT simple message;
+ message CAT " ";
+ message CAT addition.
+
+meldung in fehlerdatei ausgeben:
+ note (message);
+ note line;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1, 2: ""
+ CASE 3: "Nicht referenziert:"
+ CASE 4: "Ziel-Referenz fehlt:"
+ CASE 5: "Modifikation bei Dateiende nicht ausgeschaltet:"
+ CASE 6: "Index bei Dateiende nicht ausgeschaltet:"
+ CASE 7: "Nicht getrenntes Wort zu lang für Zeilenbreite:"
+ CASE 8: "Umschaltung auf gleichen Schrifttyp:"
+ CASE 9: "Kennzeichen schon vorhanden (Duplikat ignoriert):"
+ CASE 10: "Tabellenzeile breiter als limit"
+ CASE 11: "Mehr Spalten als Tabellen-Positionen bei:"
+ CASE 12: "Überschreibung nach"
+ CASE 13: "Leerzeichen vor:"
+ CASE 14: "Weniger Spalten als Tabellen-Positionen"
+ CASE 15: "counter mit dieser Kennung bereits initialisiert:"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 3: "topage oder value fehlt"
+ CASE 4: "goalpage oder value fehlt"
+ CASE 7: "Bitte nachträglich trennen!"
+ CASE 8: "Schrifttyp wurde darum nicht verändert!"
+ CASE 9: "count und goalpage überprüfen"
+ CASE 12: "Bitte fehlende Leerzeichen einfügen"
+ CASE 13: "erzeugt ggf. zusätzliche Leerzeile"
+ OTHERWISE "Bitte überprüfen"
+ END SELECT.
+END PROC report text processing warning;
+END PACKET texter errors and common;
+
diff --git a/system/base/1.7.5/src/thesaurus b/system/base/1.7.5/src/thesaurus
new file mode 100644
index 0000000..5ef7251
--- /dev/null
+++ b/system/base/1.7.5/src/thesaurus
@@ -0,0 +1,332 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PACKET thesaurus handling (* Autor: J.Liedtke *)
+
+ DEFINES THESAURUS ,
+ := ,
+ empty thesaurus ,
+ insert, (* fuegt ein Element ein *)
+ delete, (* loescht ein Element falls vorhanden*)
+ rename, (* aendert ein Element falls vorhanden*)
+ CONTAINS , (* stellt fest, ob enthalten *)
+ link , (* index in thesaurus *)
+ name , (* name of entry *)
+ get , (* get next entry ("" is eof)*)
+ highest entry : (* highest valid index of thes*)
+
+
+TYPE THESAURUS = TEXT ;
+
+LET thesaurus size = 200 ,
+ nil = 0 ,
+ niltext = "" ,
+ max name length = 80 ,
+
+ begin entry char = ""0"" ,
+ end entry char = ""1"" ,
+
+ nil entry = ""0""1"" ,
+ nil name = "" ,
+
+ quote = """" ;
+
+TEXT VAR entry ;
+INT VAR cache index := 0 ,
+ cache pos ;
+
+
+PROC access (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ construct entry ;
+ IF NOT cache identifies entry
+ THEN search through thesaurus list
+ FI ;
+ IF entry found
+ THEN cache index := code (list SUB (cache pos - 1))
+ ELSE cache index := 0
+ FI .
+
+construct entry :
+ entry := begin entry char ;
+ entry CAT name ;
+ decode invalid chars (entry, 2) ;
+ entry CAT end entry char .
+
+search through thesaurus list :
+ cache pos := pos (list, entry) .
+
+cache identifies entry :
+ cache pos <> 0 AND
+ pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+PROC access (THESAURUS CONST thesaurus, INT CONST index) :
+
+ IF cache identifies index
+ THEN cache index := index ;
+ construct entry
+ ELSE cache pos := pos (list, code (index) + begin entry char) ;
+ IF entry found
+ THEN cache pos INCR 1 ;
+ cache index := index ;
+ construct entry
+ ELSE cache index := 0 ;
+ entry := niltext
+ FI
+ FI .
+
+construct entry :
+ entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) .
+
+cache identifies index :
+ subtext (list, cache pos-1, cache pos) = code (index) + begin entry char .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+
+
+THESAURUS PROC empty thesaurus :
+
+ THESAURUS : (""1"")
+
+ENDPROC empty thesaurus ;
+
+
+OP := (THESAURUS VAR dest, THESAURUS CONST source ) :
+
+ CONCR (dest) := CONCR (source) .
+
+ENDOP := ;
+
+TEXT VAR insert name ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ insert name := name ;
+ decode invalid chars (insert name, 1) ;
+ IF insert name = "" OR LENGTH insert name > max name length
+ THEN index := nil ; errorstop ("Name unzulaessig")
+ ELSE insert element
+ FI .
+
+insert element :
+ search free entry ;
+ IF entry found
+ THEN insert into directory
+ ELSE add entry to directory if possible
+ FI .
+
+search free entry :
+ access (thesaurus, nil name) .
+
+insert into directory :
+ change (list, cache pos + 1, cache pos, insert name) ;
+ index := cache index .
+
+add entry to directory if possible :
+ INT CONST next free index := code (list SUB LENGTH list) ;
+ IF next free index <= thesaurus size
+ THEN add entry to directory
+ ELSE directory overflow
+ FI .
+
+add entry to directory :
+ list CAT begin entry char ;
+ cache pos := LENGTH list ;
+ cache index := next free index ;
+ list CAT insert name ;
+ list CAT end entry char + code (next free index + 1) ;
+ index := cache index .
+
+directory overflow :
+ index := nil .
+
+entry found : cache index > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC insert ;
+
+PROC decode invalid chars (TEXT VAR name, INT CONST start pos) :
+
+ INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ;
+ WHILE invalid char pos > 0 REP
+ change (name, invalid char pos, invalid char pos, decoded char) ;
+ invalid char pos := pos (name, ""0"", ""31"", invalid char pos)
+ PER .
+
+decoded char : quote + text(code(name SUB invalid char pos)) + quote.
+
+ENDPROC decode invalid chars ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) :
+
+ INT VAR index ;
+ insert (thesaurus, name, index) ;
+ IF index = nil AND NOT is error
+ THEN errorstop ("THESAURUS-Ueberlauf")
+ FI .
+
+ENDPROC insert ;
+
+PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ access (thesaurus, name) ;
+ index := cache index ;
+ delete (thesaurus, index) .
+
+ENDPROC delete ;
+
+PROC delete (THESAURUS VAR thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ IF entry found
+ THEN delete entry
+ FI .
+
+delete entry :
+ IF is last entry of thesaurus
+ THEN cut off as much as possible
+ ELSE set to nil entry
+ FI .
+
+set to nil entry :
+ change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) .
+
+cut off as much as possible :
+ WHILE predecessor is also nil entry REP
+ set cache to this entry
+ PER ;
+ list := subtext (list, 1, cache pos - 1) ;
+ erase cache .
+
+predecessor is also nil entry :
+ subtext (list, cache pos - 3, cache pos - 2) = nil entry .
+
+set cache to this entry :
+ cache pos DECR 3 .
+
+erase cache :
+ cache pos := 0 ;
+ cache index := 0 .
+
+is last entry of thesaurus :
+ pos (list, end entry char, cache pos) = LENGTH list - 1 .
+
+list : CONCR (thesaurus) .
+
+entry found : cache index > nil .
+
+ENDPROC delete ;
+
+
+BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) :
+
+ IF name = niltext OR LENGTH name > max name length
+ THEN FALSE
+ ELSE access (thesaurus, name) ; entry found
+ FI .
+
+entry found : cache index > nil .
+
+ENDOP CONTAINS ;
+
+PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) :
+
+ rename (thesaurus, link (thesaurus, old), new)
+
+ENDPROC rename ;
+
+PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) :
+
+ insert name := new ;
+ decode invalid chars (insert name, 1) ;
+ IF insert name = "" OR LENGTH insert name > max name length
+ THEN errorstop ("Name unzulaessig")
+ ELSE change to new name
+ FI .
+
+change to new name :
+ access (thesaurus, index) ;
+ IF cache index <> 0 AND entry <> ""
+ THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name)
+ FI .
+
+list : CONCR (thesaurus) .
+
+ENDPROC rename ;
+
+INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ access (thesaurus, name) ;
+ cache index .
+
+ENDPROC link ;
+
+TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ subtext (entry, 2, LENGTH entry - 1) .
+
+ENDPROC name ;
+
+PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) :
+
+ identify index ;
+ REP
+ to next entry
+ UNTIL end of list COR valid entry found PER .
+
+identify index :
+ IF index = 0
+ THEN cache index := 0 ;
+ cache pos := 1
+ ELSE access (thesaurus, index)
+ FI .
+
+to next entry :
+ cache pos := pos (list, begin entry char, cache pos + 1) ;
+ IF cache pos > 0
+ THEN get entry
+ ELSE get nil entry
+ FI .
+
+get entry :
+ cache index INCR 1 ;
+ index := cache index ;
+ name := subtext (list, cache pos + 1, end entry pos - 1) .
+
+get nil entry :
+ cache index := 0 ;
+ cache pos := 0 ;
+ index := 0 ;
+ name := "" .
+
+end entry pos : pos (list, end entry char, cache pos) .
+
+end of list : index = 0 .
+
+valid entry found : name <> "" .
+
+list : CONCR (thesaurus) .
+
+ENDPROC get ;
+
+INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*)
+
+ code (list SUB LENGTH list) - 1 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC highest entry ;
+
+ENDPACKET thesaurus handling ;
+
diff --git a/system/dos/1.8.7/doc/dos-dat-handbuch b/system/dos/1.8.7/doc/dos-dat-handbuch
new file mode 100644
index 0000000..a1e4fd4
--- /dev/null
+++ b/system/dos/1.8.7/doc/dos-dat-handbuch
@@ -0,0 +1,650 @@
+____________________________________________________________________________
+
+
+#on("b")##on ("u")#
+#center#Betriebssystem E U M E L
+#off ("u")#
+
+
+#center#MS-DOS-DAT
+
+
+
+
+#off("b")#
+#center#Lizenzfreie Software der
+#on ("b")#
+
+#center#Gesellschaft für Mathematik und Datenverarbeitung mbH,
+#center#5205 Sankt Augustin
+
+
+#off("b")#
+#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für
+#center#nichtkommerzielle Zwecke gestattet.
+
+#center#Gewährleistung und Haftung werden ausgeschlossen
+
+
+____________________________________________________________________________
+#page#
+#free(4.5)#
+
+#center#Lesen und Schreiben
+#center#von
+#center#MS-DOS Dateien
+
+#on ("b")##center#MS-DOS-DAT#off ("b")#
+#free(1.5)#
+
+
+#center#Version 2.0
+
+#center#Stand 10.09.87
+#page#
+#pagenr ("%",1)##setcount (1)##block##pageblock##count per page#
+#headeven#
+% #center#MS-DOS-DAT
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#MS-DOS-DAT#right#%
+#center#____________________________________________________________
+
+#end#
+#on("bold")#
+#ib#1. Allgemeines#ie#
+#off ("b")#
+
+Dieses Programm ermöglicht MS-DOS Dateien vom EUMEL aus von Disketten zu
+lesen und auf Disketten zu schreiben. Die Benutzerschnittstelle ist ähnlich der des
+EUMEL-Archivs organisiert. Der Benutzer kommuniziert mit einer Task des
+EUMEL-Systems, nämlich mit der Task 'DOS'. Diese wickelt dann über das Archiv­
+laufwerk die Diskettenzugriffe ab. Der Benutzer meldet die MS-DOS Diskette mit
+'reserve ("...", /"DOS")' an und kann dann mit 'list (/"DOS")', 'fetch ("...", /"DOS")',
+'save ("...", /"DOS")' und weiteren Kommandos auf die MS-DOS Diskette zugreifen.
+Für das Schreiben und Lesen (save, fetch) stehen insgesamt 7 verschiedene Be­
+triebsarten zur Verfügung. Man kann in eine Datei im ASCII Code mit und ohne
+Anpassung der Umlaute, im IBM-ASCII Code, im Atari-ST Code oder ganz ohne
+Codeumsetzung lesen bzw. schreiben. Die Betriebsart selbst wird beim Anmelden der
+MS-DOS Diskette durch den Textparameter des 'reserve'-Kommandos bestimmt.
+
+Die gleiche Benutzerschnittstelle gilt für die Kommunikation mit der Task 'DOS HD'.
+Diese Task liest und schreibt aber nicht auf der Diskette, sondern in der MS-DOS
+Partition der Festplatte (falls vorhanden).
+
+
+#on("bold")#
+#ib#2. Benutzeranleitung #ie#
+#off ("b")#
+Im Normalfall will man als Benutzer eine EUMEL-Textdatei auf eine MS-DOS
+Diskette schreiben oder eine mit z.B. Word-Star erstellte MS-DOS-Textdatei in
+das EUMEL-System einlesen (implementierte Formate siehe Abschnitt 3).
+
+Lesen einer MS-DOS-Datei:
+
+#linefeed (1.25)#
+#on ("b")#
+ reserve ("file ascii german", /"DOS");
+ (* MS-DOS-Diskette ins Laufwerk einlegen *)
+ fetch (filename, /"DOS");
+ release (/"DOS")
+#off ("b")#
+
+Schreiben einer MS-DOS-Datei:
+
+#on ("b")#
+ reserve ("file ascii german", /"DOS");
+ (* MS-DOS-Diskette ins Laufwerk einlegen *)
+ save (filename, /"DOS");
+ release (/"DOS")
+#off("b")#
+#linefeed (1.0)#
+
+
+Sollen statt der Umlaute []{|}\ verwendet werden, so ist statt "file ascii german" "file
+ascii" einzustellen. Eine genaue Beschreibung aller 7 möglichen Betriebsarten wird in
+Abschnitt 6 gegeben. Der Dateiname 'file name' unterliegt den im Abschnitt 4 be­
+schriebenen Einschränkungen.
+
+
+#on("bold")#
+#ib#3. Implementierte Formate#ie#
+#off("b")#
+
+Diese Hardware ermöglicht das Bearbeiten von MS-DOS Disketten mit Hilfe der
+Task /"DOS" und (falls es sich um einen MS-DOS fähigen Rechner mit MS-DOS Parti­
+tion auf der Festplatte handelt) das Bearbeiten von Daten in der MS-DOS Partition
+der Platte.
+
+#on("bold")#
+#ib#3.1 Arbeiten mit der Task /"DOS"#ie#
+#off ("b")#
+
+Die Task /"DOS" verwendet das Archivlaufwerk als MS-DOS Datenträger. Es sind
+alle mit dem IBM-Format der DOS Version 2 und 3 kompatiblen Formate für 5.25
+Zoll und 3.5 Zoll Disketten implementiert, sofern diese 512 Byte große Sektoren
+verwenden und im ersten Sektor einen erweiterten BIOS-Parameterblock (BPB)
+enthalten (hierzu gehören auch mit dem Atari ST bearbeitete Disketten). Weiterhin
+sind die beiden von IBM verwendeten Formate der DOS Version 1 implementiert (5.25
+Zoll, ein- bzw. zweiseitig, 40 Spuren a 8 Sektoren).
+
+Die einzige Hardwarevoraussetzung besteht darin, daß der Hardwareanpassungs­
+modul (SHard) alle von DOS benutzten Sektoren lesen und schreiben können muß.
+
+#on("bold")#
+#ib#3.2 Arbeiten mit der Task /"DOS HD"#ie#
+#off ("b")#
+
+Die Task /"DOS HD" verwendet die MS-DOS Partition der Festplatte als Daten­
+träger (falls eine solche vorhanden ist und das SHard diese ansprechen kann). Hier
+gibt es keine Beschränkungen bezüglich des Plattentyps.
+
+
+#on("bold")#
+#ib#4. Dateibenennung#ie#
+#off ("b")#
+
+Die Namen für MS-DOS Dateien unterliegen bestimmten Regeln. Ein Dateiname
+kann aus
+- einem bis acht Zeichen oder
+- einem bis acht Zeichen gefolgt von einem Punkt und einer Namenserweiterung
+ von einem bis drei Zeichen
+bestehen.
+
+Gültige Zeichen sind
+- die Buchstaben A bis Z
+- die Ziffern 0 bis 9
+- die Sonder- und Satzzeichen $ \# & § ! ( ) { }
+
+Da weitere Sonderzeichen in verschiedenen MS-DOS Versionen in unterschiedlich­
+em Umfang erlaubt sind, ist ihre Verwendung beim Schreiben (save) vom EUMEL aus
+nicht zugelassen. Beim Lesen und Löschen dagegen sind sie erlaubt.
+
+Außerdem sind die Buchstaben a - z erlaubt. Diese werden beim Zugriff auf das
+MS-DOS Inhaltsverzeichnis (Directory) in große Buchstaben konvertiert. Durch das
+Kommando 'fetch ("Test", /"DOS")' wird also die MS-DOS Datei mit dem Namen
+'TEST' in die EUMEL Datei mit dem Namen 'Test' gelesen; 'save ("test", /"DOS")'
+überschreibt dann die MS-DOS-Datei 'TEST' (natürlich nach Anfrage).
+
+
+#on("bold")#
+#ib#5. Beschreibung der Kommandos#ie#
+#off ("b")#
+
+In diesem Abschnitt steht der Begriff Dostask beim Arbeiten mit der Floppy für die
+Task /"DOS" und beim Arbeiten mit der MS-DOS Partition der Platte für die Task
+/"DOS HD". Analog steht der Begriff Dosbereich beim Arbeiten mit der Floppy für die
+Floppy und beim Arbeiten mit der MS-DOS Partition der Platte für diese Partition.
+
+#on("bold")#
+THESAURUS OP ALL (TASK CONST task)
+#off ("b")#
+ Wird der 'ALL'-Operator für die Dostask aufgerufen, so wird ein Thesaurus ge­
+ liefert. In diesem Thesaurus sind alle im Dosbereich vorhandenen Dateien einge­
+ tragen. Die vorhandenen Unterinhaltsverzeichnisse (Subdirectories) werden nicht
+ eingetragen.
+
+
+#on("bold")#
+PROC check (TEXT CONST filename, TASK CONST task)
+#off ("b")#
+ Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' im Dosbe­
+ reich prüfgelesen. Es werden nur die mit Daten belegten Blöcke prüfgelesen. Sollen
+ auch der Einträge im Inhaltsverzeichnis überprüft werden, so erreicht man dies
+ durch vorheriges neues Anmelden mit der Prozedur 'reserve'.
+
+
+#on("bold")#
+PROC clear (TASK CONST task)
+#off ("b")#
+ Durch Aufruf dieser Prozedur für die Task /"DOS" wird die gesamte Diskette ge­
+ löscht. Mit dieser Prozedur können #on ("u")#nur MS-DOS formatierte Disketten#off ("u")# behandelt
+ werden. Soll eine Diskette dagegen für den Gebrauch unter MS-DOS initialisiert
+ werden, so ist sie auf einem MS-DOS-Rechner zu formatieren.
+
+ Der Aufruf dieser Prozedur für die Task /DOS HD" ist aus Sicherheitsgründen nicht
+ erlaubt.
+
+
+#on("bold")#
+PROC erase (TEXT CONST filename, TASK CONST task)
+#off ("b")#
+ Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' im Dosbe­
+ reich gelöscht.
+
+
+#on("bold")#
+BOOL PROC exists (TEXT CONST name, TASK CONST task)
+#off ("b")#
+ Wird diese Prozedur für die Dostask aufgerufen, so liefert sie 'TRUE', falls eine
+ Datei mit dem Namen 'name' im Dosbereich existiert. Andernfalls liefert sie
+ 'FALSE'.
+
+
+#on("bold")#
+PROC fetch (TEXT CONST filename, TASK CONST task)
+#off ("b")#
+ Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' aus dem
+ Dosbereich gelesen. Hierbei wird in der beim Anmelden (reserve ("...", dostask))
+ bestimmten Betriebsart gelesen (siehe Abschnitt 6).
+
+
+#on("bold")#
+PROC list (TASK CONST task)
+#off ("b")#
+ Wird diese Prozedur für die Dostask aufgerufen, so werden alle Dateien des In­
+ haltsverzeichnisses und alle Unterverzeichnisse des Dosbereichs aufgelistet.
+
+
+#on("bold")#
+PROC release (TASK CONST task)
+#off ("b")#
+ Der Aufruf dieser Prozedur für die Task Dostask hebt deren Reservierung auf.
+ Gleichzeitig wird auch der für block i/o benutzte Kanal freigegeben, so daß bei
+ Benutzung der Task /"DOS" der Archivkanal durch das EUMEL-Archiv wieder
+ benutzt werden kann.
+
+ Um möglichst effizient arbeiten zu können, werden Inhaltsverzeichnis und Ket­
+ tungsblock des Dosbereichs als Kopie im EUMEL gehalten. Der hierdurch belegte
+ Speicher wird beim 'release' wieder freigegeben. Dies ist bei kleinen Systemen
+ besonders wichtig.
+
+
+#on("bold")#
+PROC reserve (TEXT CONST mode, TASK CONST task)
+#off ("b")#
+ Durch Aufruf für die Dostask werden Operationen mit dem Dosbereich angemel­
+ det. Gleichzeitig koppelt sich die Dostask an den entsprechenden Kanal an.
+ (/"DOS" an Kanal 31 und /"DOS HD" an Kanal 29). Die Anmeldung wird abge­
+ lehnt, wenn der für die MS-DOS Operationen benötigte Kanal belegt ist (z.B. bei
+ Kanal 31 durch eine Archiv­Operation). Ähnlich wie beim EUMEL-Archiv bleibt
+ diese Reservierung bis 5 Minuten nach dem letzten Zugriff gültig.
+
+ Wird beim Arbeiten mit der Task /"DOS" die MS-DOS Diskette gewechselt, so
+ muß erneut 'reserve ("...", /"DOS")' aufgerufen werden. Nur so ist gewährleistet,
+ daß das Inhaltsverzeichnis der neuen Diskette geladen wird.
+
+ Der Text 'mode' gibt die Betriebsart für das Schreiben und Lesen der Diskette
+ sowie den Pfad für das Bearbeiten von Subdirectories an und nicht wie beim
+ EUMEL-Archiv den Diskettennamen. Es gilt folgende Systax:
+
+ modus :[\directory][\directory]...[\directory]
+
+ Hierbei sind die Angaben in eckigen Klammern optional. Wird kein Pfad angege­
+ ben, so wird mit dem Hauptdirektory der Diskette gearbeitet. Ansonsten wird mit
+ dem Directory gearbeitet, welches durch den hinter dem Doppelpunkt angegeben
+ Pfad bezeichnet wird. Als 'modus' können alle in Abschnitt 6 beschriebenen Be­
+ triebsarten verwendet werden.
+
+
+#on("bold")#
+PROC save (TEXT CONST filename, TASK CONST task)
+#off ("b")#
+ Durch Aufruf dieser Prozedur für die Dostask wird die Datei 'filename' in den
+ Dosbereich geschrieben. Hierbei wird in der beim Anmelden (reserve ("...",
+ dostask)) bestimmten Betriebsart geschrieben (siehe Abschnitt 6).
+
+
+#on("bold")#
+#ib#6. Die Betriebsarten von 'fetch' und 'save'#ie#
+
+#ib#6.1 Betriebsart: file ascii#ie#
+
+#on("bold")#
+fetch ("filename", dostask)
+#off ("b")#
+ Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei
+ werden von allen Zeichen nur die niederwertigen 7 Bit gemäß DIN 66 003, ASCII
+ Code, internationale Referenzversion interpretiert. Die Datei wird so aufbereitet, daß
+ ein Bearbeiten mit dem EUMEL-Editor möglich ist. Dies geschieht folgenderma­
+ ßen:
+ - Alle im EUMEL darstellbaren Zeichen werden auf diese abgebildet.
+ - Die Zeichenfolgen CR LF, LF CR, LF, CR (CR = carriage return, LF = line­
+ feed) beenden einen Satz in der MS-DOS-Datei. Dementsprechend wird
+ eumelseitig die aktuelle Zeile beendet.
+ - Das Zeichen FF (form feed) beendet eumelseitig die aktuelle Zeile. Außerdem
+ wird ein Satz mit dem Inhalt "\#page\#" eingefügt.
+ - TAB's (Code 9) werden mit Blanks zur nächsten 8ter-Position expandiert.
+ - 'Ctrl z' in der MS-DOS Datei wird als Dateiende interpretiert. Fehlt dieses,
+ so wird bis zum letzten Zeichen des letzten Sektors der Datei gelesen.
+ - Alle anderen Zeichen mit 0 <= code (zeichen) <=  31 (Steuerzeichen)
+ werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird
+ als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt).
+
+
+#on("bold")#
+save ("filename", dostask)
+#off ("b")#
+ Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS
+ wird der ASCII Code, internationale Referenzversion gemäß DIN 66 003 verwendet.
+ Dies geschieht folgendermaßen:
+ - Die EUMEL-spezifischen Druckzeichen (Trenn -, Trenn k, Druck \#, ge­
+ schütztes Blank) werden in -, k, \# und Blank umgesetzt.
+ - Alle in der internationalen Referenzversion des ASCII Codes vorhandenen
+ Eumel-Zeichen werden auf diese abgebildet.
+ - Alle in der internationalen Referenzversion des ASCII Codes nicht vorhande­
+ nen Eumel-Zeichen werden durch eine Ersatzdarstellung dargestellt (der
+ Code des Zeichens wird als 3 stellige Dezimalzahl eingeschlossen von
+ \#-Zeichen dargestellt)
+ - Steht in einer Zeile nur das Kommando '\#page\#' so wird dieses in ein Sei­
+ tenvorschubsteuerzeichen (""12"") umgewandelt.
+ - Eine dreistellige Dezimalzahl eingeschlossen von \# Zeichen wird als Ersatz­
+ darstellung für das Zeichen mit dem durch die Dezimalzahl angegebenen
+ Code betrachte. Diese Ersatzdarstellung wird beim Schreiben aufgelöst (d.h.
+ durch das entsprechende Zeichen ersetzt).
+ - Nach jeder Zeile wird 'carriage return' und ' linefeed' angefügt
+ - Am Ende der Datei wird 'ctrl z' angehängt.
+
+
+#on("bold")#
+#ib#6.2 Betriebsart: file ascii german#ie#
+
+fetch ("filename", dostask)
+#off ("b")#
+ Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei
+ werden von allen Zeichen nur die niederwertigen 7 Bit gemäß DIN 66 003, ASCII
+ Code, deutsche Referenzversion interpretiert. Die Datei wird so aufbereitet, daß ein
+ Bearbeiten mit dem EUMEL-Editor möglich ist. Dies geschieht wie in der Be­
+ triebsart 'file ascii', jedoch stehen statt []{}|\ die Umlaute und ß zur Verfügung.
+
+
+#on("bold")#
+save ("filename", dostask)
+#off ("b")#
+ Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS
+ wird der ASCII Code, deutsche Referenzversion gemäß DIN 66 003 verwendet. Dies
+ geschieht wie in der Betriebsart 'file ascii', jedoch stehen statt []{}|\ die Umlaute
+ zur Verfügung.
+
+
+#on("bold")#
+#ib#6.3 Betriebsart: file ibm#ie#
+
+fetch ("filename", dostask)
+#off ("b")#
+ Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei
+ werden alle Zeichen wie in der von IBM verwendeten Version des ASCII Codes
+ interpretiert. Die Datei wird so aufbereitet, daß ein Bearbeiten mit dem EUMEL-
+ Editor möglich ist. Dies geschieht folgendermaßen:
+ - Alle im EUMEL darstellbaren Zeichen werden auf diese abgebildet.
+ - Die Zeichenfolgen CR LF, LF CR, LF, CR (CR = carriage return, LF = line­
+ feed) beenden einen Satz in der MS-DOS-Datei. Dementsprechend wird
+ eumelseitig die aktuelle Zeile beendet.
+ - Das Zeichen FF (form feed) beendet eumelseitig die aktuelle Zeile. Außerdem
+ wird ein Satz mit dem Inhalt "\#page\#" eingefügt.
+ - TAB's (Code 9) werden mit Blanks zur nächsten 8ter-Position expandiert.
+ - Alle anderen Zeichen mit 0 <= code (zeichen) <=  31 (Steuerzeichen)
+ werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird
+ als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt).
+
+
+#on("bold")#
+save ("filename", dostask)
+#off ("b")#
+ Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS
+ wird der ASCII Code in der von IBM verwendeten Version verwendet. Dies ge­
+ schieht folgendermaßen:
+ - Die EUMEL-spezifischen Druckzeichen (Trenn -, Trenn k, Druck \#, ge­
+ schütztes Blank) werden in -, k, \# und Blank umgesetzt.
+ - Alle in der IBM Version des ASCII Codes vorhandenen Eumel-Zeichen
+ werden auf diese abgebildet.
+ - Alle in der IBM Version des ASCII Codes nicht vorhandenen Eumel-Zeichen
+ werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird
+ als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt)
+ - Steht in einer Zeile nur das Kommando '\#page\#' so wird dieses in ein Sei­
+ tenvorschubsteuerzeichen (""12"") umgewandelt.
+ - Eine dreistellige Dezimalzahl eingeschlossen von \# Zeichen wird als Ersatz­
+ darstellung für das Zeichen mit dem durch die Dezimalzahl angegebenen
+ Code betrachte. Diese Ersatzdarstellung wird beim Schreiben aufgelöst (d.h.
+ durch das entsprechende Zeichen ersetzt).
+ - Nach jeder Zeile wird 'carriage return' und ' linefeed' angefügt
+
+
+#on("bold")#
+#ib#6.4 Betriebsart: file atari st#ie#
+
+fetch ("filename", dostask)
+#off ("b")#
+ Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei
+ werden alle Zeichen wie in der vom Atari ST verwendeten Version des ASCII Codes
+ interpretiert. Die Datei wird so aufbereitet, daß ein Bearbeiten mit dem EUMEL-
+ Editor möglich ist. Dies geschieht folgendermaßen:
+ - Alle im EUMEL darstellbaren Zeichen werden auf diese abgebildet.
+ - Die Zeichenfolgen CR LF, LF CR, LF, CR (CR = carriage return, LF = line­
+ feed) beenden einen Satz in der MS-DOS-Datei. Dementsprechend wird
+ eumelseitig die aktuelle Zeile beendet.
+ - Das Zeichen FF (form feed) beendet eumelseitig die aktuelle Zeile. Außerdem
+ wird ein Satz mit dem Inhalt "\#page\#" eingefügt.
+ - TAB's (Code 9) werden mit Blanks zur nächsten 8ter-Position expandiert.
+ - Alle anderen Zeichen mit 0 <= code (zeichen) <=  31 (Steuerzeichen)
+ werden durch eine Ersatzdarstellung dargestellt (der Code des Zeichens wird
+ als 3 stellige Dezimalzahl eingeschlossen von \#-Zeichen dargestellt).
+
+
+#on("bold")#
+save ("filename", dostask)
+#off ("b")#
+ Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Unter MS-DOS
+ wird der ASCII Code in der vom Atari ST verwendeten Version verwendet. Dies
+ geschieht folgendermaßen:
+ - Die EUMEL-spezifischen Druckzeichen (Trenn -, Trenn k, Druck \#, ge­
+ schütztes Blank) werden in -, k, \# und Blank umgesetzt.
+ - Alle in der vom Atari ST verwendeten Version des ASCII Codes vorhandenen
+ Eumel-Zeichen werden auf diese abgebildet.
+ - Alle in der vom Atari ST verwendeten Version des ASCII Codes nicht
+ vorhandenen Eumel-Zeichen werden durch eine Ersatzdarstellung dargestellt
+ (der Code des Zeichens wird als 3 stellige Dezimalzahl eingeschlossen von
+ \#-Zeichen dargestellt)
+ - Steht in einer Zeile nur das Kommando '\#page\#' so wird dieses in ein Sei­
+ tenvorschubsteuerzeichen (""12"") umgewandelt.
+ - Eine dreistellige Dezimalzahl eingeschlossen von \# Zeichen wird als Ersatz­
+ darstellung für das Zeichen mit dem durch die Dezimalzahl angegebenen
+ Code betrachte. Diese Ersatzdarstellung wird beim Schreiben aufgelöst (d.h.
+ durch das entsprechende Zeichen ersetzt).
+ - Nach jeder Zeile wird 'carriage return' und ' linefeed' angefügt
+
+
+#on("bold")#
+#ib#6.5 Betriebsart: file transparent#ie#
+
+fetch ("filename", dostask)
+#off ("b")#
+ Die MS-DOS Datei 'filename' wird in die EUMEL-Datei 'filename' kopiert. Dabei
+ werden von allen Zeichen alle 8 Bit interpretiert. Es werden keine Zeichen einge­
+ fügt, gelöscht oder gewandelt. Somit stehen dann auch CR und LF Zeichen in der
+ EUMEL-Datei.
+
+ Da eine solche Datei noch Steuerzeichen enthält, ist beim Bearbeiten mit dem
+ Editor Vorsicht geboten.
+
+
+#on("bold")#
+save ("filename", dostask)
+#off ("b")#
+ Die EUMEL-Datei 'filename' wird nach MS-DOS geschrieben. Es werden keine
+ Codeumsetzungen durchgeführt. Insbesondere muß die EUMEL-Datei auch die CR
+ LF Sequenzen für das Zeilenende enthalten.
+
+
+#on("bold")#
+#ib#6.6 Betriebsart: row text#ie#
+#off ("b")#
+
+Diese Betriebsart ist nur für Programmierer interessant. Sie ist für die Umsetzung
+exotischer Codes in den EUMEL-Code mittels ELAN-Programmen gedacht.
+
+#on("bold")#
+fetch ("filename", dostask)
+#off ("b")#
+ Die MS-DOS Datei 'filename' wird in einen Datenraum mit folgender Struktur
+ kopiert:
+
+ STRUCT (INT benutzte texte, ROW 4000 TEXT datensatz)
+
+ Dabei bekommt der Datenraum den Type 1000. Der Integer 'benutzte texte' gibt an,
+ wieviele Elemente des ROW 4000 TEXT benutzt sind. In jedem benutzten Element
+ des ROW 4000 TEXT steht der Inhalt einer logischen Gruppe der MS-DOS Disket­
+ te. (Eine logische Gruppe umfaßt bei einer einseitig beschriebenen MS-DOS
+ Diskette 512 Byte und bei einer zweiseitig beschriebenen 1024 bzw. 2048 Byte). In
+ dieser Betriebsart werden keine Zeichen der MS-DOS Datei konvertiert oder
+ interpretiert, so daß also auch alle Steuerzeichen erhalten bleiben.
+
+
+#on("bold")#
+save ("filename", dostask)
+#off ("b")#
+ Hier bezeichnet 'filename' einen Datenraum der Struktur:
+
+ STRUCT (INT benutzte texte, ROW 4000 TEXT datensatz)
+
+ Dieser Datenraum muß den Type 1000 haben.
+ Es werden die benutzten Texte (1 bis benutzte texte) aneinandergehängt und ohne
+ irgendwelche Konvertierungen bzw. Interpretationen als MS-DOS Datei 'filename'
+ geschrieben. Dies bedeutet, daß die Texte auch alle von MS-DOS benötigten
+ Steuerzeichen (z.B. 'ctrl z' als Dateiendekennzeichen) enthalten müssen.
+
+
+#on("bold")#
+#ib#6.7 Betriebsart: ds#ie#
+#off ("b")#
+Diese Betriebsart ist nur für den Programmierer interessant. Sie ermöglicht das Abbil­
+den von Datenstrukturen zwischen MS-DOS und EUMEL.
+
+#on("bold")#
+fetch ("filename", dostask)
+#off ("b")#
+ Die MS-DOS Datei 'filename' wird blockweise in den Datenraum 'filename' ko­
+ piert. Hierbei wird der erste Block der MS-DOS Datei in die 2. Seite des Daten­
+ raums kopiert. (Die 2. Seite eines Datenraums ist die erste, die von einer Daten­
+ struktur voll überdeckt werden kann).
+
+
+#on("bold")#
+save ("filename", dostask)
+#off ("b")#
+ Der Datenraum 'filename' wird ab seiner 2. Seite in die MS-DOS Datei 'filename'
+ geschrieben. Hierbei werden alle Seiten des Datenraums (auch die nicht allokier­
+ ten) bis einschließlich der letzten allokierten Datenraumseite geschrieben.
+
+
+#on("bold")#
+#ib#7. Installation#ie#
+#off ("b")#
+
+Die Software zur Generierung der Tasks /"DOS" und /"DOS HD" wird auf einem
+EUMEL-Archiv ausgeliefert.
+
+#on("bold")#
+#ib#7.1 Installation der Task /"DOS"#ie#
+
+#ib#7.1.1 Installation im Multi-User#ie#
+#off ("b")#
+
+Die Software muß in einer privilegierten Task mit dem Namen 'DOS' installiert wer­
+den. Dies geschieht folgendermaßen:
+
+
+ begin ("DOS", "SYSUR")
+
+ archive ("austausch");
+ fetch ("dos inserter", archive);
+ run ("dos inserter")
+
+
+Danach stehen die Prozeduren
+
+
+ PROC dos manager
+ PROC dos manager (INT CONST channel)
+
+
+zur Verfügung. Beide Prozeduren machen die aufrufende Task zur Kommunikations­
+task für das Schreiben und Lesen von MS-DOS Disketten. Die erste benutzt dazu
+den Archivkanal (Kanal 31), bei der zweiten ist der Kanal über den Parameter ein­
+stellbar. Eine dieser Prozeduren muß jetzt aufgerufen werden.
+
+#on("bold")#
+#ib#7.1.2. Installation im Single-User#ie#
+#off ("b")#
+
+Die Software wird im Monitor ('gib Kommando'-Modus) durch folgende Kommandos
+installiert:
+
+
+ archive ("austausch");
+ fetch ("dos inserter", archive);
+ run ("dos inserter")
+
+
+Für das Schreiben und Lesen von MS-DOS Disketten wird der Archivkanal (Kanal
+31) benutzt.
+
+
+#on("bold")#
+#ib#7.2 Installation der Task /"DOS HD"#ie#
+#off ("b")#
+
+Die Software muß in einer privilegierten Task mit dem Namen 'DOS HD' installiert
+werden. Dies geschieht folgendermaßen:
+
+
+ begin ("DOS HD", "SYSUR")
+
+ archive ("austausch");
+ fetch ("dos hd inserter", archive);
+ run ("dos hd inserter")
+
+
+Danach steht die Prozedur
+
+
+ PROC dos manager
+
+
+zur Verfügung. Sie macht die aufrufende Task zur Kommunikationstask für das
+Schreiben und Lesen in der MS-DOS Partition der Platte. Sie benutzt dazu den
+Kanal 29, der, wie im Portierungshandbuch für den 8086 beschrieben, implementiert
+sein muß.
+
+#page#
+#headeven#
+#end#
+
+
+
+
+
+Herausgegeben von:
+
+ Gesellschaft für Mathematik und Datenverarbeitung mbH
+ (GMD)
+ Schloß Birlinghoven
+ 5205 Sankt Augustin 1
+
+ und
+
+ Hochschulrechenzentrum der Universität Bielefeld
+ (HRZ)
+ Universitätsstraße
+ 4800 Bielefeld 1
+
+Autor:
+
+ Frank Klapper
+
+überarbeitet von:
+
+ Thomas Müller
+ Hansgeorg Freese (GMD)
+
+Umschlaggestaltung:
+
+ Hannelotte Wecken
+
+
+
+
+
+
diff --git a/system/dos/1.8.7/source-disk b/system/dos/1.8.7/source-disk
new file mode 100644
index 0000000..cc5ebe0
--- /dev/null
+++ b/system/dos/1.8.7/source-disk
@@ -0,0 +1 @@
+187_ergos/04_dos.img
diff --git a/system/dos/1.8.7/src/block i-o b/system/dos/1.8.7/src/block i-o
new file mode 100644
index 0000000..554fcca
--- /dev/null
+++ b/system/dos/1.8.7/src/block i-o
@@ -0,0 +1,180 @@
+PACKET disk block io DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ (* 05.01.87 *)
+ read disk block,
+ read disk block and close work if error,
+ read disk cluster,
+ write disk block,
+ write disk block and close work if error,
+ write disk cluster,
+ first non dummy ds page,
+
+ block no dump modus:
+
+BOOL VAR block no dump flag := FALSE;
+
+LET write normal = 0;
+
+INT CONST first non dummy ds page := 2;
+
+INT VAR error;
+
+PROC read disk block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no):
+ IF block no dump flag THEN dump ("READ ", block no) FI;
+ check rerun;
+ read block (ds, ds page no, eublock (block no), error);
+ IF error > 0
+ THEN lesefehler (error)
+ FI.
+
+END PROC read disk block;
+
+PROC read disk block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ REAL CONST block no):
+ IF block no dump flag THEN dump ("READ ", block no) FI;
+ check rerun;
+ read block (ds, ds page no, eublock (block no), error);
+ IF error > 0
+ THEN lesefehler (error)
+ FI.
+
+END PROC read disk block;
+
+PROC read disk block and close work if error (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no):
+ IF block no dump flag THEN dump ("READ ", block no) FI;
+ check rerun;
+ read block (ds, ds page no, eublock (block no), error);
+ IF error > 0
+ THEN close work;
+ lesefehler (error)
+ FI.
+
+END PROC read disk block and close work if error;
+
+PROC read disk block and close work if error (DATASPACE VAR ds,
+ INT CONST ds page no,
+ REAL CONST block no):
+ IF block no dump flag THEN dump ("READ ", block no) FI;
+ check rerun;
+ read block (ds, ds page no, eublock (block no), error);
+ IF error > 0
+ THEN close work;
+ lesefehler (error)
+ FI.
+
+END PROC read disk block and close work if error;
+
+PROC read disk cluster (DATASPACE VAR ds,
+ INT CONST first ds page no,
+ REAL CONST cluster no):
+ IF block no dump flag THEN dump ("CLUSTER ", cluster no) FI;
+ INT VAR i;
+ FOR i FROM 0 UPTO sectors per cluster - 1 REP
+ read disk block (ds, first ds page no + i, block no + real (i))
+ PER.
+
+block no:
+ begin of cluster (cluster no).
+
+END PROC read disk cluster;
+
+PROC lesefehler (INT CONST fehler code):
+ error stop (fehlertext).
+
+fehlertext:
+ SELECT fehler code OF
+ CASE 1: "Diskettenlaufwerk nicht betriebsbereit"
+ CASE 2: "Lesefehler"
+ OTHERWISE "Lesefehler " + text (fehler code)
+ END SELECT.
+
+END PROC lesefehler;
+
+PROC write disk block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no):
+ IF block no dump flag THEN dump ("WRITE", block no) FI;
+ check rerun;
+ write block (ds, ds page no, write normal, eublock (block no), error);
+ IF error > 0
+ THEN schreibfehler (error)
+ FI.
+
+END PROC write disk block;
+
+PROC write disk block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ REAL CONST block no):
+ IF block no dump flag THEN dump ("WRITE", block no) FI;
+ check rerun;
+ write block (ds, ds page no, write normal, eublock (block no), error);
+ IF error > 0
+ THEN schreibfehler (error)
+ FI.
+
+END PROC write disk block;
+
+PROC write disk block and close work if error (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no):
+ IF block no dump flag THEN dump ("WRITE", block no) FI;
+ check rerun;
+ write block (ds, ds page no, write normal, eublock (block no), error);
+ IF error > 0
+ THEN close work;
+ schreibfehler (error)
+ FI.
+
+END PROC write disk block and close work if error;
+
+PROC write disk block and close work if error (DATASPACE CONST ds,
+ INT CONST ds page no,
+ REAL CONST block no):
+ IF block no dump flag THEN dump ("WRITE", block no) FI;
+ check rerun;
+ write block (ds, ds page no, write normal, eublock (block no), error);
+ IF error > 0
+ THEN close work;
+ schreibfehler (error)
+ FI.
+
+END PROC write disk block and close work if error;
+
+PROC write disk cluster (DATASPACE CONST ds,
+ INT CONST first ds page no,
+ REAL CONST cluster no):
+ IF block no dump flag THEN dump ("CLUSTER ", cluster no) FI;
+ INT VAR i;
+ FOR i FROM 0 UPTO sectors per cluster - 1 REP
+ write disk block (ds, first ds page no + i, block no + real (i))
+ PER.
+
+block no:
+ begin of cluster (cluster no).
+
+END PROC write disk cluster;
+
+PROC schreibfehler (INT CONST fehler code):
+ error stop (fehlertext).
+
+fehlertext:
+ SELECT fehler code OF
+ CASE 1: "Diskettenlaufwerk nicht betriebsbereit"
+ CASE 2: "Schreibfehler"
+ OTHERWISE "Schreibfehler " + text (fehler code)
+ END SELECT.
+
+END PROC schreibfehler;
+
+PROC block no dump modus (BOOL CONST status):
+ block no dump flag := status
+
+END PROC block no dump modus;
+
+END PACKET disk block io;
+
diff --git a/system/dos/1.8.7/src/bpb ds b/system/dos/1.8.7/src/bpb ds
new file mode 100644
index 0000000..dabf721
--- /dev/null
+++ b/system/dos/1.8.7/src/bpb ds
Binary files differ
diff --git a/system/dos/1.8.7/src/dir.dos b/system/dos/1.8.7/src/dir.dos
new file mode 100644
index 0000000..08456b5
--- /dev/null
+++ b/system/dos/1.8.7/src/dir.dos
@@ -0,0 +1,693 @@
+PACKET dir DEFINES (* Copyright (c) 1986, 87 *)
+ (* Frank Klapper *)
+ open dir, (* 02.03.88 *)
+ insert dir entry,
+ delete dir entry,
+ init dir ds,
+ file info,
+ format dir,
+
+ dir list,
+ file exists,
+ subdir exists,
+ all files,
+ all subdirs:
+
+LET max dir entrys = 1000;
+
+(*-------------------------------------------------------------------------*)
+
+INITFLAG VAR dir block ds used := FALSE;
+DATASPACE VAR dir block ds;
+BOUND STRUCT (ALIGN dummy, ROW 64 REAL daten) VAR dir block;
+REAL VAR last read dir block no;
+
+PROC init dir block io:
+ last read dir block no := -1.0;
+ IF NOT initialized (dir block ds used)
+ THEN dir block ds := nilspace;
+ dir block := dir block ds
+ FI.
+
+END PROC init dir block io;
+
+PROC read dir block (REAL CONST block nr):
+ IF last read dir block no <> block nr
+ THEN last read dir block no := -1.0;
+ read disk block and close work if error (dir block ds, 2, block nr);
+ last read dir block no := block nr
+ FI.
+
+END PROC read dir block;
+
+PROC write dir block (REAL CONST block nr):
+ write disk block and close work if error (dir block ds, 2, block nr);
+ last read dir block no := block nr.
+
+END PROC write dir block;
+
+PROC write dir block:
+ IF last read dir block no < 0.0
+ THEN error stop ("Lesefehler")
+ FI;
+ write dir block (last read dir block no)
+
+END PROC write dir block;
+
+PROC get dir entry (TEXT VAR entry buffer, INT CONST block entry no):
+ (* 0 <= block entry no <= 15 *)
+ entry buffer := 32 * ".";
+ INT CONST replace offset := 4 * block entry no;
+ replace (entry buffer, 1, dir block.daten [replace offset + 1]);
+ replace (entry buffer, 2, dir block.daten [replace offset + 2]);
+ replace (entry buffer, 3, dir block.daten [replace offset + 3]);
+ replace (entry buffer, 4, dir block.daten [replace offset + 4]).
+
+END PROC get dir entry;
+
+PROC put dir entry (TEXT CONST entry buffer, INT CONST block entry no):
+ (* 0 <= block entry no <= 15 *)
+ INT CONST offset := 4 * block entry no;
+ dir block.daten [offset + 1] := entry buffer RSUB 1;
+ dir block.daten [offset + 2] := entry buffer RSUB 2;
+ dir block.daten [offset + 3] := entry buffer RSUB 3;
+ dir block.daten [offset + 4] := entry buffer RSUB 4.
+
+END PROC put dir entry;
+
+(*-------------------------------------------------------------------------*)
+
+LET DIRPOS = REAL; (* 16.0 * msdos block nr + entry no *)
+ (* 0 <= entry no <= 15 *)
+
+DIRPOS PROC dirpos (REAL CONST block nr, INT CONST entry nr):
+ block nr * 16.0 + real (entry nr).
+
+END PROC dir pos;
+
+REAL PROC block no (DIRPOS CONST p):
+ floor (p / 16.0)
+
+END PROC block no;
+
+INT PROC entry no (DIRPOS CONST p):
+ int (p MOD 16.0)
+
+END PROC entry no;
+
+PROC incr (DIRPOS VAR p):
+ p INCR 1.0.
+
+END PROC incr;
+
+(*-------------------------------------------------------------------------*)
+
+LET FREELIST = STRUCT (ROW max dir entrys DIRPOS stack,
+ INT stacktop,
+ DIRPOS begin of free area,
+ end of dir,
+ REAL dir root); (* erste Clusterno, 0 für Main Dir *)
+
+PROC init free list (FREELIST VAR flist, REAL CONST root):
+ flist.stacktop := 0;
+ flist.begin of free area := dir pos (9.0e99, 0);
+ flist.end of dir := dir pos (-1.0, 0);
+ flist.dir root := root.
+
+END PROC init free list;
+
+PROC store (FREELIST VAR flist, DIRPOS CONST free pos):
+ flist.stacktop INCR 1;
+ flist.stack [flist.stack top] := free pos.
+
+END PROC store;
+
+PROC store begin of free area (FREELIST VAR flist, DIRPOS CONST begin):
+ flist.begin of free area := begin
+
+END PROC store begin of free area;
+
+PROC store end of dir (FREELIST VAR flist, DIRPOS CONST end):
+ flist.end of dir := end
+
+END PROC store end of dir;
+
+DIRPOS PROC free dirpos (FREELIST VAR flist):
+ enable stop;
+ DIRPOS VAR result;
+ IF flist.stacktop > 0
+ THEN pop
+ ELIF NOT free area empty
+ THEN first of free area
+ ELIF expansion alloweded
+ THEN allocate new dir cluster;
+ result := free dirpos (flist)
+ ELSE error stop ("Directory voll")
+ FI;
+ result.
+
+pop:
+ result := flist.stack [flist.stacktop];
+ flist.stacktop DECR 1.
+
+free area empty:
+ flist.begin of free area > flist.end of dir.
+
+first of free area:
+ result := flist.begin of free area;
+ incr (flist.begin of free area).
+
+expansion alloweded:
+ flist.dir root >= 2.0.
+
+allocate new dir cluster:
+ REAL CONST new dir cluster :: available fat entry;
+ REAL VAR last entry no;
+ search last entry no of fat chain;
+ fat entry (new dir cluster, last fat chain entry);
+ fat entry (last entry no, new dir cluster);
+ write fat;
+ store begin of free area (flist, dir pos (first new block, 0));
+ store end of dir (flist, dir pos (last new block, 15));
+ init new dir cluster.
+
+search last entry no of fat chain:
+ last entry no := flist.dir root;
+ WHILE NOT is last fat chain entry (fat entry (last entry no)) REP
+ last entry no := fat entry (last entry no)
+ PER.
+
+first new block:
+ begin of cluster (new dir cluster).
+
+last new block:
+ begin of cluster (new dir cluster) + real (sectors per cluster - 1).
+
+init new dir cluster:
+ TEXT CONST empty dir entry :: 32 * ""0"";
+ INT VAR i;
+ FOR i FROM 0 UPTO 15 REP
+ put dir entry (empty dir entry, i)
+ PER;
+ disable stop;
+ REAL VAR block no := first new block;
+ WHILE block no <= last new block REP
+ write dir block (block no)
+ PER.
+
+END PROC free dirpos;
+
+(*-------------------------------------------------------------------------*)
+
+LET FILEENTRY = STRUCT (TEXT date and time,
+ REAL size,
+ first cluster,
+ DIRPOS dirpos),
+
+ FILELIST = STRUCT (THESAURUS thes,
+ ROW max dir entrys FILEENTRY entry);
+
+PROC init file list (FILELIST VAR flist):
+ flist.thes := empty thesaurus.
+
+END PROC init file list;
+
+PROC store file entry (FILELIST VAR flist, TEXT CONST entry text, DIRPOS CONST position):
+ INT VAR entry index;
+ insert (flist.thes, file name, entry index);
+ store file entry (flist.entry [entry index], entry text, position).
+
+file name:
+ TEXT CONST name pre :: compress (subtext (entry text, 1, 8)),
+ name post :: compress (subtext (entry text, 9, 11));
+ IF name post <> ""
+ THEN name pre + "." + name post
+ ELSE name pre
+ FI.
+
+END PROC store file entry;
+
+PROC store file entry (FILEENTRY VAR fentry, TEXT CONST entry text, DIRPOS CONST position):
+ fentry.first cluster := real (entry text ISUB 14);
+ fentry.date and time := dos date + " " + dos time;
+ fentry.size := dint (entry text ISUB 15, entry text ISUB 16);
+ fentry.dirpos := position.
+
+dos date:
+ day + "." + month + "." + year.
+
+day:
+ text2 (code (entry text SUB 25) MOD 32).
+
+month:
+ text2 (code (entry text SUB 25) DIV 32 + 8 * (code (entry text SUB 26) MOD 2)).
+
+year:
+ text (80 + code (entry text SUB 26) DIV 2, 2).
+
+dos time:
+ hour + ":" + minute.
+
+hour:
+ text2 (code (entry text SUB 24) DIV 8).
+
+minute:
+ text2 (code (entry text SUB 23) DIV 32 + 8 * (code (entry text SUB 24) MOD 8)).
+
+END PROC store file entry;
+
+TEXT PROC text2 (INT CONST intvalue):
+ IF intvalue < 10
+ THEN "0" + text (intvalue)
+ ELSE text (int value)
+ FI.
+
+END PROC text2;
+
+DIRPOS PROC file entry pos (FILELIST CONST flist, TEXT CONST file name):
+ INT CONST link index :: link (flist.thes, file name);
+ IF link index = 0
+ THEN error stop ("Die Datei """ + file name + """ gibt es nicht")
+ FI;
+ flist.entry [link index].dir pos.
+
+END PROC file entry pos;
+
+PROC delete (FILELIST VAR flist, TEXT CONST file name):
+ INT VAR dummy;
+ delete (flist.thes, file name, dummy).
+
+END PROC delete;
+
+PROC file info (FILELIST CONST flist, TEXT CONST file name, REAL VAR first cluster no, storage):
+ INT CONST link index :: link (flist.thes, file name);
+ IF link index = 0
+ THEN error stop ("Die Datei """ + file name + """ gibt es nicht")
+ FI;
+ first cluster no := flist.entry [link index].first cluster;
+ storage := flist.entry [link index].size
+
+END PROC file info;
+
+BOOL PROC contains (FILELIST VAR flist, TEXT CONST file name):
+ flist.thes CONTAINS file name
+
+END PROC contains;
+
+PROC list (FILE VAR f, FILELIST CONST flist):
+ INT VAR index := 0;
+ TEXT VAR name;
+ get (flist.thes, name, index);
+ WHILE index > 0 REP
+ list file;
+ get (flist.thes, name, index)
+ PER.
+
+list file:
+ write (f, centered name);
+ write (f, " ");
+ write (f, text (flist.entry [index].size, 11, 0));
+ write (f, " Bytes belegt ");
+ write (f, flist.entry [index].date and time);
+(*COND TEST*)
+ write (f, " +++ ");
+ write (f, text (flist.entry [index].first cluster));
+(*ENDCOND*)
+ line (f).
+
+centered name:
+ INT VAR point pos := pos (name, ".");
+ IF point pos > 0
+ THEN name pre + "." + name post
+ ELSE text (name, 12)
+ FI.
+
+name pre:
+ text (subtext (name, 1, point pos - 1), 8).
+
+name post:
+ text (subtext (name, point pos + 1, point pos + 4), 3).
+
+END PROC list;
+
+(*-------------------------------------------------------------------------*)
+
+LET DIRENTRY = REAL,
+
+ DIRLIST = STRUCT (THESAURUS thes,
+ ROW max dir entrys DIRENTRY entry);
+
+PROC init dir list (DIRLIST VAR dlist):
+ dlist.thes := empty thesaurus.
+
+END PROC init dir list;
+
+PROC store subdir entry (DIRLIST VAR dlist, TEXT CONST entry text):
+ INT VAR entry index;
+ insert (dlist.thes, subdir name, entry index);
+ dlist.entry [entry index] := real (entry text ISUB 14).
+
+subdir name:
+ TEXT CONST name pre :: compress (subtext (entry text, 1, 8)),
+ name post :: compress (subtext (entry text, 9, 11));
+ IF name post <> ""
+ THEN name pre + "." + name post
+ ELSE name pre
+ FI.
+
+END PROC store subdir entry;
+
+REAL PROC first cluster of subdir (DIRLIST CONST dlist, TEXT CONST name):
+ INT CONST link index := link (dlist.thes, name);
+ IF link index = 0
+ THEN error stop ("Das Unterverzeichnis """ + name + """ gibt es nicht")
+ FI;
+ dlist.entry [link index].
+
+END PROC first cluster of subdir;
+
+BOOL PROC contains (DIRLIST CONST dlist, TEXT CONST subdir name):
+ dlist.thes CONTAINS subdir name
+
+END PROC contains;
+
+PROC list (FILE VAR f, DIRLIST CONST dlist):
+ INT VAR index := 0;
+ TEXT VAR name;
+ get (dlist.thes, name, index);
+ WHILE index > 0 REP
+ list dir;
+ get (dlist.thes, name, index)
+ PER.
+
+list dir:
+ write (f, centered name);
+ write (f, " <DIR>");
+(*COND TEST*)
+ write (f, " +++ ");
+ write (f, text (dlist.entry [index]));
+(*ENDCOND*)
+ line (f).
+
+centered name:
+ INT VAR point pos := pos (name, ".");
+ IF point pos > 0
+ THEN name pre + "." + name post
+ ELSE text (name, 12)
+ FI.
+
+name pre:
+ text (subtext (name, 1, point pos - 1), 8).
+
+name post:
+ text (subtext (name, point pos + 1, point pos + 4), 3).
+
+END PROC list;
+
+(*-------------------------------------------------------------------------*)
+
+LET DIR = BOUND STRUCT (FILELIST filelist,
+ DIRLIST dirlist,
+ FREELIST freelist,
+ TEXT path);
+
+DIR VAR dir;
+DATASPACE VAR dir ds;
+INITFLAG VAR dir ds used := FALSE;
+
+PROC open dir (TEXT CONST path string):
+ init dir block io;
+ init dir ds;
+ dir.path := path string;
+ load main dir;
+ TEXT VAR rest path := path string;
+ WHILE rest path <> "" REP
+ TEXT CONST sub dir name := next sub dir name (rest path);
+ load sub dir
+ PER.
+
+load main dir:
+ init file list (dir.filelist);
+ init dir list (dir.dirlist);
+ init free list (dir.free list, 0.0);
+ store end of dir (dir.freelist, dirpos (last main dir sector, 15));
+ BOOL VAR was last dir sector := FALSE;
+ REAL VAR block no := first main dir sector;
+ INT VAR i;
+ FOR i FROM 1 UPTO dir sectors REP
+ load dir block (block no, was last dir sector);
+ block no INCR 1.0
+ UNTIL was last dir sector
+ PER.
+
+first main dir sector:
+ real (begin of dir).
+
+last main dir sector:
+ real (begin of dir + dir sectors - 1).
+
+load sub dir:
+ REAL VAR cluster no := first cluster of sub dir (dir.dirlist, sub dir name);
+ was last dir sector := FALSE;
+ init file list (dir.filelist);
+ init dir list (dir.dirlist);
+ init free list (dir.free list, cluster no);
+ WHILE NOT is last fat chain entry (cluster no) REP
+ load sub dir entrys of cluster;
+ cluster no := fat entry (cluster no)
+ UNTIL was last dir sector
+ PER.
+
+load sub dir entrys of cluster:
+ store end of dir (dir.freelist, dirpos (last block no of cluster, 15));
+ block no := begin of cluster (cluster no);
+ FOR i FROM 1 UPTO sectors per cluster REP
+ load dir block (block no, was last dir sector);
+ block no INCR 1.0
+ UNTIL was last dir sector
+ PER.
+
+last block no of cluster:
+ begin of cluster (cluster no) + real (sectors per cluster - 1).
+
+END PROC open dir;
+
+PROC load dir block (REAL CONST block no, BOOL VAR was last block):
+ was last block := FALSE;
+ read dir block (block no);
+ INT VAR entry no;
+ TEXT VAR entry;
+ FOR entry no FROM 0 UPTO 15 REP
+ get dir entry (entry, entry no);
+ process entry
+ UNTIL was last block
+ PER.
+
+process entry:
+ SELECT pos (""0"."229"", entry SUB 1) OF
+ CASE 1: end of dir search
+ CASE 2: (* root des aktuellen directorys oder des übergeordneten, also nichts tun *)
+ CASE 3: free entry
+ OTHERWISE volume label or file entry or subdir entry
+ END SELECT.
+
+end of dir search:
+ was last block := TRUE;
+ store begin of free area (dir.freelist, dir pos (block no, entry no)).
+
+free entry:
+ store (dir.freelist, dir pos (block no, entry no)).
+
+volume label or file entry or subdir entry:
+ INT CONST byte 11 :: code (entry SUB 12);
+ IF (byte 11 AND 8) > 0
+ THEN (* volume label *)
+ ELIF (byte 11 AND 16) > 0
+ THEN sub dir entry
+ ELSE file entry
+ FI.
+
+sub dir entry:
+ store subdir entry (dir.dir list, entry).
+
+file entry:
+ store file entry (dir.file list, entry, dir pos (block no, entry no)).
+
+END PROC load dir block;
+
+TEXT PROC next subdir name (TEXT VAR path string):
+ TEXT VAR subdir name;
+ IF (path string SUB 1) <> "\"
+ THEN error stop ("ungültige Pfadbezeichnung")
+ FI;
+ INT CONST backslash pos :: pos (path string, "\", 2);
+ IF backslash pos = 0
+ THEN subdir name := subtext (path string, 2);
+ path string := ""
+ ELSE subdir name := subtext (path string, 2, backslash pos - 1);
+ path string := subtext (path string, backslash pos)
+ FI;
+ dos name (subdir name, read modus).
+
+END PROC next subdir name;
+
+PROC init dir ds:
+ IF initialized (dir ds used)
+ THEN forget (dir ds)
+ FI;
+ dir ds := nilspace;
+ dir := dir ds.
+
+END PROC init dir ds;
+
+PROC insert dir entry (TEXT CONST name, REAL CONST start cluster, storage):
+ DIRPOS CONST ins pos :: free dirpos (dir.free list);
+ TEXT CONST entry string :: entry name + ""32"" + (10 * ""0"") + dos time +
+ dos date + entry start cluster + entry storage;
+ write entry on disk;
+ write entry in dir ds.
+
+entry name:
+ INT CONST point pos := pos (name, ".");
+ IF point pos > 0
+ THEN subtext (name, 1, point pos - 1) + (9 - point pos) * " " +
+ subtext (name, point pos + 1) + (3 - LENGTH name + point pos) * " "
+ ELSE name + (11 - LENGTH name) * " "
+ FI.
+
+dos time:
+ TEXT CONST akt time :: time of day (clock (1));
+ code ((minute MOD 8) * 32) + code (8 * hour + minute DIV 8).
+
+hour:
+ int (subtext (akt time, 1, 2)).
+
+minute:
+ int (subtext (akt time, 4, 5)).
+
+dos date:
+ TEXT CONST akt date :: date (clock (1));
+ code (32 * (month MOD 8) + day) + code ((year - 80) * 2 + month DIV 8).
+
+day:
+ int (subtext (akt date, 1, 2)).
+
+month:
+ int (subtext (akt date, 4, 5)).
+
+year:
+ int (subtext (akt date, 7, 8)).
+
+entry start cluster:
+ TEXT VAR buffer2 := "12";
+ replace (buffer2, 1, low word (start cluster));
+ buffer2.
+
+entry storage:
+ TEXT VAR buffer4 := "1234";
+ replace (buffer4, 1, low word (storage));
+ replace (buffer4, 2, high word (storage));
+ buffer4.
+
+write entry on disk:
+ read dir block (block no (ins pos));
+ put dir entry (entry string, entry no (ins pos));
+ write dir block.
+
+write entry in dir ds:
+ store file entry (dir.file list, entry string, ins pos).
+
+END PROC insert dir entry;
+
+PROC delete dir entry (TEXT CONST name):
+ TEXT VAR entry;
+ DIRPOS CONST del pos :: file entry pos (dir.filelist, name);
+ read dir block (block no (del pos));
+ get dir entry (entry, entry no (del pos));
+ put dir entry (""229"" + subtext (entry, 2, 32), entry no (del pos));
+ write dir block;
+ delete (dir.filelist, name);
+ store (dir.freelist, del pos).
+
+END PROC delete dir entry;
+
+PROC format dir:
+ init dir block io;
+ init dir ds;
+ build empty dir block;
+ REAL VAR block no := real (begin of dir);
+ disable stop;
+ FOR i FROM 1 UPTO dir sectors REP
+ write dir block (block no);
+ block no INCR 1.0
+ PER;
+ enable stop;
+ dir.path := "";
+ init file list (dir.file list);
+ init dir list (dir.dir list);
+ init free list (dir.free list, 0.0);
+ store begin of free area (dir.free list, dir pos (real (begin of dir), 0));
+ store end of dir (dir.free list, dir pos (last main dir sector, 15)).
+
+build empty dir block:
+ INT VAR i;
+ FOR i FROM 0 UPTO 15 REP
+ put dir entry (32 * ""0"", i)
+ PER.
+
+last main dir sector:
+ real (begin of dir + dir sectors - 1).
+
+END PROC format dir;
+
+PROC file info (TEXT CONST file name, REAL VAR start cluster, size):
+ file info (dir.file list, file name, start cluster, size)
+
+END PROC file info;
+
+THESAURUS PROC all files:
+ THESAURUS VAR t := dir.filelist.thes;
+ t
+
+END PROC all files;
+
+THESAURUS PROC all subdirs:
+ dir.dirlist.thes
+
+END PROC all subdirs;
+
+BOOL PROC file exists (TEXT CONST file name):
+ contains (dir.filelist, file name)
+
+END PROC file exists;
+
+BOOL PROC subdir exists (TEXT CONST subdir name):
+ contains (dir.dirlist, subdir name)
+
+END PROC subdir exists;
+
+PROC dir list (DATASPACE VAR ds):
+ open list file;
+ head line (list file, list file head);
+ list (list file, dir.file list);
+ list (list file, dir.dir list).
+
+open list file:
+ forget (ds);
+ ds := nilspace;
+ FILE VAR list file := sequential file (output, ds);
+ putline (list file, "").
+
+list file head:
+ "DOS" + path string.
+
+path string:
+ IF dir.path <> ""
+ THEN " PATH: " + dir.path
+ ELSE ""
+ FI.
+
+END PROC dir list;
+
+END PACKET dir;
+
diff --git a/system/dos/1.8.7/src/disk descriptor.dos b/system/dos/1.8.7/src/disk descriptor.dos
new file mode 100644
index 0000000..0b0d7fc
--- /dev/null
+++ b/system/dos/1.8.7/src/disk descriptor.dos
@@ -0,0 +1,339 @@
+PACKET dos disk DEFINES (* Copyright (C) 1986, 87 *)
+ (* Frank Klapper *)
+ (* Referenz: 3-22 *) (* 11.09.87 *)
+
+ open dos disk,
+
+ sectors per cluster,
+ fat copies,
+ dir sectors,
+ media descriptor,
+ fat sectors,
+
+ begin of fat,
+ fat entrys,
+ begin of dir,
+ begin of cluster,
+ cluster size,
+
+ bpb exists,
+ write bpb,
+
+ eu block,
+
+ bpb dump modus:
+
+INITFLAG VAR bpb ds initialisiert := FALSE;
+DATASPACE VAR bpb ds;
+BOUND STRUCT (ALIGN dummy, ROW 512 INT daten) VAR bpb;
+
+BOOL VAR bpb dump flag := FALSE;
+
+REAL VAR begin of data area;
+INT VAR sectors per track,
+ heads;
+
+IF exists ("shard interface")
+ THEN load shard interface table
+FI;
+
+TEXT CONST bpb type 254 :: ""00""00""00"" +
+ ""69""85""77""69""76""66""80""66"" +
+ ""00""02"" +
+ ""01"" +
+ ""01""00"" +
+ ""02"" +
+ ""64""00"" +
+ ""64""01"" +
+ ""254"" +
+ ""01""00"" +
+ ""08""00"" +
+ ""01""00"" +
+ ""00""00"",
+ bpb type 255 :: ""00""00""00"" +
+ ""69""85""77""69""76""66""80""66"" +
+ ""00""02"" +
+ ""02"" +
+ ""01""00"" +
+ ""02"" +
+ ""112""00"" +
+ ""128""02"" +
+ ""255"" +
+ ""01""00"" +
+ ""08""00"" +
+ ""02""00"" +
+ ""00""00"";
+
+PROC open dos disk:
+ enable stop;
+ bpb ds an bound koppeln;
+ bpb lesen;
+ IF bpb ungueltig
+ THEN versuche pseudo bpb zu verwenden
+ FI;
+ ueberpruefe bpb auf gueltigkeit;
+ globale variablen initialisieren;
+ IF bpb dump flag
+ THEN dump schreiben
+ FI.
+
+bpb ds an bound koppeln:
+ IF NOT initialized (bpb ds initialisiert)
+ THEN bpb ds := nilspace;
+ bpb := bpb ds
+ FI.
+
+bpb lesen:
+ INT VAR return;
+ check rerun;
+ read block (bpb ds, 2, 0, return);
+ IF return <> 0
+ THEN lesefehler (return)
+ FI.
+
+bpb ungueltig:
+ (* Byte 12 = Byte 13 = ... = Byte 23 <==> Word 6 = ... = Word 11 *)
+ INT VAR word no;
+ FOR word no FROM 6 UPTO 10 REP
+ IF bpb.daten [word no + 1] <> bpb.daten [word no + 2]
+ THEN LEAVE bpb ungueltig WITH FALSE
+ FI
+ PER;
+ TRUE.
+
+versuche pseudo bpb zu verwenden:
+ lies ersten fat sektor;
+ IF fat sektor gueltig und pseudo bpb vorhanden
+ THEN pseudo bpb laden
+ ELSE error stop ("Format unbekannt")
+ FI.
+
+lies ersten fat sektor:
+ (* da der bpb in diesem Fall ungültig, lese ich den fat sektor in den bpb
+ Datenraum *)
+ check rerun;
+ read block (bpb ds, 2, 1, return);
+ IF return <> 0
+ THEN lesefehler (return)
+ FI.
+
+fat sektor gueltig und pseudo bpb vorhanden:
+ TEXT VAR fat start := "1234";
+ replace (fat start, 1, bpb.daten [1]);
+ replace (fat start, 2, bpb.daten [2]);
+ (fat start SUB 2) = ""255"" CAND (fat start SUB 3) = ""255"" CAND
+ pseudo bpb vorhanden.
+
+pseudo bpb vorhanden:
+ pos (""254""255"", fat start SUB 1) > 0.
+
+pseudo bpb laden:
+ INT VAR i;
+ FOR i FROM 1 UPTO 15 REP
+ bpb.daten [i] := bpb puffer ISUB i
+ PER.
+
+bpb puffer:
+ IF pseudo bpb name = ""255""
+ THEN bpb type 255
+ ELSE bpb type 254
+ FI.
+
+pseudo bpb name:
+ fat start SUB 1.
+
+ueberpruefe bpb auf gueltigkeit:
+ IF bytes per sector <> 512
+ THEN error stop ("DOS Format nicht implementiert (unzulässige Sektorgröße)")
+ FI;
+ IF (fat sectors > 64)
+ THEN error stop ("ungültige DOS Disk (BPB)")
+ FI.
+
+globale variablen initialisieren:
+ sectors per track := bpb byte (25) * 256 + bpb byte (24);
+ heads := bpb byte (27) * 256 + bpb byte (26);
+ begin of data area := real (reserved sectors + fat copies * fat sectors + dir sectors).
+
+dump schreiben:
+ dump ("Sektoren pro Cluster", sectors per cluster);
+ dump ("Fat Kopien ", fat copies);
+ dump ("Dir Sektoren ", dir sectors);
+ dump ("Media Descriptor ", media descriptor);
+ dump ("Sektoren pro Fat ", fat sectors);
+ dump ("Fat Anfang (0) ", begin of fat (0));
+ dump ("Fat Einträge ", fat entrys);
+ dump ("Dir Anfang ", begin of dir).
+
+END PROC open dos disk;
+
+PROC lesefehler (INT CONST fehler code):
+ error stop (fehlertext).
+
+fehlertext:
+ SELECT fehler code OF
+ CASE 1: "Diskettenlaufwerk nicht betriebsbereit"
+ CASE 2: "Lesefehler"
+ OTHERWISE "Lesefehler " + text (fehler code)
+ END SELECT.
+
+END PROC lesefehler;
+
+TEXT VAR konvertier puffer := "12";
+
+INT PROC bpb byte (INT CONST byte no):
+ replace (konvertier puffer, 1, bpb.daten [byte no DIV 2 + 1]);
+ code (konvertier puffer SUB puffer pos).
+
+puffer pos:
+ IF even byte no
+ THEN 1
+ ELSE 2
+ FI.
+
+even byte no:
+ (byte no MOD 2) = 0.
+
+END PROC bpb byte;
+
+INT PROC bytes per sector:
+ bpb byte (12) * 256 + bpb byte (11)
+
+END PROC bytes per sector;
+
+INT PROC sectors per cluster:
+ bpb byte (13)
+
+END PROC sectors per cluster;
+
+INT PROC reserved sectors:
+ bpb byte (15) * 256 + bpb byte (14)
+
+END PROC reserved sectors;
+
+INT PROC fat copies:
+ bpb byte (16)
+
+END PROC fat copies;
+
+INT PROC dir sectors:
+ dir entrys DIV dir entrys per sector.
+
+dir entrys:
+ bpb byte (18) * 256 + bpb byte (17).
+
+dir entrys per sector:
+ 16.
+
+END PROC dir sectors;
+
+REAL PROC dos sectors:
+ real (bpb byte (20)) * 256.0 + real (bpb byte (19))
+
+END PROC dos sectors;
+
+INT PROC media descriptor:
+ bpb byte (21)
+
+END PROC media descriptor;
+
+INT PROC fat sectors:
+ bpb byte (23) * 256 + bpb byte (22)
+
+END PROC fat sectors;
+
+INT PROC begin of fat (INT CONST fat copy no):
+ (* 0 <= fat copy no <= fat copies - 1 *)
+ reserved sectors + fat copy no * fat sectors
+
+END PROC begin of fat;
+
+INT PROC fat entrys:
+ anzahl daten cluster + 2.
+
+anzahl daten cluster:
+ int ((dos sectors - tabellen sektoren) / real (sectors per cluster)).
+
+tabellen sektoren:
+ real (reserved sectors + fat copies * fat sectors + dir sectors).
+
+END PROC fat entrys;
+
+INT PROC begin of dir:
+ reserved sectors + fat copies * fat sectors.
+
+END PROC begin of dir;
+
+REAL PROC begin of cluster (REAL CONST cluster no):
+ begin of data area + (cluster no - 2.0) * real (sectors per cluster)
+
+END PROC begin of cluster;
+
+INT PROC cluster size:
+ 512 * sectors per cluster
+
+END PROC cluster size;
+
+BOOL PROC bpb exists (INT CONST no):
+
+ exists ("bpb ds") AND no > 0 AND no < 4.
+
+END PROC bpb exists;
+
+PROC write bpb (INT CONST no):
+ INT VAR return;
+ write block (old ("bpb ds"), no + 1, 0, 0, return);
+ IF return <> 0
+ THEN error stop ("Schreibfehler")
+ FI.
+
+END PROC write bpb;
+
+(* Da DOS-Partitionen maximal 32 MByte groß sein können, können die Blocknummern
+ durch 16 BIT unsigned Integer dargestellt werden. Die Werte die die 'eublock'-
+ Prozeduren liefern sind als solche zu verstehen *)
+
+INT PROC eu block (INT CONST dos block no):
+ IF hd version
+ THEN dos block no
+ ELSE dos block no floppy format
+ FI.
+
+dos block no floppy format:
+ IF page format
+ THEN head * eu sectors per head + trac * eu sectors + sector
+ ELSE head * eu sectors + trac * abs (eu heads) * eu sectors + sector
+ FI.
+
+page format:
+ eu heads < 0.
+
+sector:
+ dos block no MOD sectors per track.
+
+trac:
+ (dos block no DIV sectors per track) DIV heads.
+
+head:
+ (dos block no DIV sectors per track) MOD heads.
+
+eu sectors per head:
+ eu sectors * eu tracks.
+
+eu sectors:
+ eu last sector - eu first sector + 1.
+
+END PROC eu block;
+
+INT PROC eu block (REAL CONST dos block no):
+ eublock (low word (dos block no)).
+
+END PROC eublock;
+
+PROC bpb dump modus (BOOL CONST status):
+ bpb dump flag := status
+
+END PROC bpb dump modus;
+
+END PACKET dos disk;
+
diff --git a/system/dos/1.8.7/src/dos hd inserter b/system/dos/1.8.7/src/dos hd inserter
new file mode 100644
index 0000000..24be82b
--- /dev/null
+++ b/system/dos/1.8.7/src/dos hd inserter
@@ -0,0 +1,41 @@
+IF NOT single user
+ THEN do ("IF name (myself) <> ""DOS HD"" THEN error stop (""Bitte der Task den Namen 'DOS HD' geben und neu starten"") FI");
+FI;
+
+archive ("austausch");
+check off;
+command dialogue (FALSE);
+fetch ("insert.dos", archive);
+fetch ("bpb ds", archive);
+IF single user
+ THEN do (PROC (TEXT CONST) gen s, ALL "insert.dos");
+ gen s ("manager/S.dos")
+ ELSE fetch (ALL "insert.dos", archive);
+ fetch ("manager/M.dos", archive);
+ release (archive);
+ do (PROC (TEXT CONST) gen m, ALL "insert.dos");
+ gen m ("manager/M.dos");
+FI;
+do ("hd version (TRUE)");
+forget ("insert.dos", quiet);
+forget ("dos hd inserter", quiet);
+IF NOT single user
+ THEN do ("dos manager (29)")
+FI.
+
+single user:
+ (pcb (9) AND 255) = 1.
+
+PROC gen m (TEXT CONST name):
+ insert (name);
+ forget (name, quiet)
+
+END PROC gen m;
+
+PROC gen s (TEXT CONST t):
+ fetch (t, archive);
+ insert (t);
+ forget (t, quiet)
+
+END PROC gen s;
+
diff --git a/system/dos/1.8.7/src/dos inserter b/system/dos/1.8.7/src/dos inserter
new file mode 100644
index 0000000..2f70b28
--- /dev/null
+++ b/system/dos/1.8.7/src/dos inserter
@@ -0,0 +1,59 @@
+IF NOT single user
+ THEN do ("IF name (myself) <> ""DOS"" THEN error stop (""Bitte der Task den Namen 'DOS' geben und neu starten"") FI");
+FI;
+
+archive ("austausch");
+check off;
+command dialogue (FALSE);
+hol ("shard interface");
+hol ("bpb ds");
+hol ("insert.dos");
+IF single user
+ THEN do (PROC (TEXT CONST) gen s, ALL "insert.dos");
+ gen s ("manager/S.dos")
+ ELSE do (PROC (TEXT CONST) hol, ALL "insert.dos");
+ hol ("manager/M.dos");
+ release (archive);
+ do (PROC (TEXT CONST) gen m, ALL "insert.dos");
+ gen m ("manager/M.dos");
+ putline ("jetzt mit 'dos manager' bzw. 'dos manager (channnel)' starten");
+FI;
+do ("hd version (FALSE)");
+do ("load shard interface table");
+forget ("shard interface", quiet);
+forget ("insert.dos", quiet);
+forget ("dos inserter", quiet).
+
+single user:
+ (pcb (9) AND 255) = 1.
+
+PROC gen m (TEXT CONST name):
+ insert (name);
+ forget (name, quiet)
+
+END PROC gen m;
+
+PROC gen s (TEXT CONST t):
+ hol (t);
+ insert (t);
+ forget (t, quiet)
+
+END PROC gen s;
+
+PROC hol (TEXT CONST t):
+ IF NOT exists (t)
+ THEN fetch (t, archive)
+ FI
+
+END PROC hol;
+
+
+
+
+
+
+
+
+
+
+
diff --git a/system/dos/1.8.7/src/dump b/system/dos/1.8.7/src/dump
new file mode 100644
index 0000000..5138162
--- /dev/null
+++ b/system/dos/1.8.7/src/dump
@@ -0,0 +1,49 @@
+PACKET dump DEFINES
+
+ dump:
+
+TEXT VAR ergebnis := "";
+
+PROC dump (TEXT CONST kommentar, dump text):
+ ergebnis := kommentar;
+ ergebnis CAT ": ";
+ INT VAR i;
+ FOR i FROM 1 UPTO LENGTH dump text REP
+ zeichen schreiben
+ PER;
+ ergebnis schreiben.
+
+zeichen schreiben:
+ INT CONST char code :: code (dump text SUB i);
+ IF char code < 32
+ THEN ergebnis CAT ("$" + text (char code) + "$")
+ ELSE ergebnis CAT code (char code)
+ FI.
+
+END PROC dump;
+
+PROC dump (TEXT CONST kommentar, INT CONST dump int):
+ ergebnis := kommentar;
+ ergebnis CAT ": ";
+ ergebnis CAT text (dump int);
+ ergebnis schreiben.
+
+END PROC dump;
+
+PROC dump (TEXT CONST kommentar, REAL CONST dump real):
+ ergebnis := kommentar;
+ ergebnis CAT ": ";
+ ergebnis CAT text (dump real);
+ ergebnis schreiben.
+
+END PROC dump;
+
+PROC ergebnis schreiben:
+ FILE VAR f := sequential file (output, "logbuch");
+ putline (f, ergebnis);
+ ergebnis := "".
+
+END PROC ergebnis schreiben;
+
+END PACKET dump;
+
diff --git a/system/dos/1.8.7/src/eu disk descriptor b/system/dos/1.8.7/src/eu disk descriptor
new file mode 100644
index 0000000..5a61367
--- /dev/null
+++ b/system/dos/1.8.7/src/eu disk descriptor
@@ -0,0 +1,107 @@
+PACKET eu disk DEFINES (* Copyright (C) 1986, 87 *)
+ (* Frank Klapper *)
+ (* 05.01.87 *)
+ load shard interface table,
+ open eu disk,
+ eu size,
+ eu heads,
+ eu tracks,
+ eu first sector,
+ eu last sector:
+
+LET table length = 15,
+
+ size field = 1,
+ head field = 2,
+ track field = 3,
+ first sector field = 4,
+ last sector field = 5;
+
+ROW table length ROW 5 INT VAR format table;
+
+INT VAR table top := 0,
+ table pointer;
+
+PROC open eu disk:
+ enable stop;
+ init check rerun;
+ IF hd version
+ THEN LEAVE open eu disk
+ FI;
+ INT CONST blocks := archive blocks;
+ IF blocks <= 0
+ THEN error stop ("keine Diskette eingelegt")
+ FI;
+ search format table entry.
+
+search format table entry:
+ IF table top < 1
+ THEN error stop ("SHard-Interfacetabelle nicht geladen")
+ FI;
+ table pointer := 1;
+ WHILE format table [table pointer][size field] <> blocks REP
+ table pointer INCR 1;
+ IF table pointer > table top
+ THEN error stop ("Diskettenformat nicht implementiert")
+ FI
+ PER.
+
+END PROC open eu disk;
+
+PROC load shard interface table:
+ FILE VAR f := sequential file (input, "shard interface");
+ TEXT VAR line;
+ table top := 0;
+ WHILE NOT eof (f) REP
+ get line (f, line);
+ IF (line SUB 1) <> ";"
+ THEN load line
+ FI
+ PER.
+
+load line:
+ table top INCR 1;
+ IF table top > table length
+ THEN error stop ("Shard Interface Tabelle zu groß")
+ FI;
+ INT VAR blank pos := 1;
+ format table [table top][size field] := next int;
+ format table [table top][head field] := next int;
+ format table [table top][track field] := next int;
+ format table [table top][first sector field] := next int;
+ format table [table top][last sector field] := next int.
+
+next int:
+ line := compress (subtext (line, blank pos)) + " ";
+ blank pos := pos (line, " ");
+ int (subtext (line, 1, blank pos - 1)).
+
+END PROC load shard interface table;
+
+INT PROC eu size:
+ format table [table pointer][size field]
+
+END PROC eu size;
+
+INT PROC eu heads:
+ format table [table pointer][head field]
+
+END PROC eu heads;
+
+INT PROC eu tracks:
+ format table [table pointer][track field]
+
+END PROC eu tracks;
+
+INT PROC eu first sector:
+ format table [table pointer][first sector field]
+
+END PROC eu first sector;
+
+INT PROC eu last sector:
+ format table [table pointer][last sector field]
+
+END PROC eu last sector;
+
+END PACKET eu disk;
+
diff --git a/system/dos/1.8.7/src/fat.dos b/system/dos/1.8.7/src/fat.dos
new file mode 100644
index 0000000..2890b1a
--- /dev/null
+++ b/system/dos/1.8.7/src/fat.dos
@@ -0,0 +1,369 @@
+PACKET dos fat DEFINES (* Copyright (C) 1985, 86, 87 *)
+ (* Frank Klapper *)
+ (* 11.09.87 *)
+ read fat,
+ write fat,
+ first fat block ok,
+ clear fat ds,
+ format fat,
+
+ fat entry,
+ last fat chain entry,
+ is last fat chain entry,
+ erase fat chain,
+ available fat entry:
+
+ (* Referenz: 4. *)
+
+LET fat size = 16 384, (* maximal 64 Sektoren a 512 Byte (256 Worte) *)
+ max anzahl fat sektoren = 64;
+
+LET FAT = BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block row, (* für Kopie des 1. Fatsektors *)
+ ROW fat size INT fat row);
+
+DATASPACE VAR fat ds;
+INITFLAG VAR fat ds used := FALSE;
+FAT VAR fat struktur;
+
+.fat: fat struktur.fat row.
+
+REAL VAR erster moeglicher freier eintrag;
+
+BOOL VAR kleines fat format;
+
+PROC read fat:
+ fat ds initialisieren;
+ fat bloecke lesen;
+ fat format bestimmen;
+ erster moeglicher freier eintrag := 2.0.
+
+fat ds initialisieren:
+ clear fat ds;
+ fat struktur := fat ds.
+
+fat bloecke lesen:
+ LET kein testblock = FALSE;
+ INT VAR block no;
+ FOR block no FROM 0 UPTO fat sectors - 1 REP
+ fat block lesen (block no, kein testblock)
+ PER.
+
+fat format bestimmen:
+ IF fat entrys <= 4086
+ THEN kleines fat format := TRUE
+ ELSE kleines fat format := FALSE
+ FI.
+
+END PROC read fat;
+
+PROC write fat:
+ disable stop;
+ INT VAR block nr;
+ FOR block nr FROM 0 UPTO fat sectors - 1 REP
+ fat block schreiben (block nr)
+ PER.
+
+END PROC write fat;
+
+BOOL PROC first fat block ok:
+ (* überprüft, ob der erste Block der Fat auf Diskette und im Speicher
+ gleich ist *)
+ enable stop;
+ LET testblock = TRUE;
+ fat block lesen (0, testblock);
+ INT VAR i;
+ FOR i FROM 1 UPTO 256 REP
+ vergleiche woerter
+ PER;
+ TRUE.
+
+vergleiche woerter:
+ IF fat [i] <> fat struktur.block row [i]
+ THEN LEAVE first fat block ok WITH FALSE
+ FI.
+
+END PROC first fat block ok;
+
+PROC clear fat ds:
+ IF initialized (fat ds used)
+ THEN forget (fat ds)
+ FI;
+ fat ds := nilspace.
+
+END PROC clear fat ds;
+
+PROC format fat:
+ fat ds initialisieren;
+ fat format bestimmen;
+ erster moeglicher freier eintrag := 2.0;
+ write first four fat bytes;
+ write other fat bytes;
+ vermerke schreibzugriffe;
+ write fat.
+
+fat ds initialisieren:
+ clear fat ds;
+ fat struktur := fat ds.
+
+fat format bestimmen:
+ IF fat entrys <= 4086
+ THEN kleines fat format := TRUE
+ ELSE kleines fat format := FALSE
+ FI.
+
+write first four fat bytes:
+ fat [1] := word (media descriptor, 255);
+ IF kleines fat format
+ THEN fat [2] := word (255, 0)
+ ELSE fat [2] := word (255, 255)
+ FI.
+
+write other fat bytes:
+ INT VAR i;
+ FOR i FROM 3 UPTO 256 * fat sectors REP
+ fat [i] := 0
+ PER.
+
+vermerke schreibzugriffe:
+ FOR i FROM 0 UPTO fat sectors - 1 REP
+ schreibzugriff (i)
+ PER.
+
+END PROC format fat;
+
+(*-------------------------------------------------------------------------*)
+
+REAL PROC fat entry (REAL CONST real entry no):
+ (* 0 <= entry no <= 22 000 *)
+ INT CONST entry no :: int (real entry no);
+ IF kleines fat format
+ THEN construct 12 bit value
+ ELSE dint (fat [entry no + 1], 0)
+ FI.
+
+construct 12 bit value:
+ INT CONST first byte no := entry no + entry no DIV 2;
+ IF entry no MOD 2 = 0
+ THEN real ((right byte MOD 16) * 256 + left byte)
+ ELSE real (right byte * 16 + left byte DIV 16)
+ FI.
+
+left byte:
+ fat byte (first byte no).
+
+right byte:
+ fat byte (first byte no + 1).
+
+END PROC fat entry;
+
+TEXT VAR convert buffer := "12";
+
+INT PROC fat byte (INT CONST no):
+ replace (convert buffer, 1, word);
+ IF even byte no
+ THEN code (convert buffer SUB 1)
+ ELSE code (convert buffer SUB 2)
+ FI.
+
+even byte no:
+ no MOD 2 = 0.
+
+word:
+ fat [no DIV 2 + 1].
+
+END PROC fat byte;
+
+PROC fat entry (REAL CONST real entry no, real value):
+ (* 0 <= entry no <= 22 000 *)
+ INT CONST entry no :: int (real entry no),
+ value :: low word (real value);
+ IF kleines fat format
+ THEN write 12 bit value
+ ELSE fat [entry no + 1] := value;
+ schreibzugriff (entry no DIV 256)
+ FI;
+ update first possible available entry.
+
+write 12 bit value:
+ INT CONST first byte no :: entry no + entry no DIV 2;
+ schreibzugriff (fat block of first byte);
+ schreibzugriff (fat block of second byte);
+ write value.
+
+fat block of first byte:
+ first byte no DIV 512.
+
+fat block of second byte:
+ second byte no DIV 512.
+
+write value:
+ IF even entry no
+ THEN write fat byte (first byte no, value MOD 256);
+ write fat byte (second byte no,
+ (right byte DIV 16) * 16 + value DIV 256)
+ ELSE write fat byte (first byte no,
+ (left byte MOD 16) + 16 * (value MOD 16));
+ write fat byte (second byte no, value DIV 16)
+ FI.
+
+even entry no:
+ entry no MOD 2 = 0.
+
+second byte no:
+ first byte no + 1.
+
+left byte:
+ fat byte (first byte no).
+
+right byte:
+ fat byte (second byte no).
+
+update first possible available entry:
+ IF value = 0
+ THEN erster moeglicher freier eintrag :=
+ min (erster moeglicher freier eintrag, real entry no)
+ FI.
+
+END PROC fat entry;
+
+PROC write fat byte (INT CONST byte no, new value):
+ read old word;
+ change byte;
+ write new word.
+
+read old word:
+ replace (convert buffer, 1, word).
+
+write new word:
+ word := convert buffer ISUB 1.
+
+word:
+ fat [byte no DIV 2 + 1].
+
+change byte:
+ replace (convert buffer, byte pos, code (new value)).
+
+byte pos:
+ byte no MOD 2 + 1.
+
+END PROC write fat byte;
+
+REAL PROC last fat chain entry:
+ IF kleines fat format
+ THEN 4 088.0
+ ELSE 65 528.0
+ FI.
+
+END PROC last fat chain entry;
+
+BOOL PROC is last fat chain entry (REAL CONST value):
+ value >= last fat chain entry
+
+END PROC is last fat chain entry;
+
+PROC erase fat chain (REAL CONST first entry no):
+ REAL VAR next entry no := first entry no,
+ act entry no := 0.0;
+ WHILE next entry exists REP
+ act entry no := next entry no;
+ next entry no := fat entry (act entry no);
+ fat entry (act entry no, 0.0)
+ PER.
+
+next entry exists:
+ NOT is last fat chain entry (next entry no).
+
+END PROC erase fat chain;
+
+REAL PROC available fat entry:
+ (* da die fat weniger als 22 000 Einträge umfaßt, kann ich diese als
+ INTEGER berechnen *)
+ INT VAR i;
+ REAL VAR real i := erster moeglicher freier eintrag;
+ FOR i FROM int (erster moeglicher freier eintrag) UPTO fat entrys - 1 REP
+ IF fat entry (real i) = 0.0
+ THEN erster moeglicher freier eintrag := real i;
+ LEAVE available fat entry WITH erster moeglicher freier eintrag
+ FI;
+ real i INCR 1.0
+ PER;
+ close work;
+ error stop ("MS-DOS Datentraeger voll");
+ 1.0e99.
+
+END PROC available fat entry;
+
+(*-------------------------------------------------------------------------*)
+
+PROC fat block lesen (INT CONST block nr, BOOL CONST test block):
+ (* 0 <= block nr <= fat sectors - 1 *)
+ disable stop;
+ IF NOT test block
+ THEN kein schreibzugriff (block nr)
+ FI;
+ INT VAR kopie nr;
+ FOR kopie nr FROM 0 UPTO fat copies - 1 REP
+ clear error;
+ read disk block (fat ds, ds seiten nr, disk block nr)
+ UNTIL NOT is error
+ PER;
+ IF is error
+ THEN close work
+ FI.
+
+ds seiten nr:
+ IF test block
+ THEN 2
+ ELSE block nr + 2 + 1
+ FI.
+
+disk block nr:
+ begin of fat (kopie nr) + block nr.
+
+END PROC fat block lesen;
+
+PROC fat block schreiben (INT CONST block nr):
+ IF war schreibzugriff (block nr)
+ THEN wirklich schreiben
+ FI.
+
+wirklich schreiben:
+ disable stop;
+ INT VAR kopie nr;
+ FOR kopie nr FROM 0 UPTO fat copies - 1 REP
+ write disk block and close work if error (fat ds, ds seiten nr, disk block nr)
+ PER;
+ kein schreibzugriff (block nr).
+
+ds seiten nr:
+ block nr + 2 + 1.
+
+disk block nr:
+ begin of fat (kopie nr) + block nr.
+
+END PROC fat block schreiben;
+
+(*-------------------------------------------------------------------------*)
+
+ROW max anzahl fat sektoren BOOL VAR schreib zugriff tabelle;
+
+PROC schreibzugriff (INT CONST fat sektor):
+ schreibzugriff tabelle [fat sektor + 1] := TRUE
+
+END PROC schreibzugriff;
+
+PROC kein schreibzugriff (INT CONST fat sektor):
+ schreibzugriff tabelle [fat sektor + 1] := FALSE
+
+END PROC kein schreibzugriff;
+
+BOOL PROC war schreibzugriff (INT CONST fat sektor):
+ schreibzugriff tabelle [fat sektor + 1]
+
+END PROC war schreibzugriff;
+
+(*-------------------------------------------------------------------------*)
+
+END PACKET dos fat;
+
diff --git a/system/dos/1.8.7/src/fetch b/system/dos/1.8.7/src/fetch
new file mode 100644
index 0000000..7cb7571
--- /dev/null
+++ b/system/dos/1.8.7/src/fetch
@@ -0,0 +1,371 @@
+PACKET fetch DEFINES (* Copyright (C) 1985, 86, 87 *)
+ (* Frank Klapper *)
+ (* 27.04.87 *)
+ fetch,
+ check file:
+
+LET ascii = 1,
+ ascii german = 2,
+ transparent = 3,
+ row text = 5,
+ ds = 6,
+ dump = 7,
+ atari st = 10,
+ ibm = 11,
+
+ (*line end chars = ""10""12""13"",*)
+ min line end char = ""10"",
+ max line end char = ""13"",
+ lf = ""10"",
+ cr = ""13"",
+ tab code = 9,
+ lf code = 10,
+ ff code = 12,
+ cr code = 13,
+ ctrl z = ""26"",
+
+ page cmd = "#page#",
+
+ row text length = 4000,
+ row text type = 1000;
+
+BOUND STRUCT (INT size,
+ ROW row text length TEXT cluster row) VAR cluster struct;
+
+FILE VAR file;
+
+TEXT VAR buffer;
+INT VAR buffer length;
+
+PROC fetch (TEXT CONST name, DATASPACE VAR file ds, INT CONST mode):
+
+ SELECT mode OF
+ CASE ascii, ascii german, atari st, ibm, transparent:
+ fetch filemode (file ds, name, mode)
+ CASE row text : fetch row textmode (file ds, name)
+ CASE ds : fetch dsmode (file ds, name)
+ CASE dump : fetch dumpmode (file ds, name)
+ OTHERWISE error stop ("Unzulässige Betriebsart")
+ END SELECT.
+
+END PROC fetch;
+
+PROC fetch filemode (DATASPACE VAR file space, TEXT CONST name,
+ INT CONST code type):
+ enable stop;
+ initialize fetch filemode;
+ open fetch dos file (name);
+ WHILE NOT was last fetch cluster REP
+ get text of cluster;
+ write lines;
+(***************************************)
+ IF lines (file) > 3900
+ THEN putline (file, ">>> FREMDDATEI FUER EUMEL ZU LANG. ES KÖNNEN DATEN FEHLEN <<<");
+ LEAVE fetch filemode
+ FI;
+(***************************************)
+ UNTIL file end via ctrl z
+ PER;
+ write last line if necessary;
+ close fetch dos file.
+
+initialize fetch filemode:
+ buffer := "";
+ buffer length := 0;
+ forget (file space);
+ file space := nilspace;
+ file := sequential file (output, file space);
+ BOOL VAR file end via ctrl z := FALSE.
+
+get text of cluster:
+ cat next fetch dos cluster (buffer);
+ IF ascii code
+ THEN ctrl z is buffer end
+ FI;
+ adapt code (buffer, buffer length + 1, code type);
+ buffer length := length (buffer).
+
+ascii code:
+ (code type = ascii) OR (code type = ascii german).
+
+ctrl z is buffer end:
+ INT CONST ctrl z pos :: pos (buffer, ctrl z, buffer length + 1);
+ file end via ctrl z := ctrl z pos > 0;
+ IF file end via ctrl z
+ THEN buffer := subtext (buffer, 1, ctrl z pos - 1);
+ buffer length := length (buffer)
+ FI.
+
+write lines:
+ INT VAR line begin pos := 1, line end pos;
+ compute line end pos;
+ WHILE line end pos > 0 REP
+ putline (file, subtext (buffer, line begin pos, line end pos));
+ exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
+ line begin pos := line end pos + 1;
+ compute line end pos
+ PER;
+ buffer := subtext (buffer, line begin pos);
+ buffer length := length (buffer);
+ IF buffer length > 5 000
+ THEN putline (file, buffer);
+ exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
+ buffer := "";
+ buffer length := 0
+ FI.
+
+compute line end pos:
+ line end pos := line begin pos;
+ REP
+ line end pos := pos (buffer, min line end char, max line end char, line end pos);
+ INT CONST line end code :: code (buffer SUB line end pos);
+ SELECT line end code OF
+ CASE lf code: look for cr
+ CASE 11 : line end pos INCR 1
+ CASE cr code: look for lf
+ END SELECT
+ UNTIL line end code <> 11
+ PER.
+
+look for cr:
+ IF line end pos = buffer length
+ THEN line end pos := 0
+ ELIF (buffer SUB line end pos + 1) = cr
+ THEN line end pos INCR 1
+ FI.
+
+look for lf:
+ IF line end pos = buffer length
+ THEN line end pos := 0
+ ELIF (buffer SUB line end pos + 1) = lf
+ THEN line end pos INCR 1
+ FI.
+
+write last line if necessary:
+ IF buffer length > 0
+ THEN putline (file, buffer);
+ exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
+ FI.
+
+END PROC fetch filemode;
+
+PROC adapt code (TEXT VAR text buffer, INT CONST start pos, code type):
+ SELECT code type OF
+ CASE ascii : cancel bit 8
+ CASE ascii german: cancel bit 8; ascii german adaption
+ CASE atari st : atari st adaption
+ CASE ibm : ibm adaption
+ (*CASE transparent : do nothing *)
+ END SELECT.
+
+cancel bit 8:
+ INT VAR set pos := pos (text buffer, ""128"", ""255"", start pos);
+ WHILE set pos > 0 REP
+ replace (text buffer, set pos, seven bit char);
+ set pos := pos (text buffer, ""128"", ""255"", set pos + 1)
+ PER.
+
+seven bit char:
+ code (code (text buffer SUB set pos) AND 127).
+
+ascii german adaption:
+ change all by replace (text buffer, start pos, "[", "Ä");
+ change all by replace (text buffer, start pos, "\", "Ö");
+ change all by replace (text buffer, start pos, "]", "Ü");
+ change all by replace (text buffer, start pos, "{", "ä");
+ change all by replace (text buffer, start pos, "|", "ö");
+ change all by replace (text buffer, start pos, "}", "ü");
+ change all by replace (text buffer, start pos, "~", "ß").
+
+atari st adaption:
+ change all by replace (text buffer, start pos, ""142"", "Ä");
+ change all by replace (text buffer, start pos, ""153"", "Ö");
+ change all by replace (text buffer, start pos, ""154"", "Ü");
+ change all by replace (text buffer, start pos, ""132"", "ä");
+ change all by replace (text buffer, start pos, ""148"", "ö");
+ change all by replace (text buffer, start pos, ""129"", "ü");
+ change all by replace (text buffer, start pos, ""158"", "ß").
+
+ibm adaption:
+ change all by replace (text buffer, start pos, ""142"", "Ä");
+ change all by replace (text buffer, start pos, ""153"", "Ö");
+ change all by replace (text buffer, start pos, ""154"", "Ü");
+ change all by replace (text buffer, start pos, ""132"", "ä");
+ change all by replace (text buffer, start pos, ""148"", "ö");
+ change all by replace (text buffer, start pos, ""129"", "ü");
+ change all by replace (text buffer, start pos, ""225"", "ß").
+
+END PROC adapt code;
+
+PROC change all by replace (TEXT VAR string, INT CONST begin pos,
+ TEXT CONST old, new):
+
+ INT VAR p := pos (string, old, begin pos);
+ WHILE p > 0 REP
+ replace (string, p, new);
+ p := pos (string, old, p + 1)
+ PER.
+
+END PROC change all by replace;
+
+PROC control char conversion (TEXT VAR string, INT CONST code type):
+
+ IF code type <> transparent
+ THEN code conversion
+ FI.
+
+code conversion:
+ INT VAR p := pos (string, ""0"", ""31"", 1);
+ WHILE p > 0 REP
+ convert char;
+ p := pos (string, ""0"", ""31"", p)
+ PER.
+
+convert char:
+ INT CONST char code := code (string SUB p);
+ SELECT char code OF
+ CASE tab code: expand tab
+ CASE lf code: change (string, p, p, "")
+ CASE ff code: change (string, p, p, page cmd)
+ CASE cr code: change (string, p, p, "")
+ OTHERWISE ersatzdarstellung
+ END SELECT.
+
+expand tab:
+ change (string, p, p, (8 - (p - 1) MOD 8) * " ").
+
+ersatzdarstellung:
+ TEXT CONST t := text (char code);
+ change (string, p, p, "#" + (3 - length (t)) * "0" + t + "#").
+
+END PROC control char conversion;
+
+PROC fetch rowtextmode (DATASPACE VAR file space,
+ TEXT CONST name):
+ enable stop;
+ open fetch dos file (name);
+ initialize fetch rowtext mode;
+ WHILE NOT was last fetch cluster REP
+ cluster struct.size INCR 1;
+ cluster struct.cluster row [cluster struct.size] := "";
+ cat next fetch dos cluster (cluster struct.cluster row [cluster struct.size])
+ PER;
+ close fetch dos file.
+
+initialize fetch row text mode:
+ forget (file space);
+ file space := nilspace;
+ cluster struct := file space;
+ type (file space, row text type);
+ cluster struct.size := 0.
+
+END PROC fetch rowtext mode;
+
+PROC fetch ds mode (DATASPACE VAR in ds, TEXT CONST name):
+ enable stop;
+ open fetch dos file (name);
+ init fetch dsmode;
+ WHILE NOT was last fetch cluster REP
+ read next fetch dos cluster (in ds, ds block no);
+ PER;
+ close fetch dos file.
+
+init fetch dsmode:
+ forget (in ds);
+ in ds := nilspace;
+ INT VAR ds block no := 2.
+
+END PROC fetch ds mode;
+
+PROC fetch dumpmode (DATASPACE VAR file space, TEXT CONST name):
+ enable stop;
+ open fetch dos file (name);
+ initialize fetch dumpmode;
+ WHILE NOT was last fetch cluster REP
+ TEXT VAR cluster buffer := "";
+ cat next fetch dos cluster (cluster buffer);
+ dump cluster
+ UNTIL offset > 50 000.0
+ PER;
+ close fetch dos file.
+
+initialize fetch dump mode:
+ BOOL VAR fertig := FALSE;
+ REAL VAR offset := 0.0;
+ forget (file space);
+ file space := nilspace;
+ file := sequential file (output, file space).
+
+dump cluster:
+ TEXT VAR dump line;
+ INT VAR line, column;
+ FOR line FROM 0 UPTO (cluster size DIV 16) - 1 REP
+ build dump line;
+ putline (file, dump line);
+ offset INCR 16.0
+ UNTIL fertig
+ PER.
+
+build dump line:
+ TEXT VAR char line := "";
+ dump line := text (offset, 6, 0);
+ dump line := subtext (dump line, 1, 5);
+ dump line CAT " ";
+ FOR column FROM 0 UPTO 7 REP
+ convert char;
+ dump line CAT " "
+ PER;
+ dump line CAT " ";
+ FOR column FROM 8 UPTO 15 REP
+ convert char;
+ dump line CAT " "
+ PER;
+ dump line CAT " ";
+ dump line CAT char line.
+
+convert char:
+ TEXT CONST char :: cluster buffer SUB (line * 16 + column + 1);
+ IF char = ""
+ THEN fertig := TRUE;
+ dump line CAT " ";
+ LEAVE convert char
+ FI;
+ INT CONST char code := code (char);
+ LET hex chars = "0123456789ABCDEF";
+ dump line CAT (hex chars SUB (char code DIV 16 + 1));
+ dump line CAT (hex chars SUB (char code MOD 16 + 1));
+ charline CAT show char.
+
+show char:
+ IF (char code > 31 AND char code < 127)
+ THEN char
+ ELSE "."
+ FI.
+
+END PROC fetch dump mode;
+
+PROC check file (TEXT CONST name):
+ disable stop;
+ DATASPACE VAR test ds := nilspace;
+ enable check file (name, test ds);
+ forget (test ds);
+ IF is error
+ THEN clear error;
+ error stop ("Fehler beim Prüflesen der Datei """ + name + """")
+ FI.
+
+END PROC check file;
+
+PROC enable check file (TEXT CONST name, DATASPACE VAR test ds):
+ enable stop;
+ open fetch dos file (name);
+ WHILE NOT was last fetch cluster REP
+ INT VAR dummy := 2;
+ read next fetch dos cluster (test ds, dummy)
+ PER;
+ close fetch dos file.
+
+END PROC enable check file;
+
+END PACKET fetch;
+
diff --git a/system/dos/1.8.7/src/fetch save interface b/system/dos/1.8.7/src/fetch save interface
new file mode 100644
index 0000000..27b4925
--- /dev/null
+++ b/system/dos/1.8.7/src/fetch save interface
@@ -0,0 +1,70 @@
+PACKET fetch save DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ save fetch mode, (* 22.04.87 *)
+ path:
+
+LET ascii = 1,
+ ascii german = 2,
+ transparent = 3,
+ row text = 5,
+ ds = 6,
+ dump = 7,
+ atari st = 10,
+ ibm = 11;
+
+INT PROC save fetch mode (TEXT CONST reserve string):
+ TEXT VAR modus;
+ INT CONST p := pos (reserve string, ":");
+ IF p = 0
+ THEN modus := reserve string
+ ELSE modus := subtext (reserve string, 1, p - 1)
+ FI;
+ modus normieren;
+ IF modus = "FILEASCII"
+ THEN ascii
+ ELIF modus = "FILEASCIIGERMAN"
+ THEN asciigerman
+ ELIF modus = "FILEATARIST"
+ THEN atari st
+ ELIF modus = "FILEIBM"
+ THEN ibm
+ ELIF modus = "FILETRANSPARENT"
+ THEN transparent
+ ELIF modus = "ROWTEXT"
+ THEN row text
+ ELIF modus = "DS"
+ THEN ds
+ ELIF modus = "DUMP"
+ THEN dump
+ ELSE error stop ("Unzulässige Betriebsart"); -1
+ FI.
+
+modus normieren:
+ change all (modus, " ", "");
+ INT VAR i;
+ FOR i FROM 1 UPTO LENGTH modus REP
+ INT CONST char code :: code (modus SUB i);
+ IF is lower case
+ THEN replace (modus, i, upper case char)
+ FI
+ PER.
+
+is lower case:
+ char code > 96 AND char code < 123.
+
+upper case char:
+ code (char code - 32).
+
+END PROC save fetch mode;
+
+TEXT PROC path (TEXT CONST reserve string):
+ INT CONST p :: pos (reserve string, ":");
+ IF p = 0
+ THEN ""
+ ELSE subtext (reserve string, p + 1)
+ FI.
+
+END PROC path;
+
+END PACKET fetch save;
+
diff --git a/system/dos/1.8.7/src/get put interface.dos b/system/dos/1.8.7/src/get put interface.dos
new file mode 100644
index 0000000..1d6de92
--- /dev/null
+++ b/system/dos/1.8.7/src/get put interface.dos
@@ -0,0 +1,368 @@
+PACKET dos get put DEFINES (* Copyright (C) 1986, 87 *)
+ (* Frank Klapper *)
+ (* 11.12.87 *)
+ log modus,
+
+ open dos disk,
+ close dos disk,
+ access dos disk,
+
+ open fetch dos file,
+ close fetch dos file,
+ cat next fetch dos cluster,
+ read next fetch dos cluster,
+ was last fetch cluster,
+
+ open save dos file,
+ write next save dos cluster,
+ close save dos file,
+
+ erase dos file,
+
+ all dosfiles,
+ all dossubdirs,
+ dosfile exists,
+ dos list,
+
+ clear dos disk,
+ format dos disk:
+
+BOOL VAR log flag := FALSE;
+
+PROC log modus (BOOL CONST status):
+ log flag := status
+
+END PROC log modus;
+
+(*-------------------------------------------------------------------------*)
+
+LET max cluster size = 8192, (* 8192 * 8 = 64 KB *)
+ reals per sector = 64;
+
+LET CLUSTER = BOUND STRUCT (ALIGN dummy,
+ ROW max cluster size REAL cluster row);
+
+CLUSTER VAR cluster;
+DATASPACE VAR cluster ds;
+INITFLAG VAR cluster ds used := FALSE;
+
+TEXT VAR convert buffer;
+INT VAR convert buffer length;
+
+PROC init cluster handle:
+ IF initialized (cluster ds used)
+ THEN forget (cluster ds)
+ FI;
+ cluster ds := nilspace;
+ cluster := cluster ds;
+ convert buffer := "";
+ convert buffer length := 0.
+
+END PROC init cluster handle;
+
+PROC cat cluster text (REAL CONST cluster no, TEXT VAR destination, INT CONST to):
+ read disk cluster (cluster ds, 2, cluster no);
+ init convert buffer;
+ INT VAR i;
+ FOR i FROM 1 UPTO sectors per cluster * reals per sector REP
+ replace (convert buffer, i, cluster.cluster row [i])
+ PER;
+ destination CAT subtext (convert buffer, 1, to).
+
+init convert buffer:
+ IF convert buffer length < cluster size
+ THEN convert buffer CAT (cluster size - convert buffer length) * "*";
+ convert buffer length := cluster size
+ FI.
+
+END PROC cat cluster text;
+
+PROC write text to cluster (REAL CONST cluster no, TEXT CONST string):
+ IF LENGTH string < cluster size
+ THEN execute write text (text (string, cluster size))
+ ELSE execute write text (string)
+ FI;
+ write disk cluster (cluster ds, 2, cluster no).
+
+END PROC write text to cluster;
+
+PROC execute write text (TEXT CONST string):
+ INT VAR i;
+ FOR i FROM 1 UPTO sectors per cluster * reals per sector REP
+ cluster.cluster row [i] := string RSUB i
+ PER.
+
+END PROC execute write text;
+
+(*-------------------------------------------------------------------------*)
+
+BOOL VAR disk open := FALSE;
+TEXT VAR act path;
+
+REAL VAR last access time;
+
+PROC open dos disk (TEXT CONST path):
+ IF log flag THEN dump ("open dos disk", path) FI;
+ enable stop;
+ close work;
+ init cluster handle;
+ act path := path;
+ disk open := TRUE
+
+END PROC open dos disk;
+
+PROC close dos disk:
+ IF log flag THEN dump ("close dos disk", "") FI;
+ enable stop;
+ disk open := FALSE;
+ close work;
+ init cluster handle; (* Datenraumespeicher freigeben *)
+ clear fat ds;
+ init dir ds.
+
+END PROC close dos disk;
+
+PROC access dos disk:
+ enable stop;
+ IF NOT disk open
+ THEN error stop ("DOS-Arbeit nicht eröffnet")
+ FI;
+ IF work closed COR (last access more than 5 seconds ago CAND disk changed)
+ THEN open eu disk; (* hier wird der RERUN Check initialisiert *)
+ open dos disk;
+ read fat;
+ open dir (act path);
+ last access time := clock (1);
+ open work
+ FI.
+
+last access more than 5 seconds ago:
+ abs (clock (1) - last access time) > 5.0.
+
+disk changed:
+ IF hd version
+ THEN FALSE
+ ELSE last access time := clock (1);
+ NOT first fat block ok
+ FI.
+
+END PROC access dos disk;
+
+(*-------------------------------------------------------------------------*)
+
+REAL VAR next fetch cluster,
+ fetch rest; (* in Bytes *)
+
+PROC open fetch dos file (TEXT CONST file name):
+ IF log flag THEN dump ("open fetch dos file", file name) FI;
+ enable stop;
+ access dos disk;
+ file info (file name, next fetch cluster, fetch rest).
+
+END PROC open fetch dos file;
+
+BOOL PROC was last fetch cluster:
+ IF log flag THEN dump ("was last fetch cluster", "") FI;
+ is last fat chain entry (next fetch cluster) OR fetch rest <= 0.0.
+
+END PROC was last fetch cluster;
+
+PROC cat next fetch dos cluster (TEXT VAR buffer):
+ IF log flag THEN dump ("cat next fetch dos cluster", "") FI;
+ enable stop;
+ IF was last fetch cluster
+ THEN error stop ("fetch nach Dateiende")
+ FI;
+ IF fetch rest < real (cluster size)
+ THEN cat cluster text (next fetch cluster, buffer, int (fetch rest));
+ fetch rest := 0.0
+ ELSE cat cluster text (next fetch cluster, buffer, cluster size);
+ fetch rest DECR real (cluster size)
+ FI;
+ last access time := clock (1);
+ next fetch cluster := fat entry (next fetch cluster).
+
+END PROC cat next fetch dos cluster;
+
+PROC read next fetch dos cluster (DATASPACE VAR read ds, INT VAR start page):
+ IF log flag THEN dump ("read next fetch dos cluster", start page) FI;
+ enable stop;
+ IF was last fetch cluster
+ THEN error stop ("fetch nach Dateiende")
+ FI;
+ read disk cluster (read ds, start page, next fetch cluster);
+ last access time := clock (1);
+ start page INCR sectors per cluster;
+ next fetch cluster := fat entry (next fetch cluster);
+ IF fetch rest < real (cluster size)
+ THEN fetch rest := 0.0
+ ELSE fetch rest DECR real (cluster size)
+ FI.
+
+END PROC read next fetch dos cluster;
+
+PROC close fetch dos file:
+ IF log flag THEN dump ("close fetch dos file", "") FI;
+
+END PROC close fetch dos file;
+
+(*-------------------------------------------------------------------------*)
+
+TEXT VAR save name;
+REAL VAR first save cluster,
+ last save cluster,
+ save size;
+
+PROC open save dos file (TEXT CONST file name):
+ IF log flag THEN dump ("open save dos file", file name) FI;
+ enable stop;
+ access dos disk;
+ IF file exists (file name) OR subdir exists (file name)
+ THEN error stop ("die Datei """ + file name + """ gibt es schon")
+ FI;
+ save name := file name;
+ first save cluster := -1.0;
+ save size := 0.0.
+
+END PROC open save dos file;
+
+PROC write next save dos cluster (TEXT CONST buffer):
+ IF log flag THEN dump ("write next save dos cluster", "") FI;
+ enable stop;
+ REAL CONST save cluster := available fat entry;
+ write text to cluster (save cluster, buffer);
+ last access time := clock (1);
+ save size INCR real (LENGTH buffer);
+ IF first save cluster < 2.0
+ THEN first save cluster := save cluster
+ ELSE fat entry (last save cluster, save cluster)
+ FI;
+ fat entry (save cluster, last fat chain entry);
+ last save cluster := save cluster.
+
+END PROC write next save dos cluster;
+
+PROC write next save dos cluster (DATASPACE CONST save ds, INT VAR start page):
+ IF log flag THEN dump ("write next save dos cluster", start page) FI;
+ enable stop;
+ REAL CONST save cluster := available fat entry;
+ write disk cluster (save ds, start page, save cluster);
+ last access time := clock (1);
+ start page INCR sectors per cluster;
+ save size INCR real (cluster size);
+ IF first save cluster < 2.0
+ THEN first save cluster := save cluster
+ ELSE fat entry (last save cluster, save cluster)
+ FI;
+ fat entry (save cluster, last fat chain entry);
+ last save cluster := save cluster.
+
+END PROC write next save dos cluster;
+
+PROC close save dos file:
+ IF log flag THEN dump ("close save dos file", "") FI;
+ enable stop;
+ IF first save cluster < 2.0
+ THEN LEAVE close save dos file
+ FI;
+ fat entry (last save cluster, last fat chain entry);
+ write fat;
+ insert dir entry (save name, first save cluster, save size);
+ last access time := clock (1).
+
+END PROC close save dos file;
+
+(*-------------------------------------------------------------------------*)
+
+PROC erase dos file (TEXT CONST file name):
+ IF log flag THEN dump ("erase dos file", file name) FI;
+ enable stop;
+ access dos disk;
+ REAL VAR first cluster, size;
+ file info (file name, first cluster, size);
+ delete dir entry (file name);
+ erase fat chain (first cluster);
+ write fat;
+ last access time := clock (1).
+
+END PROC erase dos file;
+
+(*-------------------------------------------------------------------------*)
+
+THESAURUS PROC all dosfiles:
+ IF log flag THEN dump ("all dosfile", "") FI;
+ enable stop;
+ access dos disk;
+ all files.
+
+END PROC all dosfiles;
+
+THESAURUS PROC all dossubdirs:
+ IF log flag THEN dump ("all subdirs", "") FI;
+ enable stop;
+ access dos disk;
+ all subdirs.
+
+END PROC all dossubdirs;
+
+BOOL PROC dos file exists (TEXT CONST file name):
+ IF log flag THEN dump ("dos file exists", file name) FI;
+ enable stop;
+ access dos disk;
+ file exists (file name).
+
+END PROC dos file exists;
+
+PROC dos list (DATASPACE VAR list ds):
+ IF log flag THEN dump ("dos list", "") FI;
+ enable stop;
+ access dos disk;
+ dir list (list ds).
+
+END PROC dos list;
+
+(*-------------------------------------------------------------------------*)
+
+PROC clear dos disk:
+ IF log flag THEN dump ("clear dos disk", "") FI;
+ enable stop;
+ IF hd version
+ THEN error stop ("nicht implementiert")
+ ELSE access dos disk;
+ format dir;
+ format fat;
+ last access time := clock (1)
+ FI.
+
+END PROC clear dos disk;
+
+PROC format dos disk (INT CONST format code):
+
+ IF log flag THEN dump ("format dos disk (" + text (format code) + ")", "") FI;
+ enable stop;
+ IF NOT disk open
+ THEN error stop ("DOS-Arbeit nicht eröffnet")
+ FI;
+ IF hd version
+ THEN error stop ("nicht implementiert")
+ ELSE do format
+ FI.
+
+do format:
+ IF bpb exists (format code)
+ THEN close work;
+ format archive (format code);
+ open eu disk;
+ write bpb (format code);
+ open dos disk;
+ format dir; (* enthält 'open dir' *)
+ format fat; (* enthält 'read fat' *)
+ open work
+ ELSE error stop ("Format unzulässig")
+ FI;
+ last access time := clock (1).
+
+END PROC format dos disk;
+
+END PACKET dos get put;
+
diff --git a/system/dos/1.8.7/src/insert.dos b/system/dos/1.8.7/src/insert.dos
new file mode 100644
index 0000000..14f98cd
--- /dev/null
+++ b/system/dos/1.8.7/src/insert.dos
@@ -0,0 +1,14 @@
+dump
+konvert
+open
+eu disk descriptor
+disk descriptor.dos
+block i/o
+name conversion.dos
+fat.dos
+dir.dos
+get put interface.dos
+fetch save interface
+fetch
+save
+
diff --git a/system/dos/1.8.7/src/konvert b/system/dos/1.8.7/src/konvert
new file mode 100644
index 0000000..c5c4c43
--- /dev/null
+++ b/system/dos/1.8.7/src/konvert
@@ -0,0 +1,75 @@
+PACKET konvert DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ (* 28.10.86 *)
+ high byte,
+ low byte,
+ word,
+ change low byte,
+ change high byte,
+ dint,
+ high word,
+ low word:
+
+INT PROC high byte (INT CONST value):
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 2)
+
+END PROC high byte;
+
+INT PROC low byte (INT CONST value):
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 1)
+
+END PROC low byte;
+
+INT PROC word (INT CONST low byte, high byte):
+ TEXT CONST x :: code (low byte) + code (high byte);
+ x ISUB 1
+
+END PROC word;
+
+PROC change low byte (INT VAR word, INT CONST low byte):
+ TEXT VAR x := " ";
+ replace (x, 1, word);
+ replace (x, 1, code (low byte));
+ word := x ISUB 1
+
+END PROC change low byte;
+
+PROC change high byte (INT VAR word, INT CONST high byte):
+ TEXT VAR x := " ";
+ replace (x, 1, word);
+ replace (x, 2, code (high byte));
+ word := x ISUB 1
+
+END PROC change high byte;
+
+REAL PROC dint (INT CONST low word, high word):
+ real low word + 65536.0 * real high word.
+
+real low word:
+ real (low byte (low word)) + 256.0 * real (high byte (low word)).
+
+real high word:
+ real (low byte (high word)) + 256.0 * real (high byte (high word)).
+
+END PROC dint;
+
+INT PROC high word (REAL CONST double precission int):
+ int (double precission int / 65536.0)
+
+END PROC high word;
+
+INT PROC low word (REAL CONST double precission int):
+ string of low bytes ISUB 1.
+
+string of low bytes:
+ code (int (double precission int MOD 256.0)) +
+ code (int ((double precission int MOD 65536.0) / 256.0)).
+
+END PROC low word;
+
+END PACKET konvert;
+
diff --git a/system/dos/1.8.7/src/manager-M.dos b/system/dos/1.8.7/src/manager-M.dos
new file mode 100644
index 0000000..e27c513
--- /dev/null
+++ b/system/dos/1.8.7/src/manager-M.dos
@@ -0,0 +1,211 @@
+PACKET dos manager multi DEFINES (* Copyright (C) 1985, 86, 87 *)
+ (* Frank Klapper *)
+ provide channel, (* 16.10.87 *)
+ dos manager:
+
+LET std archive channel = 31,
+
+ ack = 0,
+ second phase ack = 5,
+ false code = 6,
+
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ clear code = 18,
+ reserve code = 19,
+ free code = 20,
+ check read code = 22,
+ format code = 23,
+
+ log code = 78,
+
+ quote = """";
+
+BOUND STRUCT (TEXT name, pass) VAR msg;
+
+TASK VAR order task;
+
+INT VAR dos channel;
+
+INT VAR fetch save modus;
+
+REAL VAR last access time := 0.0;
+
+TASK VAR disk owner := niltask;
+
+TEXT VAR save file name;
+
+PROC provide channel (INT CONST channel):
+ dos channel := channel
+
+END PROC provide channel;
+
+IF hd version
+ THEN provide channel (29)
+ ELSE provide channel (std archive channel)
+FI;
+
+PROC dos manager:
+ dos manager (dos channel)
+
+END PROC dos manager;
+
+PROC dos manager (INT CONST channel):
+ dos channel := channel;
+ task password ("-");
+ global manager
+ (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) dos manager)
+
+END PROC dos manager;
+
+PROC dos manager (DATASPACE VAR ds, INT CONST order code, phase,
+ TASK CONST from task):
+ enable stop;
+ order task := from task;
+ msg := ds;
+ IF NOT (order task = disk owner) AND
+ order code <> free code AND order code <> reserve code
+ THEN errorstop ("DOS nicht angemeldet")
+ FI;
+ IF order task = disk owner
+ THEN last access time := clock (1)
+ FI;
+ SELECT order code OF
+ CASE fetch code : fetch file
+ CASE save code : save file
+ CASE erase code : erase file
+ CASE clear code : clear disk
+ CASE exists code : exists file
+ CASE list code : list disk
+ CASE all code : deliver directory
+ CASE reserve code : reserve
+ CASE free code : free
+ CASE check read code: check
+ CASE format code : format
+ CASE log code : send log
+ OTHERWISE errorstop ("unbekannter Auftrag für Task: " + name (myself))
+ END SELECT.
+
+fetch file:
+ fetch (dos name (msg.name, read modus), ds, fetch save modus);
+ manager ok (ds).
+
+check:
+ check file (dos name (msg.name, read modus));
+ manager message (expanded name (msg.name, read modus) + " ohne Fehler gelesen").
+
+format:
+ IF phase = 1
+ THEN manager question ("Diskette formatieren")
+ ELSE format dos disk (int (msg.name));
+ manager ok (ds)
+ FI.
+
+save file:
+ IF phase = 1
+ THEN save first phase
+ ELSE save second phase
+ FI.
+
+save first phase:
+ save file name := dos name (msg.name, write modus);
+ IF dos file exists (save file name)
+ THEN manager question (expanded name (msg.name, write modus) + " auf der MS-DOS Disk ueberschreiben")
+ ELSE send (order task, second phase ack, ds)
+ FI.
+
+save second phase:
+ IF dos file exists (save file name)
+ THEN erase dos file (save file name)
+ FI;
+ save (save file name, ds, fetch save modus);
+ forget (ds) ;
+ ds := nilspace ;
+ manager ok (ds).
+
+clear disk:
+ IF phase = 1
+ THEN manager question ("Diskette loeschen")
+ ELSE clear dos disk;
+ manager ok (ds)
+ FI.
+
+erase file:
+ IF dos file exists (dos name (msg.name, read modus))
+ THEN IF phase = 1
+ THEN manager question (expanded name (msg.name, TRUE) + " auf der MS-DOS Disk loeschen")
+ ELSE erase dos file (dos name (msg.name, read modus));
+ manager ok (ds)
+ FI
+ ELSE manager message ("die Datei " + expanded name (msg.name, TRUE) + " gibt es nicht auf der MS-DOS Disk")
+ FI.
+
+exists file:
+ IF dos file exists (dos name (msg.name, read modus))
+ THEN manager ok (ds)
+ ELSE send (order task, false code, ds)
+ FI.
+
+list disk:
+ dos list (ds);
+ manager ok (ds).
+
+send log:
+ forget (ds);
+ ds := old ("logbuch");
+ manager ok (ds).
+
+deliver directory:
+ forget (ds);
+ ds := nilspace;
+ BOUND THESAURUS VAR all names := ds;
+ all names := all dos files;
+ manager ok (ds).
+
+reserve:
+ IF reserve or free permitted
+ THEN continue channel (dos channel);
+ disk owner := from task;
+ fetch save modus := save fetch mode (msg.name);
+ open dos disk (path (msg.name));
+ forget ("logbuch", quiet);
+ manager ok (ds)
+ ELSE errorstop ("Archivlaufwerk wird von Task """+ name (disk owner) + """ benutzt")
+ FI.
+
+reserve or free permitted :
+ from task = disk owner OR last access more than five minutes ago
+ OR disk owner = niltask OR NOT
+ (exists (disk owner) OR station(disk owner) <> station (myself)).
+
+last access more than five minutes ago :
+ abs (last access time - clock (1)) > 300.0.
+
+free:
+ IF reserve or free permitted
+ THEN close dos disk;
+ disk owner := niltask;
+ break (quiet);
+ manager ok (ds)
+ ELSE manager message ("DOS nicht angemeldet")
+ FI.
+
+END PROC dos manager;
+
+PROC manager ok (DATASPACE VAR ds):
+ send (order task, ack, ds);
+ last access time := clock (1).
+
+END PROC manager ok;
+
+TEXT PROC expanded name (TEXT CONST name, BOOL CONST status):
+ text (quote + dos name (name, status) + quote, 14)
+
+END PROC expanded name;
+
+END PACKET dos manager multi;
+
diff --git a/system/dos/1.8.7/src/manager-S.dos b/system/dos/1.8.7/src/manager-S.dos
new file mode 100644
index 0000000..23885e6
--- /dev/null
+++ b/system/dos/1.8.7/src/manager-S.dos
@@ -0,0 +1,268 @@
+PACKET dos single DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ (* 11.09.87 *)
+ /,
+ dos,
+ provide dos channel,
+ archive,
+ reserve,
+ release,
+ save,
+ fetch,
+ erase,
+ check,
+ exists,
+ ALL,
+ SOME,
+ clear,
+ list,
+ format:
+
+LET std archive channel = 31,
+ main channel = 1;
+
+INT VAR dos channel := std archive channel;
+INT VAR fetch save modus;
+
+TYPE DOSTASK = TEXT;
+
+DOSTASK CONST dos := "DOS";
+
+OP := (DOSTASK VAR d, TEXT CONST t):
+ CONCR (d) := t
+
+END OP :=;
+
+DOSTASK OP / (TEXT CONST text):
+ DOSTASK VAR d;
+ CONCR (d) := text;
+ d
+
+END OP /;
+
+BOOL PROC is dostask (DOSTASK CONST d):
+ CONCR (d) = "DOS"
+
+END PROC is dos task;
+
+PROC provide dos channel (INT CONST channel no):
+ dos channel := channel no
+
+END PROC provide dos channel;
+
+DATASPACE VAR space := nilspace;
+forget (space);
+
+PROC reserve (TEXT CONST string, DOSTASK CONST task):
+ IF is dostask (task)
+ THEN fetch save modus := save fetch mode (string);
+ open dos disk (path (string))
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+END PROC reserve;
+
+PROC archive (TEXT CONST string, DOSTASK CONST task):
+ reserve (string, task)
+
+END PROC archive;
+
+PROC release (DOSTASK CONST task):
+ IF is dos task (task)
+ THEN close dos disk
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+END PROC release;
+
+PROC fetch (TEXT CONST name, DOSTASK CONST from):
+ IF is dostask (from)
+ THEN fetch from dos disk
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+fetch from dos disk:
+ IF NOT exists (name) COR overwrite permitted
+ THEN do fetch
+ FI.
+
+overwrite permitted:
+ say ("eigene Datei """) ;
+ say (name) ;
+ yes (""" auf der Diskette ueberschreiben").
+
+do fetch:
+ last param (name);
+ disable stop;
+ continue (dos channel);
+ fetch (dos name (name, read modus), space, fetch save modus);
+ continue (main channel);
+ IF NOT is error
+ THEN forget (name, quiet);
+ copy (space, name)
+ FI;
+ forget (space).
+
+END PROC fetch;
+
+PROC erase (TEXT CONST name, DOSTASK CONST task):
+ IF is dos task (task)
+ THEN do erase dos file
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+do erase dos file:
+ IF NOT exists (name, /"DOS")
+ THEN error stop ("die Datei """ + name + """ gibt es nicht")
+ ELIF yes ("""" + dos name (name, read modus)+ """ auf Der Diskette loeschen")
+ THEN disable stop;
+ continue (dos channel);
+ erase dos file (dos name (name, read modus));
+ continue (main channel)
+ FI.
+
+END PROC erase;
+
+PROC save (TEXT CONST name, DOSTASK CONST task):
+ IF is dos task (task)
+ THEN save to dos disk
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+save to dos disk:
+ TEXT CONST save file name :: dos name (name, write modus);
+ disable stop;
+ continue (dos channel);
+ IF NOT dos file exists (save file name) COR overwrite permitted
+ THEN IF dos file exists (save file name)
+ THEN erase dos file (save file name)
+ FI;
+ save (save file name, old (name), fetch save modus);
+ FI;
+ continue (main channel).
+
+overwrite permitted:
+ continue (main channel);
+ BOOL CONST result :: yes ("""" + save file name + """ auf der Diskette ueberschreiben");
+ continue (dos channel);
+ result.
+
+END PROC save;
+
+PROC check (TEXT CONST name, DOSTASK CONST from):
+ IF is dostask (from)
+ THEN disable stop;
+ continue (dos channel);
+ check file (dos name (name, read modus));
+ continue (main channel)
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+END PROC check;
+
+BOOL PROC exists (TEXT CONST name, DOSTASK CONST task):
+ IF is dos task (task)
+ THEN disable stop;
+ continue (dos channel);
+ BOOL VAR dummy := dos file exists (dos name (name, read modus));
+ continue (main channel);
+ enable stop;
+ dummy
+ ELSE error stop ("die angesprochene Task existiert nicht"); FALSE
+ FI.
+
+END PROC exists;
+
+PROC list (DOSTASK CONST from):
+ forget (space);
+ space := nilspace;
+ FILE VAR list file := sequential file (output, space);
+ list (list file, from);
+ modify (list file);
+ show (list file);
+ forget (space).
+
+ENDPROC list;
+
+PROC list (FILE VAR list file, DOSTASK CONST from):
+ IF is dos task (from)
+ THEN list dos disk
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+list dos disk:
+ disable stop;
+ continue (dos channel);
+ dos list (space);
+ continue (main channel);
+ enable stop;
+ output (list file);
+ FILE VAR list source := sequential file (output, space);
+ TEXT VAR line;
+ WHILE NOT eof (list source) REP
+ getline (list source, line);
+ putline (list file, line)
+ PER.
+
+END PROC list;
+
+THESAURUS OP ALL (DOSTASK CONST task):
+ IF is dos task (task)
+ THEN disable stop;
+ continue (dos channel);
+ THESAURUS VAR dummy := all dos files;
+ continue (main channel);
+ enable stop;
+ dummy
+ ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus
+ FI.
+
+END OP ALL;
+
+THESAURUS OP SOME (DOSTASK CONST task):
+ IF is dos task (task)
+ THEN disable stop;
+ continue (dos channel);
+ THESAURUS VAR dummy := all dos files;
+ continue (main channel);
+ enable stop;
+ SOME dummy
+ ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus
+ FI.
+
+END OP SOME;
+
+PROC clear (DOSTASK CONST task):
+ IF is dos task (task)
+ THEN clear disk
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+clear disk:
+ disable stop;
+ IF yes ("Diskette loeschen")
+ THEN continue (dos channel);
+ clear dos disk;
+ continue (main channel)
+ FI.
+
+END PROC clear;
+
+PROC format (INT CONST format code, DOSTASK CONST task):
+ IF is dos task (task)
+ THEN format disk
+ ELSE error stop ("die angesprochene Task existiert nicht")
+ FI.
+
+format disk:
+ disable stop;
+ IF yes ("Diskette formatieren")
+ THEN continue (dos channel);
+ format dos disk (format code);
+ continue (main channel)
+ FI.
+
+END PROC format;
+
+END PACKET dos single;
+
diff --git a/system/dos/1.8.7/src/name conversion.dos b/system/dos/1.8.7/src/name conversion.dos
new file mode 100644
index 0000000..e72d838
--- /dev/null
+++ b/system/dos/1.8.7/src/name conversion.dos
@@ -0,0 +1,77 @@
+PACKET name conversion DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ dos name, (* 31.12.86 *)
+
+ read modus,
+ write modus:
+
+BOOL CONST read modus :: TRUE,
+ write modus :: NOT read modus;
+
+LET upper case chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$#&§!()-{}`_",
+ lower case chars = "abcdefghijklmnopqrstuvwxyz";
+
+TEXT PROC dos name (TEXT CONST eu name, BOOL CONST read write modus):
+ enable stop;
+ INT CONST point pos :: pos (eu name, ".");
+ IF name extension exists
+ THEN changed name with extension
+ ELSE changed name without extension
+ FI.
+
+name extension exists:
+ point pos > 0.
+
+changed name with extension:
+ TEXT CONST name pre :: compress (subtext (eu name, 1, point pos - 1)),
+ name post :: compress (subtext (eu name, point pos + 1));
+ IF LENGTH name pre = 0 OR LENGTH name pre > 8 OR LENGTH name post > 3
+ THEN error
+ FI;
+ IF LENGTH name post = 0
+ THEN new name (name pre, read write modus)
+ ELSE new name (name pre, read write modus) + "."
+ + new name (name post, read write modus)
+ FI.
+
+changed name without extension:
+ IF LENGTH eu name > 8 OR LENGTH euname < 1
+ THEN error
+ FI;
+ new name (eu name, read write modus).
+
+error:
+ error stop ("Unzulässiger Name").
+
+END PROC dos name;
+
+TEXT PROC new name (TEXT CONST old name, BOOL CONST read write modus):
+ TEXT VAR new := "";
+ INT VAR count;
+ FOR count FROM 1 UPTO LENGTH old name REP
+ convert char
+ PER;
+ new.
+
+convert char:
+ TEXT CONST char :: old name SUB count;
+ IF is lower case char
+ THEN new CAT (upper case chars SUB string pos)
+ ELIF is upper case char OR read write modus
+ THEN new CAT char
+ ELSE error stop ("Unzulässiger Name")
+ FI.
+
+is lower case char:
+ pos (lower case chars, char) > 0.
+
+is upper case char:
+ pos (upper case chars, char) > 0.
+
+string pos:
+ pos (lower case chars, char).
+
+END PROC new name;
+
+END PACKET name conversion;
+
diff --git a/system/dos/1.8.7/src/open b/system/dos/1.8.7/src/open
new file mode 100644
index 0000000..518c4b8
--- /dev/null
+++ b/system/dos/1.8.7/src/open
@@ -0,0 +1,66 @@
+PACKET open DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ open work, (* 05.01.87 *)
+ close work,
+ work opened,
+ work closed,
+ init check rerun,
+ check rerun,
+
+ hd version:
+
+BOOL VAR open;
+INT VAR old session;
+
+BOOL VAR hd flag := FALSE;
+
+INITFLAG VAR packet := FALSE;
+
+PROC open work:
+ open := TRUE
+
+END PROC open work;
+
+PROC close work:
+ open := FALSE
+
+END PROC close work;
+
+BOOL PROC work opened:
+ IF NOT initialized (packet)
+ THEN close work
+ FI;
+ open
+
+END PROC work opened;
+
+BOOL PROC work closed:
+ NOT work opened
+
+END PROC work closed;
+
+PROC init check rerun:
+ old session := session
+
+END PROC init check rerun;
+
+PROC check rerun:
+ IF session <> old session
+ THEN close work;
+ error stop ("Diskettenzugriff im RERUN")
+ FI.
+
+END PROC check rerun;
+
+PROC hd version (BOOL CONST status):
+ hd flag := status
+
+END PROC hd version;
+
+BOOL PROC hd version:
+ hd flag
+
+END PROC hd version;
+
+END PACKET open;
+
diff --git a/system/dos/1.8.7/src/save b/system/dos/1.8.7/src/save
new file mode 100644
index 0000000..7e67e91
--- /dev/null
+++ b/system/dos/1.8.7/src/save
@@ -0,0 +1,233 @@
+PACKET save DEFINES (* Copyright (C) 1985, 86, 87 *)
+ (* Frank Klapper *)
+ (* 27.04.87 *)
+ save:
+
+LET ascii = 1,
+ ascii german = 2,
+ transparent = 3,
+ row text = 5,
+ ds = 6,
+ atari st = 10,
+ ibm = 11,
+
+ ff = ""12"",
+ ctrl z = ""26"",
+ cr lf = ""13""10"",
+
+ row text mode length = 4000;
+
+TEXT VAR buffer;
+
+BOUND STRUCT (INT size,
+ ROW row text mode length TEXT cluster row) VAR cluster struct;
+
+PROC save (TEXT CONST file name, DATASPACE CONST file ds, INT CONST mode):
+
+ SELECT mode OF
+ CASE ascii, ascii german, atari st, ibm, transparent:
+ save filemode (file ds, filename, mode)
+ CASE row text : save row textmode (file ds, filename)
+ CASE ds : save dsmode (file ds, filename)
+ OTHERWISE error stop ("Unzulässige Betriebsart")
+ END SELECT.
+
+END PROC save;
+
+PROC save filemode (DATASPACE CONST file space, TEXT CONST name, INT CONST code type):
+
+ enable stop;
+ open save dos file (name);
+ FILE VAR file := sequential file (modify, file space);
+ buffer := "";
+ INT VAR line no;
+ FOR line no FROM 1 UPTO lines (file) REP
+ to line (file, line no);
+ buffer cat file line;
+ WHILE length (buffer) >= cluster size REP
+ write next save dos cluster (subtext (buffer, 1, cluster size));
+ buffer := subtext (buffer, cluster size + 1)
+ PER
+ PER;
+ IF ascii code
+ THEN buffer CAT ctrl z
+ FI;
+ write rest;
+ close save dos file;
+ buffer := "".
+
+buffer cat file line:
+ exec (PROC (TEXT CONST, INT CONST) cat adapted line, file, code type).
+
+ascii code:
+ (code type = ascii) OR (code type = ascii german).
+
+write rest:
+ WHILE buffer <> ""
+ REP write next save dos cluster (subtext (buffer, 1, cluster size));
+ buffer := subtext (buffer, cluster size + 1)
+ PER.
+
+END PROC save filemode;
+
+PROC cat adapted line (TEXT VAR line, INT CONST code type):
+
+ IF code type = transparent
+ THEN buffer CAT line
+ ELSE change esc sequences;
+ change eumel print chars;
+ SELECT code type OF
+ CASE ascii : ascii change
+ CASE ascii german: ascii german change
+ CASE atari st : atari st change
+ CASE ibm : ibm change
+ END SELECT;
+ buffer CAT line;
+ IF (line SUB length (line)) <> ff
+ THEN buffer CAT cr lf
+ FI
+ FI.
+
+change esc sequences:
+ change all (line, "#page#", ff);
+ INT VAR p := pos (line, "#");
+ WHILE p > 0 REP
+ IF is esc sequence
+ THEN change (line, p, p+4, coded char)
+ FI;
+ p := pos (line, "#", p+1)
+ PER.
+
+is esc sequence:
+ LET digits = "0123456789";
+ (line SUB (p+4)) = "#" CAND pos (digits, line SUB p+1) > 0 CAND
+ pos (digits, line SUB p+2) > 0 CAND pos (digits, line SUB p+3) > 0.
+
+coded char:
+ code (int (subtext (line, p+1, p+3))).
+
+change eumel print chars:
+ p := pos (line, ""220"", ""223"", 1);
+ WHILE p > 0 REP
+ replace (line, p, std char);
+ p := pos (line, ""220"", ""223"", p + 1)
+ PER.
+
+std char:
+ "k-# " SUB (code (line SUB p) - 219).
+
+ascii change:
+ change all (line, "ß", "#251#");
+ p := pos (line, "Ä", "ü", 1);
+ WHILE p > 0 REP
+ change (line, p, p, ersatzdarstellung (line SUB p));
+ p := pos (line, "Ä", "ü", p + 1)
+ PER.
+
+ascii german change:
+ change all (line, "[", "#091#");
+ change all (line, "\", "#092#");
+ change all (line, "]", "#093#");
+ change all (line, "{", "#123#");
+ change all (line, "|", "#124#");
+ change all (line, "}", "#125#");
+ change all (line, "~", "#126#");
+ change all (line, "ß", ""126"");
+ p := pos (line, "Ä", "ü", 1);
+ WHILE p > 0 REP
+ replace (line, p, umlaut in ascii german);
+ p := pos (line, "Ä", "ü", p + 1)
+ PER.
+
+umlaut in ascii german:
+ "[\]{|}" SUB (code (line SUB p) - 213).
+
+ibm change:
+ change all (line, "ß", ""225"");
+ p := pos (line, "Ä", "ü", 1);
+ WHILE p > 0 REP
+ replace (line, p, umlaut in ibm);
+ p := pos (line, "Ä", "ü", p + 1)
+ PER.
+
+atari st change:
+ change all (line, "ß", ""158"");
+ p := pos (line, "Ä", "ü", 1);
+ WHILE p > 0 REP
+ replace (line, p, umlaut in ibm);
+ p := pos (line, "Ä", "ü", p + 1)
+ PER.
+
+umlaut in ibm:
+ ""142""153""154""132""148""129"" SUB (code (line SUB p) - 213).
+
+END PROC cat adapted line;
+
+TEXT PROC ersatzdarstellung (TEXT CONST char):
+
+ TEXT CONST t :: text (code (char SUB 1));
+ "#" + (3 - length (t)) * "0" + t + "#"
+
+END PROC ersatzdarstellung;
+
+PROC save rowtextmode (DATASPACE CONST space, TEXT CONST name):
+
+ enable stop;
+ open save dos file (name);
+ init save row textmode;
+ WHILE line no < cluster struct.size REP
+ fill buffer;
+ write next save dos cluster (subtext (buffer, 1, cluster size));
+ remember rest
+ PER;
+ write rest;
+ close save dos file;
+ buffer := "".
+
+init save rowtextmode:
+ cluster struct := space;
+ buffer := "";
+ INT VAR line no := 0.
+
+fill buffer:
+ WHILE line no < cluster struct.size AND NOT buffer full REP
+ line no INCR 1;
+ buffer CAT cluster struct.cluster row [line no]
+ PER.
+
+buffer full:
+ LENGTH buffer >= cluster size.
+
+remember rest:
+ buffer := subtext (buffer, cluster size + 1).
+
+write rest:
+ WHILE buffer <> ""
+ REP write next save dos cluster (subtext (buffer, 1, cluster size));
+ remember rest
+ PER.
+
+END PROC save rowtextmode;
+
+PROC save ds mode (DATASPACE CONST out ds, TEXT CONST name):
+
+ enable stop;
+ open save dos file (name);
+ INT VAR page no := first non dummy ds page;
+ get last allocated ds page;
+ WHILE page no <= last allocated ds page REP
+ write next save dos cluster (out ds, page no);
+ PER;
+ close save dos file.
+
+get last allocated ds page:
+ INT VAR last allocated ds page := -1,
+ i;
+ FOR i FROM 1 UPTO ds pages (out ds) REP
+ last allocated ds page := next ds page (out ds, last allocated ds page)
+ PER.
+
+END PROC save ds mode;
+
+END PACKET save;
+
diff --git a/system/dos/1.8.7/src/shard interface b/system/dos/1.8.7/src/shard interface
new file mode 100644
index 0000000..20d9b76
--- /dev/null
+++ b/system/dos/1.8.7/src/shard interface
@@ -0,0 +1,20 @@
+; ';' in Spalte 1 kennzeichnet eine Kommentarzeile
+; alle Werte müssen durch Blanks getrennt werden
+;
+;heads: Anzahl der Köpfe, positiv für cylinderorientiertes Lesen
+; negativ für seitenorientiertes Lesen
+;
+;size heads tracks first sectors last sector
+;=====================================================
+320 1 40 1 8
+360 1 40 1 9
+640 -2 40 1 8
+720 -2 40 1 9
+800 2 40 1 10
+1440 -2 80 1 9
+1600 2 80 1 10
+2400 -2 80 1 15
+1232 1 77 0 15
+2464 -2 77 0 15
+; END OF FILE
+
diff --git a/system/eumel-coder/1.8.0/src/eumel coder 1.8.0 b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0
new file mode 100644
index 0000000..d9f489f
--- /dev/null
+++ b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0
@@ -0,0 +1,2594 @@
+PACKET eumel coder (* Autor: U. Bartling *)
+ DEFINES coder on, coder off,
+ declare, define, apply, identify,
+ :=, =,
+ dump,
+
+ LABEL,
+ gosub, goret,
+ complement condition code,
+
+ ADDRESS ,
+ GLOB, LOC, REF, DEREF,
+ ref length,
+ +,
+ adjust,
+ is global, is local, is ref,
+
+ DTYPE,
+ type class, type name,
+ void type, int type, real type, text type, bool type,
+ dataspace type, undefined type,
+ row type, struct type, proc type, end type,
+
+ OPN,
+ set length of local storage,
+ begin module, end module,
+ is proc, is eumel 0 instruction,
+ address, operation,
+ nop,
+ init op codes,
+ mnemonic,
+
+ parameter,
+ next param,
+ NEXTPARAM,
+ access ,
+ dtype ,
+ param address,
+ same type ,
+
+ reserve storage,
+ allocate denoter ,
+ allocate variable,
+ data allocation by coder ,
+ data allocation by user,
+
+ run, run again,
+ insert,
+ prot, prot off,
+ check, check on, check off,
+
+ help, bulletin, packets :
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 13.02.1986 *)
+(* Stand der Implementation : 21.03.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR memory management mode, global address offset, hash table pointer,
+ nt link, permanent pointer, param link, index, mode, field pointer,
+ word, number of errors := 0 ;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 12.03.1986 *)
+(* 1.7.5.4 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+ before first pt entry = 22784 ,
+ first permanent entry = 22785 ,
+ end of permanent table = 32767 ,
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+ four word length = 4 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+(* permanent param proc end marker = 0 , *)
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+ offset to row size = 12785 ,
+
+ void = 0 ,
+ int = 1 ,
+ real = 2 ,
+ string = 3 ,
+ bool = 5 ,
+ bool result = 6 ,
+ dataspace = 7 ,
+ undefined = 9 ,
+ row = 10 ,
+ struct = 11 ,
+ end = 0 ,
+
+ const = 1 ,
+ var = 2 ,
+(* proc = 3 , *)
+(* denoter = 5 , *)
+ bold = 2 ,
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+ prep coder mode = 5 ,
+
+ warning message = 2 ,
+ error message = 4 ,
+
+ point line = "..............." ;
+
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+
+BOOL VAR coder active := FALSE ;
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+LET invalid coder off = "CODER not active" ;
+
+PROC coder on (INT CONST data allocation mode) :
+ mark coder on ;
+ init memory management ;
+ init opn section ;
+ init compiler .
+
+mark coder on :
+ coder active := TRUE .
+
+init memory management :
+ memory management mode := data allocation mode ;
+ prep pbase (global address offset) .
+
+init compiler :
+ no do again ;
+ elan (prep coder mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+
+ENDPROC coder on;
+
+PROC coder off (BOOL CONST insert, sermon, OPN CONST start proc) :
+ IF coder active
+ THEN mark coder off ;
+ end coder (insert, sermon, start mod nr if no insert)
+ ELSE errorstop (invalid coder off)
+ FI .
+
+start mod nr if no insert :
+ IF insert THEN run again mod nr := 0
+ ELSE run again mod nr := start proc.mod nr
+ FI ;
+ run again mod nr .
+
+mark coder off :
+ reset memory management mode ;
+ init opn section ;
+ coder active := FALSE
+ENDPROC coder off ;
+
+PROC end coder (BOOL CONST insert wanted, sermon wanted, INT CONST mod) :
+ EXTERNAL 10021
+ENDPROC end coder ;
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ (***** Hash/Namenstabelle *****)
+.
+next hash entry :
+ hash table pointer INCR wordlength .
+
+end of hash table reached :
+ hash table pointer > end of hash table .
+
+yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ next pt param ;
+ mode := cdb int (param link)
+ UNTIL mode = permanent type field PER ;
+ param link INCR wordlength
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode = permanent param proc THEN type of param proc
+ ELSE type of object
+ FI .
+
+type of param proc :
+ param link INCR wordlength ;
+ get type and mode (type) ;
+ mode := permanent param proc .
+
+type of object :
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 2. Spruenge und Marken 07.03.1986 *)
+(* *)
+(* Definition des Datentyps LABEL *)
+(* *)
+(* Deklaration, Definition und Applikation von Marken *)
+(* *)
+(**************************************************************************)
+
+
+TYPE LABEL = INT ;
+
+BOOL VAR invers :: FALSE ;
+
+PROC declare (LABEL VAR label) :
+ CONCR (label) := 0
+ENDPROC declare ;
+
+PROC define (LABEL VAR label) :
+ EXTERNAL 10084
+ENDPROC define ;
+
+PROC complement condition code :
+ invers := TRUE
+ENDPROC complement condition code ;
+
+PROC apply (LABEL VAR label) :
+ EXTERNAL 10149
+ENDPROC apply ;
+
+PROC apply (LABEL VAR label, BOOL CONST condition) :
+ IF condition xor invers THEN branch true (label)
+ ELSE branch false (label)
+ FI ;
+ invers := FALSE .
+
+condition xor invers :
+ IF condition THEN NOT invers
+ ELSE invers
+ FI
+ENDPROC apply ;
+
+OP := (LABEL VAR global label, local label) : (* EQUATE ! *)
+ EXTERNAL 10014
+ENDOP := ;
+
+TEXT PROC dump (LABEL CONST label) :
+ "LAB " + text (CONCR (label))
+ENDPROC dump ;
+
+PROC gosub (LABEL VAR label) :
+ EXTERNAL 10015
+ENDPROC gosub ;
+
+PROC goret :
+ s0 (q goret code)
+ENDPROC goret ;
+
+PROC branch true (LABEL VAR label) :
+ EXTERNAL 10028
+ENDPROC branch true ;
+
+PROC branch false (LABEL VAR label) :
+ EXTERNAL 10029
+ENDPROC branch false ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 3. Datenaddressen 21.03.1986 *)
+(* *)
+(* Definition des Datentyps ADDRESS *)
+(* *)
+(* Aufbau von Datenaddressen (Vercodung) *)
+(* Fortschalten und Ausrichten von Adressen *)
+(* Bereitstellen der Fehlermeldung "address overflow" (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE ADDRESS = STRUCT (INT kind, value) ;
+
+LET global = 0 ,
+ local = 1 ,
+ ref mask = 2 ,
+ global ref = 2 ,
+ local ref = 3 ,
+ module nr = 4 ,
+ immediate value = 5 ,
+
+ eumel0 stack offset = 4 ,
+ local address limit = 16 384 ,
+
+ illegal ref operation = "REF not allowed" ,
+ deref on non ref = "DEREF on non-ref address" ,
+ global ref not allowed = "GLOBAL REF not allowed" ,
+ unknown kind = "Unknown address kind" ,
+ address overflow = "Address Overflow" ,
+ illegal plus operation = "+ not allowed" ;
+
+ADDRESS VAR result addr;
+
+INT CONST ref length :: 2 ;
+
+OP := (ADDRESS VAR l, ADDRESS CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+ADDRESS OP GLOB (INT CONST address level) :
+ result addr.kind := global ;
+ result addr.value := address level ;
+ IF memory management mode = data allocation by user
+ THEN result addr.value INCR global address offset
+ FI ;
+ result addr
+ENDOP GLOB ;
+
+ADDRESS OP LOC (INT CONST address level) :
+ result addr.kind := local ;
+ result addr.value := address level + eumel0 stack offset ;
+ result addr
+ENDOP LOC ;
+
+ADDRESS OP REF (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ IF result addr.kind = local THEN result addr.kind INCR ref mask
+ ELIF result addr.kind = global THEN errorstop (global ref not allowed)
+ ELSE errorstop (illegal ref operation)
+ FI ;
+ result addr
+ENDOP REF ;
+
+ADDRESS OP DEREF (ADDRESS CONST ref address) :
+ CONCR (result addr) := CONCR (ref address) ;
+ IF is not local ref THEN errorstop (deref on non ref) FI ;
+ result addr.kind DECR ref mask ;
+ result addr .
+
+is not local ref :
+ result addr.kind <> local ref
+ENDOP DEREF ;
+
+INT OP REPR (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global :
+ CASE local : set bit (result addr.value, 15)
+ CASE global ref : errorstop (global ref not allowed)
+ CASE local ref : prep local ref
+ OTHERWISE errorstop (unknown kind)
+ ENDSELECT ;
+ result addr.value .
+
+prep local ref :
+ IF address limit exceeded THEN errorstop (address overflow) FI ;
+ set bit (result addr.value, 14) ;
+ set bit (result addr.value, 15) .
+
+address limit exceeded :
+ result addr.value < eumel0 stack offset OR
+ result addr.value > local address limit
+ENDOP REPR ;
+
+BOOL PROC is ref (ADDRESS CONST addr) :
+ addr.kind = local ref
+ENDPROC is ref ;
+
+BOOL PROC is global (ADDRESS CONST addr) :
+ addr.kind = global
+ENDPROC is global ;
+
+BOOL PROC is local (ADDRESS CONST addr) :
+ addr.kind = local
+ENDPROC is local ;
+
+ADDRESS OP + (ADDRESS CONST addr, INT CONST offset) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global : inc global
+ CASE local : inc local
+ OTHERWISE errorstop (illegal plus operation)
+ ENDSELECT ;
+ result addr .
+
+inc global :
+ result addr.value INCR offset ;
+ IF result addr.value < 0 THEN errorstop (address overflow) FI .
+
+inc local :
+ result addr.value INCR offset ;
+ IF result addr.value < eumel 0 stack offset OR
+ result addr.value > local address limit
+ THEN errorstop (address overflow)
+ FI
+ENDOP + ;
+
+PROC adjust (ADDRESS VAR addr, INT CONST adjust length) :
+ IF is local or global THEN adjust to length FI .
+
+is local or global :
+ addr.kind <= local .
+
+adjust to length :
+ mode := addr.value MOD adjust length ;
+ IF mode <> 0 THEN addr.value INCR (adjust length-mode) FI
+ENDPROC adjust ;
+
+TEXT PROC dump (ADDRESS CONST addr) :
+ kind + text (addr.value) .
+
+kind :
+ SELECT addr.kind OF
+ CASE global : "GLOBAL "
+ CASE local : "LOCAL "
+ CASE immediate value : "IMMEDIATE "
+ CASE module nr : "PARAM PROC "
+ CASE global ref : "GLOBAL REF "
+ CASE local ref : "LOCAL REF "
+ OTHERWISE "undef. Addr:"
+ ENDSELECT
+ENDPROC dump;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 4. Datentypen Teil I 03.12.1985 *)
+(* *)
+(* Definition des Datentyps DTYPE *)
+(* *)
+(* Interne Repraesentation der primitiven Datentypen *)
+(* Identifikation von DTYPEs *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE DTYPE = INT ;
+
+OP := (DTYPE VAR l, DTYPE CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+BOOL OP = (DTYPE CONST l, r) :
+ CONCR (l) = CONCR (r)
+ENDOP = ;
+
+DTYPE PROC void type : DTYPE :(void) ENDPROC void type ;
+
+DTYPE PROC int type : DTYPE :(int ) ENDPROC int type ;
+
+DTYPE PROC real type : DTYPE :(real) ENDPROC real type ;
+
+DTYPE PROC text type : DTYPE :(string) ENDPROC text type ;
+
+DTYPE PROC bool type : DTYPE :(bool) ENDPROC bool type ;
+
+DTYPE PROC dataspace type : DTYPE :(dataspace) ENDPROC dataspace type ;
+
+DTYPE PROC undefined type : DTYPE :(undefined) ENDPROC undefined type ;
+
+DTYPE PROC row type : DTYPE :(row) ENDPROC row type ;
+
+DTYPE PROC struct type : DTYPE :(struct) ENDPROC struct type ;
+
+DTYPE PROC proc type : DTYPE :(permanent param proc) ENDPROC proc type ;
+
+DTYPE PROC end type : DTYPE :(end) ENDPROC end type ;
+
+INT PROC type class (DTYPE CONST type) :
+ SELECT type id OF
+ CASE int, real, bool, string, dataspace, undefined : 1
+ CASE void : 0
+ CASE row : 3
+ CASE struct : 4
+ CASE permanent param proc : 5
+ OTHERWISE pt type
+ ENDSELECT .
+
+pt type :
+ IF type id > ptt limit THEN permanent row or struct
+ ELSE abstract type
+ FI .
+
+abstract type : 2 .
+
+permanent row or struct :
+ mode := cdbint (type link into pt) MOD ptt limit ;
+ IF mode = struct THEN 4
+ ELIF mode = row THEN 3
+ ELSE 2
+ FI .
+
+type link into pt :
+ type id + begin of pt minus ptt limit .
+
+type id : CONCR (type)
+ENDPROC type class ;
+
+PROC identify (TEXT CONST name,INT VAR size, align, DTYPE VAR type) :
+ SELECT type pos OF
+ CASE 1 : size := 0; align := 0; type id := void
+ CASE 6 : size := 1; align := 1; type id := int
+ CASE 10 : size := 4; align := 4; type id := real
+ CASE 15 : size := 8; align := 4; type id := string
+ CASE 20 : size := 1; align := 1; type id := bool
+ CASE 25 : size := 1; align := 1; type id := dataspace
+ OTHERWISE search for type in permanent table
+ ENDSELECT .
+
+type pos :
+ enclose in delimiters ;
+ pos (".VOID.INT.REAL.TEXT.BOOL.DATASPACE.", object name) .
+
+enclose in delimiters :
+ object name := "." ;
+ object name CAT name ;
+ object name CAT "." .
+
+search for type in permanent table :
+ to object (name) ;
+ IF NOT found THEN size := 0; align := 0; type id := undefined
+ ELSE size := cdbint (permanent pointer + two wordlength) ;
+ type id := permanent pointer - begin of permanent table ;
+ IF size < two wordlength THEN align := 1
+ ELIF size < four wordlength THEN align := 2
+ ELSE align := 4
+ FI
+ FI .
+
+type id : CONCR (type)
+ENDPROC identify ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 5. Operationen Teil I 21.03.1986 *)
+(* *)
+(* Definition des Datentyps OPN *)
+(* Primitive Operationen (:= etc.) *)
+(* Bereitstellen dee Fehlermeldung 'proc op expected' (coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+TYPE OPN = STRUCT (INT kind, mod nr, top of stack) ;
+
+LET proc op = 0 ,
+ param proc = 1 ,
+ eumel 0 = 2 ,
+ nil = 3 ,
+
+ param proc at non ref = "PARAM PROC at non-ref address" ,
+ proc op expected = "PROC expected" ;
+
+OPN VAR eumel0 opn;
+eumel0 opn.kind := eumel0 ;
+eumel0 opn.top of stack := 0 ;
+
+eumel0 opn.mod nr := q pp ;
+OPN CONST pp :: eumel0 opn ,
+ nop code :: OPN :(nil, 0, 0) ;
+
+THESAURUS VAR eumel 0 opcodes :: empty thesaurus ;
+
+PROC init op codes (FILE VAR eumelcodes) :
+ eumel 0 opcodes := empty thesaurus ;
+ WHILE NOT eof (eumelcodes) REP
+ getline (eumelcodes, object name) ;
+ delete trailing blanks ;
+ IF object name <> "" CAND NOT (eumel 0 opcodes CONTAINS object name)
+ THEN insert (eumel 0 opcodes, object name)
+ FI
+ PER .
+
+delete trailing blanks :
+ WHILE (object name SUB LENGTH object name) = " " REP
+ object name := subtext (object name, 1, LENGTH object name - 1)
+ PER
+ENDPROC init op codes ;
+
+ADDRESS PROC address (OPN CONST opn) :
+ IF opn.kind <> proc op THEN errorstop (proc op expected) FI ;
+ result addr.kind := module nr ;
+ result addr.value := opn.mod nr ;
+ result addr
+ENDPROC address ;
+
+OPN PROC operation (ADDRESS CONST addr) :
+ IF addr.kind <> local ref THEN errorstop (param proc at non ref) FI ;
+ OPN VAR opn ;
+ opn.kind := param proc ;
+ opn.mod nr :=addr.value ;
+ opn.top of stack := 0 ;
+ opn
+ENDPROC operation ;
+
+TEXT PROC mnemonic (OPN CONST op code) :
+ name (eumel 0 opcodes, op code.mod nr)
+ENDPROC mnemonic ;
+
+OPN PROC nop :
+ nop code
+ENDPROC nop ;
+
+OP := (OPN VAR r, OPN CONST l) :
+ CONCR (r) := CONCR (l)
+ENDOP := ;
+
+BOOL PROC is proc (OPN CONST operation) :
+ operation.kind = proc op
+ENDPROC is proc ;
+
+BOOL PROC is eumel 0 instruction (TEXT CONST op code name) :
+ link (eumel 0 opcodes, op code name) <> 0
+ENDPROC is eumel 0 instruction ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 6. Parameterfeld 10.01.1986 *)
+(* *)
+(* Bereitstellen des Parameterfeldes *)
+(* Schreiben und Lesen von Eintraegen im Parameterfeld *)
+(* Fortschalten von Zeigern in das Parameterfeld *)
+(* Bereitstellen der Konstanten 'size of param field' (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+LET PARAMDESCRIPTOR = STRUCT (DTYPE type, INT access,
+ ADDRESS addr, OPN push opn) ,
+
+ size of param field = 100 ,
+ param field exceeded = "Param Field Overflow",
+ param nr out of range = "Illegal Param Number" ;
+
+ROW size of param field PARAMDESCRIPTOR VAR param field ;
+
+
+ (***** Schreiben *****)
+
+PROC test param pos (INT CONST param nr) :
+ IF param nr < 1 OR param nr > size of param field
+ THEN errorstop (param nr out of range)
+ FI
+ENDPROC test param pos ;
+
+PROC declare (INT CONST param nr, DTYPE CONST type) :
+ test param pos (param nr) ;
+ enter type .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type)
+ENDPROC declare ;
+
+PROC declare (INT CONST param nr, access) :
+ test param pos (param nr) ;
+ enter access .
+
+enter access :
+ param field [param nr].access := access
+ENDPROC declare ;
+
+PROC define (INT CONST param nr, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter address .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr)
+ENDPROC define ;
+
+PROC define (INT CONST param nr, value) :
+ result addr.kind := immediate value ;
+ result addr.value := value ;
+ define (param nr, result addr)
+ENDPROC define ;
+
+PROC apply (INT CONST param nr, OPN CONST opn) :
+ test param pos (param nr) ;
+ enter push opn .
+
+enter push opn :
+ CONCR (param field [param nr].push opn) := CONCR (opn)
+ENDPROC apply ;
+
+PROC parameter (INT CONST param nr, DTYPE CONST type,
+ INT CONST access, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter type ;
+ enter access ;
+ enter address ;
+ enter pp as default .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type) .
+
+enter access :
+ param field [param nr].access := access .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr) .
+
+enter pp as default :
+ CONCR (param field [param nr].push opn) := CONCR (pp)
+ENDPROC parameter ;
+
+
+ (***** Lesen *****)
+
+ADDRESS PROC param address (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].addr
+ENDPROC param address ;
+
+DTYPE PROC dtype (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].type
+ENDPROC dtype ;
+
+INT PROC access (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].access
+ENDPROC access ;
+
+
+ (***** Fortschalten *****)
+
+OP NEXTPARAM (INT VAR param nr) :
+ test param pos (param nr) ;
+ IF long entry THEN read until end FI ;
+ param nr INCR 1 .
+
+long entry :
+ type class (param field [param nr].type) > 2 .
+
+read until end :
+ REP
+ param nr INCR 1 ;
+ NEXTPARAM param nr
+ UNTIL end marker read or end of field PER .
+
+end marker read or end of field :
+ param nr > size of param field OR
+ CONCR (param field [param nr].type) = end
+ENDOP NEXTPARAM ;
+
+INT PROC next param (INT CONST p) :
+ index := p ;
+ NEXTPARAM index ;
+ index
+ENDPROC next param ;
+
+TEXT PROC dump (INT CONST p) :
+ IF p > 0 AND p <= 100 THEN dump entry (param field (p))
+ ELSE param nr out of range
+ FI
+ENDPROC dump ;
+
+TEXT PROC dump entry (PARAMDESCRIPTOR CONST id) :
+ object name := dump (id.type) ;
+ object name CAT text (id.access) ;
+ object name CAT dump (id.addr) ;
+ object name CAT dump (id.push opn) ;
+ object name
+ENDPROC dump entry ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 7. Datentypen Teil II 20.01.1986 *)
+(* *)
+(* Deklaration neuer Datentypen *)
+(* Vergleich von DTYPEs im Parameterfeld und in der Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+
+DTYPE VAR pt type ;
+
+PROC declare (TEXT CONST name, INT CONST size, align, DTYPE VAR type) :
+ entry into name table ;
+ put next permanent (permanent type) ;
+ put next permanent (size) ;
+ put next permanent (nt link) ;
+ mark no offsets of text elements .
+
+entry into name table :
+ declare object (name, nt link, CONCR (type)) .
+
+mark no offsets of text elements :
+ put next permanent (0)
+ENDPROC declare ;
+
+BOOL PROC same type (INT CONST param 1, param 2) :
+ INT CONST left type :: CONCR (param field [param 1].type) ;
+ IF left type = right type
+ THEN same fine structure if there is one
+ ELSE left type = undefined OR right type = undefined
+ FI .
+
+right type : CONCR (param field [param 2].type) .
+
+same fine structure if there is one :
+ IF left type = row THEN compare row
+ ELIF left type = struct THEN compare struct
+ ELSE TRUE
+ FI .
+
+compare row :
+ equal sizes AND same type (param1 + 1, param2 + 1) .
+
+equal sizes :
+ param field [param1+1].access = param field [param2+1].access .
+
+compare struct :
+ INT VAR p1 :: param1+1, p2 :: param2+1 ;
+ REP
+ IF NOT same type (p1, p2) THEN LEAVE same type WITH FALSE
+ ELIF end type found THEN LEAVE same type WITH TRUE
+ FI ;
+ NEXTPARAM p1 ;
+ NEXTPARAM p2
+ UNTIL end of field PER ;
+ FALSE .
+
+end type found :
+ CONCR (param field [p1].type) = end .
+
+end of field :
+ p1 > size of param field OR p2 > size of param field
+ENDPROC same type ;
+
+BOOL PROC same type (INT CONST param nr, DTYPE CONST type) :
+ field pointer := param nr ;
+ CONCR (pt type) := CONCR (type) ;
+ equal types
+ENDPROC same type ;
+
+BOOL PROC equal types :
+ identical types OR one type is undefined .
+
+one type is undefined :
+ type of actual field = undefined OR CONCR(pt type) = undefined .
+
+identical types :
+ SELECT type class (pt type) OF
+ CASE 0, 1, 2 : type of actual field = CONCR (pt type)
+ CASE 3 : perhaps equal rows
+ CASE 4 : perhaps equal structs
+ OTHERWISE FALSE
+ ENDSELECT .
+
+perhaps equal rows :
+ is row AND equal row sizes AND equal row types .
+
+is row :
+ type of actual field = row .
+
+perhaps equal structs :
+ is struct AND same type fields .
+
+is struct :
+ type of actual field = struct .
+
+equal row sizes :
+ pt row size = row size within param field .
+
+equal row types :
+ same type (field pointer + 1, pt row type) .
+
+pt row size :
+ cdb int (CONCR(pt type) + offset to row size) .
+
+pt row type :
+ CONCR (pt type) INCR 2 ;
+ pt type .
+
+row size within param field :
+ param field [field pointer].access .
+
+same type fields :
+ field pointer INCR 1 ;
+ CONCR (pt type) INCR 1 ;
+ REP
+ IF NOT equal types THEN LEAVE same type fields WITH FALSE FI ;
+ IF type of actual field = end
+ THEN LEAVE same type fields WITH TRUE
+ FI ;
+ NEXTPARAM field pointer
+ UNTIL end of field PER ;
+ FALSE .
+
+end of field :
+ field pointer > size of param field .
+
+type of actual field :
+ CONCR (param field [field pointer].type) .
+ENDPROC equal types ;
+
+BOOL PROC is not void bool or undefined (DTYPE CONST dtype) :
+ type <> void AND type <> bool AND type <> undefined .
+
+type : CONCR (dtype)
+ENDPROC is not void bool or undefined ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 8. Operationen Teil II 07.03.1986 *)
+(* *)
+(* Definition der Opcodes *)
+(* Deklaration, Definition, Identifikation und Applikation *)
+(* Eroeffnen und Schliessen eines Moduls *)
+(* *)
+(**************************************************************************)
+
+
+
+LET module not opened = "Module not opened" ,
+ define missing = "DEFINE missing" ,
+ wrong nr of params = "Wrong Nr. of Params:" ,
+ illegal kind = "Opcode expected" ,
+ nested module = "Nested Modules" ,
+ no mod nr = "Param Proc expected" ,
+ no immediate value = "Value expected" ,
+ type error = "Type Error" ,
+
+ q ln = 1 ,
+ q move = 2 , q move code = 2 048 ,
+ q inc1 = 3 , q inc1 code = 3 072 ,
+ q dec1 = 4 , q dec1 code = 4 096 ,
+ q inc = 5 , q inc code = 5 120 ,
+ q dec = 6 , q dec code = 6 144 ,
+ q add = 7 , q add code = 7 168 ,
+ q sub = 8 , q sub code = 8 192 ,
+ q clear = 9 , q clear code = 9 216 ,
+ q test = 10 ,
+ q equ = 11 , q equ code = 11 264 ,
+ q lsequ = 12 , q lsequ code = 12 288 ,
+ q fmove = 13 , q fmove code = 13 312 ,
+ q fadd = 14 , q fadd code = 14 336 ,
+ q fsub = 15 , q fsub code = 15 360 ,
+ q fmult = 16 , q fmult code = 16 384 ,
+ q fdiv = 17 , q fdiv code = 17 408 ,
+ q flsequ = 18 , q flsequ code = 18 432 ,
+ q tmove = 19 , q tmove code = 19 456 ,
+ q tequ = 20 , q tequ code = 20 480 ,
+ q accds = 21 , q access ds code = 22 528 ,
+ q ref = 22 , q ref code = 23 552 ,
+ q subscript = 23 , q subscript code = 24 576 ,
+ q select = 24 , q select code = 25 600 ,
+ q ppv = 25 ,
+ q pp = 26 ,
+ q make false = 27 , (* q make false code = 65 513 *)
+ q movex = 28 ,
+(* q longa subs q longa subs code = 65 376 *)
+ q return = 29 , q return code = 32 512 ,
+ q true return = 30 , q true return code = 32 513 ,
+ q false return = 31 , q false return code = 32 514 ,
+ q goret code = 32 519 ,
+ q esc mult = 32 , q esc mult code = 32 553 ,
+ q esc div = 33 , q esc div code = 32 554 ,
+ q esc mod = 34 , q esc mod code = 32 555 ,
+ q pproc = 35 ,
+ q compl int = 36 , q compl int code = 32 551 ,
+ q compl real = 37 , q compl real code = 32 550 ,
+(* q alias ds = 38 , *)
+ q movim = 39 , q esc movim code = 32 547 ,
+ q fequ = 40 , q fequ code = 32 548 ,
+ q tlsequ = 41 , q tlsequ code = 32 549 ,
+(* q case = 42 , *)
+ q plus = 43 ,
+ q minus = 44 ,
+ q mult = 45 ,
+ q int div = 46 ,
+ q real div = 47 ,
+ q equal = 48 ,
+ q lessequal = 49 ;
+
+INT CONST q make false code :: - 1 022 ,
+ q longa subs code :: - 159 ;
+
+
+ (***** Deklaration *****)
+
+PROC declare (OPN VAR operation) :
+ operation.kind := proc op ;
+ get module nr (operation.mod nr) ;
+ operation.top of stack := 0
+ENDPROC declare ;
+
+PROC declare (TEXT CONST name, INT CONST first, params, OPN VAR operation) :
+ declare (operation) ;
+ entry into name and pt table if necessary ;
+ enter params ;
+ enter result ;
+ enter module number .
+
+entry into name and pt table if necessary :
+ declare object (name, nt link, permanent pointer) .
+
+enter params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO params REP
+ enter param (param field [field pointer]) ;
+ NEXTPARAM field pointer
+ PER .
+
+enter result :
+ enter param (param field[field pointer].type, permanent proc op) .
+
+enter module number :
+ put next permanent (operation.mod nr)
+ENDPROC declare ;
+
+PROC enter param (PARAMDESCRIPTOR CONST param) :
+ IF param.access = const
+ THEN enter param (param.type, permanent param const)
+ ELIF param.access = var
+ THEN enter param (param.type, permanent param var)
+ ELSE errorstop ("Unknown Access")
+ FI
+ENDPROC enter param ;
+
+PROC enter param (DTYPE CONST type, INT CONST permanent mode) :
+ SELECT type class (type) OF
+ CASE 0, 1, 2 : put next permanent (CONCR(type) + permanent mode)
+ OTHERWISE errorstop ("Illegal Type")
+ ENDSELECT
+ENDPROC enter param ;
+
+
+ (***** Definition *****)
+
+PROC define (OPN VAR opn) :
+ IF NOT module open THEN errorstop (module not opened)
+ ELSE proc head (opn.mod nr, opn.top of stack)
+ FI
+ENDPROC define ;
+
+PROC set length of local storage (OPN VAR opn, INT CONST size) :
+ IF size < 0 OR size > local address limit
+ THEN errorstop (address overflow)
+ ELIF opn.top of stack = 0
+ THEN errorstop (define missing)
+ ELIF opn.kind <> proc op
+ THEN errorstop (proc op expected)
+ FI ;
+ set length (opn.top of stack, size + eumel0 stack offset)
+ENDPROC set length of local storage ;
+
+PROC define (OPN VAR operation, INT CONST size) :
+ define (operation) ;
+ set length of local storage (operation, size)
+ENDPROC define ;
+
+
+ (***** Identifikation *****)
+
+INT VAR counter, result index, result type repr;
+
+PROC identify (TEXT CONST name, INT CONST first, params, OPN VAR operation,
+ BOOL VAR object exists) :
+ find result entry ;
+ to object (name) ;
+ IF found THEN first fit and leave if found FI ;
+ IF eumel0 THEN identify eumel0 instruction
+ ELSE yield undefined operation
+ FI .
+
+find result entry :
+ result index := first;
+ counter := 0 ;
+ WHILE counter < params REP
+ NEXTPARAM result index ;
+ counter INCR 1
+ PER ;
+ check on param field exceeded .
+
+check on param field exceeded :
+ IF result index > size of param field
+ THEN errorstop (param field exceeded)
+ FI .
+
+yield undefined operation :
+ declare (result index, undefined type) ;
+ apply (result index, nop) ;
+ object exists := FALSE .
+
+first fit and leave if found :
+ WHILE yet another procedure exists REP
+ check one procedure and leave if match ;
+ next procedure
+ PER .
+
+yet another procedure exists :
+ permanent pointer <> 0 .
+
+check one procedure and leave if match:
+ param link := permanent pointer + wordlength ;
+ set end marker if end of list ;
+ counter := params ;
+ field pointer := 1 ;
+ REP
+ IF end of params AND counter = 0
+ THEN procedure found
+ ELIF end of params OR counter = 0
+ THEN LEAVE check one procedure and leave if match
+ ELSE check next param
+ FI
+ PER .
+
+check next param :
+ get type and mode (CONCR(pt type)) ;
+ IF same types THEN set param mode ;
+ counter DECR 1 ;
+ field pointer INCR 1 ;
+ next pt param
+ ELSE LEAVE check one procedure and leave if match
+ FI .
+
+same types : (* inline version ! *)
+ equal types .
+
+set param mode :
+ param field [field pointer].access := mode .
+
+procedure found :
+ get result ;
+ operation.kind := proc op ;
+ operation.mod nr := module number ;
+ operation.top of stack := 0 ;
+ object exists := TRUE ;
+ LEAVE identify .
+
+get result :
+ get type and mode (result type) ;
+ declare (result index, mode) .
+
+module number :
+ cdbint (param link + 1) .
+
+result type :
+ CONCR (param field [result index].type) .
+
+eumel0 :
+ eumel0 opn.mod nr := link (eumel 0 opcodes, name) ;
+ eumel0 opn.mod nr <> 0 .
+
+identify eumel 0 instruction :
+ init result type with void ;
+ CONCR (operation) := CONCR (eumel0 opn) ;
+ object exists := check params and set result ;
+ declare (result index, DTYPE:(result type repr)) ;
+ declare (result index, const) .
+
+init result type with void :
+ result type repr := void .
+
+check params and set result :
+ SELECT operation.mod nr OF
+ CASE q return, q false return, q true return : no params
+ CASE q inc1, q dec1 : one int param yielding void
+ CASE q pproc, q pp, q ln : one param yielding void
+ CASE q test : one param yielding bool
+ CASE q clear, q ppv : one int or bool param yielding void
+ CASE q make false : one bool param yielding void
+ CASE q move : two int or bool params yielding void
+ CASE q compl int, q inc, q dec : two int params yielding void
+ CASE q compl real, q fmove : two real params yielding void
+ CASE q equ, q lsequ : two int params yielding bool
+ CASE q fequ, q flsequ : two real params yielding bool
+ CASE q tequ, q tlsequ : two text params yielding bool
+ CASE q tmove : two text params yielding void
+ CASE q accds, q ref : two params yielding void
+ CASE q add, q sub, q esc mult,
+ q esc div, q esc mod : three int params yielding void
+ CASE q fadd, q fsub, q fmult, q fdiv : three real params yielding void
+ CASE q select, q movex : three params
+ CASE q subscript : five params
+ CASE q plus, q minus, q mult : two intreals yielding intreal
+ CASE q int div : two int params yielding int
+ CASE q real div : two real params yielding real
+ CASE q equal, q lessequal : two intrealtexts yielding bool
+ OTHERWISE FALSE
+ ENDSELECT .
+
+no params :
+ params = 0 .
+
+one int param yielding void :
+ p1 void (int type, first, params) .
+
+one param yielding void :
+ params = 1 .
+
+one param yielding bool :
+ IF params = 1 THEN result type repr := bool ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+one int or bool param yielding void :
+ p1 void (int type, first, params) OR p1 void (bool type, first, params) .
+
+one bool param yielding void :
+ p1 void (bool type, first, params) .
+
+two int or bool params yielding void :
+ p2 (int type, first, params, void) OR
+ p2 (bool type, first, params, void) .
+
+two int params yielding void :
+ p2 (int type, first, params, void) .
+
+two real params yielding void :
+ p2 (real type, first, params, void) .
+
+two text params yielding void :
+ p2 (text type, first, params, void) .
+
+two int params yielding bool :
+ p2 (int type, first, params, bool) .
+
+two real params yielding bool :
+ p2 (real type, first, params, bool) .
+
+two text params yielding bool :
+ p2 (text type, first, params, bool) .
+
+two params yielding void :
+ params = 2 .
+
+three int params yielding void :
+ p3 void (int type, first, params) .
+
+three real params yielding void :
+ p3 void (real type, first, params) .
+
+three params :
+ params = 3 .
+
+five params :
+ params = 5 .
+
+two intreals yielding intreal :
+ two int params yielding int OR two real params yielding real .
+
+two intrealtexts yielding bool :
+ two int params yielding bool OR two real params yielding bool OR
+ two text params yielding bool .
+
+two int params yielding int :
+ p2 (int type, first, params, int) .
+
+two real params yielding real :
+ p2 (real type, first, params, real)
+ENDPROC identify ;
+
+BOOL PROC p1 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 1 AND param type is requested plain type .
+
+param type is requested plain type :
+ CONCR (param field [first].type) = CONCR (requested type)
+
+ENDPROC p1 void ;
+
+BOOL PROC p2 (DTYPE CONST requested type, INT CONST first, param nr,
+ INT CONST result type) :
+ IF param nr = 2 AND param types equal requested plain type
+ THEN result type repr := result type ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+param types equal requested plain type :
+ CONCR (param field [first] .type) = CONCR (requested type) AND
+ CONCR (param field [first+1].type) = CONCR (requested type)
+
+ENDPROC p2 ;
+
+BOOL PROC p3 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 3 AND param types ok .
+
+param types ok :
+ FOR index FROM first UPTO first+2 REP
+ IF different param types THEN LEAVE p3 void WITH FALSE FI
+ PER ;
+ TRUE .
+
+different param types :
+ CONCR (param field [index].type) <> CONCR (requested type)
+ENDPROC p3 void;
+
+
+ (***** Applikation *****)
+
+INT VAR address representation, left repr, right repr, result repr;
+
+PROC apply (INT CONST first, nr of params, OPN CONST opn) :
+ IF NOT module open THEN errorstop (module not opened) FI ;
+ SELECT opn.kind OF
+ CASE eumel 0 : generate eumel0 instruction
+ CASE proc op : call operation
+ CASE param proc : call param proc
+ CASE nil :
+ OTHERWISE errorstop (illegal kind)
+ ENDSELECT .
+
+call operation :
+ push params if necessary (first, nr of params, opn.mod nr) ;
+ call (opn.mod nr) .
+
+call param proc :
+ result addr.kind := local ref ;
+ result addr.value := opn.mod nr ;
+ address representation := REPR result addr ;
+ push params if necessary (first, nr of params, address representation) ;
+ call param (address representation) .
+
+generate eumel0 instruction :
+ SELECT real nr of params OF
+ CASE 0 : p0 instruction
+ CASE 1 : apply p1 (opn, first addr)
+ CASE 2 : apply p2 (opn, first addr, second addr)
+ CASE 3 : apply p3 (opn, left type, first addr, second addr, third addr)
+ CASE 5 : subscript operation
+ OTHERWISE errorstop (wrong nr of params + text (nr of params))
+ ENDSELECT .
+
+real nr of params :
+ IF operator denotation THEN nr of params + 1
+ ELSE nr of params
+ FI .
+
+operator denotation :
+ opn.mod nr >= q plus .
+
+p0 instruction :
+ IF opn.mod nr = q return THEN s0 (q return code)
+ ELIF opn.mod nr = q true return THEN s0 (q true return code)
+ ELIF opn.mod nr = q false return THEN s0 (q false return code)
+ ELSE errorstop (wrong nr of params +
+ mnemonic (opn))
+ FI .
+
+subscript operation :
+ IF opn.mod nr = q subscript
+ THEN subscription
+ ELSE errorstop (wrong nr of params + text (nr of params))
+ FI .
+
+subscription :
+ ADDRESS CONST element length :: param field [first+2].addr ,
+ limit :: param field [first+3].addr ;
+ check on immediates ;
+ IF element length.value < 1024
+ THEN s0 (q subscript code + element length.value)
+ ELSE s0 (q longa subs code) ;
+ s0 (element length.value)
+ FI ;
+ s3 (limit.value - 1, subs index, base addr, subs result) .
+
+check on immediates :
+ IF element length.kind <> immediate value OR
+ limit.kind <> immediate value
+ THEN errorstop (no immediate value)
+ FI .
+
+subs index : REPR param field [first+1].addr .
+
+base addr : REPR param field [first].addr .
+
+subs result : REPR param field [first+4].addr .
+
+first addr :
+ param field [first].addr .
+
+left type :
+ param field [first].type .
+
+second addr :
+ param field [nextparam (first)].addr .
+
+third addr :
+ param field [nextparam(nextparam(first))].addr
+ENDPROC apply ;
+
+PROC push params if necessary (INT CONST first, nr of params, mod nr) :
+ init param push (mod nr) ;
+ IF nr of params > 0 THEN push params ;
+ push result if there is one
+ FI .
+
+push params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO nr of params REP
+ apply p1 (push code, param addr) ;
+ NEXTPARAM field pointer
+ PER .
+
+push code :
+ param field [field pointer].push opn .
+
+param addr :
+ param field [field pointer].addr .
+
+push result if there is one :
+ IF push result necessary
+ THEN push result address (REPR param field [field pointer].addr)
+ FI .
+
+push result necessary :
+ param field [field pointer].push opn.kind <> nil AND
+ is not void bool or undefined (param field [field pointer].type)
+ENDPROC push params if necessary ;
+
+PROC apply p1 (OPN CONST opn, ADDRESS CONST addr) :
+ IF opn.mod nr = q ln THEN generate line number
+ ELIF opn.mod nr = q pproc THEN push module nr
+ ELSE gen p1 instruction
+ FI .
+
+gen p1 instruction :
+ address representation := REPR addr ;
+ SELECT opn.mod nr OF
+ CASE q inc1 : t1 (q inc1 code, address representation)
+ CASE q dec1 : t1 (q dec1 code, address representation)
+ CASE q clear : t1 (q clear code,address representation)
+ CASE q test : test bool object (address representation)
+ CASE q pp : push param (address representation)
+ CASE q make false : s1 (q make false code, address representation)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+generate line number :
+ IF addr.kind = immediate value THEN mark line (addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+push module nr :
+ IF addr.kind = module nr THEN push param proc (addr.value)
+ ELSE errorstop (no mod nr)
+ FI
+ENDPROC apply p1;
+
+PROC apply p2 (OPN CONST opn, ADDRESS CONST left addr, right addr):
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movim THEN move immediate
+ ELSE gen p2 instruction
+ FI .
+
+gen p2 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q move : t2 (q move code, right repr, left repr)
+ CASE q inc : t2 (q inc code, right repr, left repr)
+ CASE q dec : t2 (q dec code, right repr, left repr)
+ CASE q equ : compare (q equ code, left repr, right repr)
+ CASE q lsequ : compare (q lsequ code, left repr, right repr)
+ CASE q fmove : t2 (q fmove code, right repr, left repr)
+ CASE q flsequ : compare (q flsequ code, left repr, right repr)
+ CASE q tmove : t2 (q tmove code, right repr, left repr)
+ CASE q tequ : compare (q tequ code, left repr, right repr)
+ CASE q compl int : s2 (q compl int code, left repr, right repr)
+ CASE q compl real : s2 (q compl real code, left repr, right repr)
+ CASE q fequ : compare (q fequ code, left repr, right repr)
+ CASE q tlsequ : compare (q tlsequ code, left repr, right repr)
+ CASE q accds : t2 (q access ds code, left repr, right repr)
+ CASE q ref : t2 (q ref code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+move immediate :
+ IF right addr.kind = immediate value
+ THEN s0 (q esc movim code) ;
+ s1 (left repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI
+ENDPROC apply p2;
+
+PROC apply p3 (OPN CONST opn, DTYPE CONST left dtype,
+ ADDRESS CONST left addr, right addr, result addr ):
+ left repr := REPR left addr ;
+ result repr := REPR result addr ;
+ IF opn.mod nr = q select THEN gen select instruction
+ ELIF opn.mod nr = q movex THEN gen long move
+ ELSE gen p3 instruction
+ FI .
+
+gen p3 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q add : int add
+ CASE q sub : int sub
+ CASE q fadd : real add
+ CASE q fsub : real sub
+ CASE q fmult : real mult
+ CASE q fdiv, q real div : real div
+ CASE q esc mult : int mult
+ CASE q esc div, q int div : int div
+ CASE q esc mod : int mod
+ CASE q plus : int real add
+ CASE q minus : int real sub
+ CASE q mult : int real mult
+ CASE q equal, q lessequal : compare (comp code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+gen select instruction :
+ IF right addr.kind = immediate value
+ THEN t1 (q select code, left repr) ;
+ s1 (right addr.value, result repr)
+ ELSE errorstop (no immediate value)
+ FI .
+
+gen long move :
+ IF right addr.kind = immediate value
+ THEN long move (left repr, result repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+int add : compute (q add code, left repr, right repr, result repr) .
+
+int sub : compute (q sub code, left repr, right repr, result repr) .
+
+real add : compute (q fadd code, left repr, right repr, result repr) .
+
+real sub : compute (q fsub code, left repr, right repr, result repr) .
+
+real mult : compute (q fmult code, left repr, right repr, result repr) .
+
+real div : compute (q fdiv code, left repr, right repr, result repr) .
+
+int mult : s3 (q esc mult code, left repr, right repr, result repr) .
+
+int div : s3 (q esc div code, left repr, right repr, result repr) .
+
+int mod : s3 (q esc mod code, left repr, right repr, result repr) .
+
+int real add :
+ IF left type = int THEN int add
+ ELSE real add
+ FI .
+
+int real sub :
+ IF left type = int THEN int sub
+ ELSE real sub
+ FI .
+
+int real mult :
+ IF left type = int THEN int mult
+ ELSE real mult
+ FI .
+
+comp code :
+ SELECT left type OF
+ CASE int : IF opn.mod nr = q equal THEN q equ ELSE q lsequ FI
+ CASE real : IF opn.mod nr = q equal THEN q fequ ELSE q flsequ FI
+ CASE string : IF opn.mod nr = q equal THEN q tequ ELSE q tlsequ FI
+ OTHERWISE errorstop (type error); q equ
+ ENDSELECT .
+
+left type : CONCR (left dtype)
+
+ENDPROC apply p3;
+
+
+ (***** Modul *****)
+
+BOOL VAR module open ;
+
+.init opn section :
+ module open := FALSE .;
+
+PROC begin module :
+ IF module open THEN errorstop (nested module)
+ ELSE begin modul ;
+ module open := TRUE
+ FI
+ENDPROC begin module ;
+
+PROC end module :
+ IF NOT module open
+ THEN errorstop (module not opened)
+ ELSE end modul ;
+ module open := FALSE
+ FI
+ENDPROC end module ;
+
+TEXT PROC dump (OPN CONST operation) :
+ IF operation.kind = proc op THEN " PROC" + text (operation.mod nr, 5)
+ ELIF operation.kind = eumel 0 THEN " EUMEL0: " + mnemonic (operation)
+ ELSE " undef. Opn"
+ FI
+ENDPROC dump ;
+
+PROC begin modul :
+ EXTERNAL 10072
+ENDPROC begin modul ;
+
+PROC end modul :
+ EXTERNAL 10011
+ENDPROC end modul ;
+
+PROC proc head (INT VAR mod nr, top of stack) :
+ EXTERNAL 10012
+ENDPROC proc head ;
+
+PROC set length (INT CONST top of stack, size) :
+ EXTERNAL 10013
+ENDPROC set length ;
+
+PROC get module nr (INT VAR module nr) :
+ EXTERNAL 10016
+ENDPROC get module nr ;
+
+PROC compute (INT CONST op code, l addr, r addr, result address) :
+ EXTERNAL 10017
+ENDPROC compute ;
+
+PROC compare (INT CONST op code, l addr, r addr) :
+ EXTERNAL 10018
+ENDPROC compare ;
+
+PROC long move (INT CONST to, from, length) :
+ EXTERNAL 10019
+ENDPROC long move ;
+
+PROC put next permanent (INT CONST permanent value) :
+ EXTERNAL 10020
+ENDPROC put next permanent ;
+
+PROC call (INT CONST mod nr) :
+ EXTERNAL 10022
+ENDPROC call ;
+
+PROC call param (INT CONST mod nr) :
+ EXTERNAL 10023
+ENDPROC call param ;
+
+PROC push param (INT CONST addr) :
+ EXTERNAL 10024
+ENDPROC push param ;
+
+PROC push param proc (INT CONST mod nr) :
+ EXTERNAL 10025
+ENDPROC push param proc ;
+
+PROC init param push (INT CONST mod nr) :
+ EXTERNAL 10026
+ENDPROC init param push ;
+
+PROC push result address (INT CONST addr) :
+ EXTERNAL 10027
+ENDPROC push result address ;
+
+PROC test bool object (INT CONST addr) :
+ EXTERNAL 10187
+ENDPROC test bool object ;
+
+PROC mark line (INT CONST line number) :
+ EXTERNAL 10030
+ENDPROC mark line ;
+
+PROC s0 (INT CONST op code) :
+ EXTERNAL 10038
+ENDPROC s0 ;
+
+PROC s1 (INT CONST op code, addr) :
+ EXTERNAL 10039
+ENDPROC s1 ;
+
+PROC s2 (INT CONST op code , addr1, addr2) :
+ EXTERNAL 10040
+ENDPROC s2 ;
+
+PROC s3 (INT CONST op code, addr1, addr2, addr3) :
+ EXTERNAL 10041
+ENDPROC s3 ;
+
+PROC t1 (INT CONST op code, addr) :
+ EXTERNAL 10042
+ENDPROC t1 ;
+
+PROC t2 (INT CONST op code, addr1, addr2) :
+ EXTERNAL 10043
+ENDPROC t2 ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 9. Speicherverwaltung 21.03.1986 *)
+(* *)
+(* Ablage der Paketdaten *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR address value;
+
+INT CONST data allocation by coder := 1 ,
+ data allocation by user := 2 ;
+
+LET not initialized = 0 ,
+ wrong mm mode = "Wrong MM Mode" ,
+ define on non global = "Define for GLOB only" ,
+ text too long = "TEXT too long" ;
+
+TEXT VAR const buffer :: point line ;
+
+.reset memory management mode :
+ memory management mode := not initialized . ;
+
+PROC reserve storage (INT CONST size) :
+ IF memory management mode <> data allocation by user
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (address value, size) ;
+ memory management mode := not initialized
+ENDPROC reserve storage ;
+
+PROC allocate variable (ADDRESS VAR addr, INT CONST size) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (addr.value, size) ;
+ addr.kind := global
+ENDPROC allocate variable ;
+
+PROC allocate denoter (ADDRESS VAR addr, INT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate int denoter (addr.value) ;
+ put data word (value, addr.value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, REAL CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate real denoter (addr.value) ;
+ addr.kind := global ;
+ define (addr, value)
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, TEXT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate text denoter (addr.value, (LENGTH value+1) DIV 2 + 2) ;
+ addr.kind := global ;
+ skip heaplink;
+ define (addr, value) ;
+ reset heaplink .
+
+skip heaplink :
+ addr.value INCR 1 .
+
+reset heaplink :
+ addr.value DECR 1
+ENDPROC allocate denoter ;
+
+PROC define (ADDRESS CONST addr, INT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value, addr.value)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, REAL CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ replace (const buffer, 1, value) ;
+ address value := addr.value ;
+ FOR index FROM 1 UPTO 4 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, TEXT CONST value) :
+ IF addr.kind <> global THEN errorstop (define on non global)
+ ELIF LENGTH value > 255 THEN errorstop (text too long)
+ FI ;
+ address value := addr.value ;
+ const buffer := code (LENGTH value) ;
+ const buffer CAT value ;
+ const buffer CAT " " ;
+ FOR index FROM 1 UPTO LENGTH const buffer DIV 2 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER ;
+ const buffer := point line
+ENDPROC define ;
+
+PROC prep pbase (INT VAR offset) :
+ EXTERNAL 10032
+ENDPROC prep pbase;
+
+PROC allocate var (INT VAR addr, INT CONST length) :
+ EXTERNAL 10033
+ENDPROC allocate var ;
+
+PROC allocate int denoter (INT VAR addr) :
+ EXTERNAL 10034
+ENDPROC allocate int denoter ;
+
+PROC allocate real denoter (INT VAR addr) :
+ EXTERNAL 10035
+ENDPROC allocate real denoter ;
+
+PROC allocate text denoter (INT VAR addr, INT CONST length) :
+ EXTERNAL 10036
+ENDPROC allocate text denoter ;
+
+PROC put data word (INT CONST value, INT CONST addr) :
+ EXTERNAL 10037
+ENDPROC put data word ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 08.01.1986 *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR line number, pattern length, packet link,
+ begin of packet, last packet entry, indentation;
+
+TEXT VAR bulletin name, type and mode, pattern, buffer;
+
+DATASPACE VAR bulletin ds :: nilspace ;
+
+.packet name :
+ cdb text (cdb int(packet link + wordlength) + two word length) .
+
+.within editor :
+ aktueller editor > 0 . ;
+
+TEXT PROC type name (DTYPE CONST type) :
+ type and mode := "" ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC type name ;
+
+TEXT PROC dump (DTYPE CONST type) :
+ type and mode := "TYPE " ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC dump ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void :
+ CASE int : type and mode CAT "INT"
+ CASE real : type and mode CAT "REAL"
+ CASE string : type and mode CAT "TEXT"
+ CASE bool, bool result : type and mode CAT "BOOL"
+ CASE dataspace : type and mode CAT "DATASPACE"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+PROC help (TEXT CONST proc name) :
+ prep bulletin ;
+ prep help ;
+ scan (object name) ;
+ next symbol (pattern) ;
+ packet link := end of permanent table ;
+ IF function = 0 THEN standard help
+ ELSE asterisk help
+ FI .
+
+prep help :
+ object name := compress (proc name) ;
+ INT VAR function :: 0 ;
+ INT CONST l :: LENGTH object name ;
+ IF l > 1 AND object name <> "**"
+ THEN IF (object name SUB l) = "*"
+ THEN function INCR 2 ;
+ delete char (object name, l)
+ FI ;
+ IF (object name SUB 1) = "*"
+ THEN function INCR 1 ;
+ delete char (object name, 1)
+ FI ;
+ IF another asterisk THEN wrong function FI
+ FI.
+
+another asterisk :
+ pos (object name, "*") <> 0 .
+
+wrong function :
+ errorstop ("unzulaessige Sternfunktion") .
+
+standard help :
+ to object (pattern) ;
+ IF found THEN display
+ ELSE error stop ("unbekannt: " + proc name)
+ FI .
+
+display :
+ WHILE permanent pointer <> 0 REP
+ put name of packet if necessary ;
+ put specifications (pattern) ;
+ next procedure
+ ENDREP ;
+ show bulletin file .
+
+put name of packet if necessary :
+ IF new packet THEN packet link := permanent pointer ;
+ find begin of packet ;
+ writeline (2) ;
+ write packet name
+ FI .
+
+find begin of packet :
+ REP
+ packet link DECR wordlength
+ UNTIL begin of packet found PER .
+
+begin of packet found :
+ cdb int (packet link) = permanent packet .
+
+new packet :
+ permanent pointer < packet link .
+
+asterisk help :
+ hash table pointer := begin of hash table ;
+ pattern length := LENGTH pattern - 1 ;
+ REP
+ list all objects in current hash table chain ;
+ next hash entry
+ UNTIL end of hash table reached ENDREP ;
+ show bulletin file .
+
+list all objects in current hash table chain :
+ nt link := hash table pointer ;
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length) ;
+ IF matching THEN into bulletin FI
+ PER .
+
+matching :
+ INT CONST p :: pos (object name, pattern) ;
+ SELECT function OF
+ CASE 1 : p <> 0 AND p = LENGTH object name - pattern length
+ CASE 2 : p = 1
+ CASE 3 : p <> 0
+ OTHERWISE FALSE
+ ENDSELECT .
+
+into bulletin :
+ object names into bulletin (BOOL PROC not end of chain)
+ENDPROC help ;
+
+BOOL PROC not end of chain :
+ permanent pointer <> 0
+ENDPROC not end of chain ;
+
+PROC write packet name :
+ indentation := 0 ;
+ write line ;
+ write bulletin line ("PACKET ") ;
+ indentation := 7 ;
+ object name := packet name ;
+ write bulletin line (object name) ;
+ write bulletin line (":") ;
+ writeline (2)
+ENDPROC write packet name ;
+
+PROC put specifications (TEXT CONST proc name) :
+ put obj name (proc name) ;
+ to first param ;
+ IF NOT end of params THEN put param list FI ;
+ put result ;
+ writeline .
+
+to first param :
+ param link := permanent pointer + word length ;
+ set end marker if end of list .
+
+put result :
+ INT VAR type;
+ get type and mode (type) ;
+ IF type <> void THEN type and mode := " --> " ;
+ name of type (type) ;
+ write bulletin line (type and mode)
+ FI
+ENDPROC put specifications ;
+
+PROC put param list :
+ write bulletin line (" (") ;
+ REP
+ INT VAR type;
+ get type and mode (type) ;
+ put type and mode ;
+ maybe param proc ;
+ next pt param ;
+ IF end of params THEN write bulletin line (")") ;
+ LEAVE put param list
+ FI ;
+ write bulletin line (", ") ;
+ PER .
+
+put type and mode :
+ type and mode := "" ;
+ name of type (type) ;
+ type and mode CAT name of mode ;
+ write bulletin line (type and mode) .
+
+name of mode :
+ IF mode = const THEN " CONST"
+ ELIF mode = var THEN " VAR"
+ ELSE " PROC"
+ FI .
+
+maybe param proc :
+ IF mode = permanent param proc THEN put virtual params FI .
+
+put virtual params :
+ skip over result type if complex type ;
+ IF NOT end of virtual params THEN put param list FI.
+
+skip over result type if complex type :
+ next pt param .
+
+end of virtual params :
+ end of params
+ENDPROC put param list ;
+
+PROC next packet :
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word = permanent packet THEN true return
+ ELIF end of permanents THEN false return
+ FI ;
+ ENDREP .
+
+true return :
+ found := TRUE ;
+ LEAVE next packet .
+
+false return :
+ found := FALSE ;
+ LEAVE next packet .
+
+end of permanents :
+ word = permanent end OR packet link > end of permanent table
+ENDPROC next packet ;
+
+PROC prep bulletin :
+ forget (bulletin ds) ;
+ bulletin ds := nilspace ;
+ bulletin file := sequential file (output, bulletin ds) ;
+ line number := 0 ;
+ buffer := ""
+ENDPROC prep bulletin ;
+
+PROC show bulletin file :
+ IF within editor THEN ueberschrift neu FI ;
+ DATASPACE VAR local ds :: bulletin ds ;
+ FILE VAR local file :: sequential file (modify, local ds) ;
+ edit (local file) ;
+ forget (local ds)
+ENDPROC show bulletin file ;
+
+PROC write bulletin line (TEXT CONST line) :
+ IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ;
+ buffer CAT line
+ENDPROC write bulletin line ;
+
+PROC writeline :
+ write (bulletin file, buffer) ;
+ line (bulletin file) ;
+ line number INCR 1 ;
+ cout (line number) ;
+ buffer := indentation * " "
+ENDPROC writeline ;
+
+PROC writeline (INT CONST times) :
+ IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
+ writeline
+ ELSE index := times
+ FI ;
+ line (bulletin file, index) ;
+ line number INCR index;
+ indentation := 0 ;
+ cout (line number)
+ENDPROC writeline ;
+
+PROC bulletin (TEXT CONST packet name) :
+ prep bulletin ;
+ scan (packet name) ;
+ next symbol (pattern) ;
+ to packet ;
+ IF found THEN list packet ;
+ show bulletin file
+ ELSE error stop (packet name + " ist kein Paketname")
+ FI .
+
+to packet :
+ last packet entry := 0 ;
+ get nametab link of packet name ;
+ packet link := before first pt entry ;
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word < 0 THEN IF word = permanent packet THEN packet found
+ ELIF word = permanent end THEN return
+ FI
+ FI
+ ENDREP .
+
+get nametab link of packet name :
+ to object (pattern) ;
+ IF NOT found THEN error stop ("unbekanntes Paket :" + packet name) ;
+ LEAVE to packet
+ FI .
+
+packet found :
+ IF cdb int (packet link + wordlength) = nt link
+ THEN last packet entry := packet link FI .
+
+return :
+ IF last packet entry <> 0 THEN found := TRUE ;
+ packet link := last packet entry
+ ELSE found := FALSE
+ FI ;
+ LEAVE to packet
+ENDPROC bulletin ;
+
+PROC list packet :
+ begin of packet := packet link + word length ;
+ write packet name ;
+ find end of packet ;
+ run through nametab and list all packet objects .
+
+find end of packet :
+ last packet entry := begin of packet ;
+ REP
+ last packet entry INCR wordlength ;
+ word := cdb int (last packet entry) ;
+ UNTIL end of packet entries PER .
+
+end of packet entries :
+ word = permanent packet OR word = permanent end .
+
+run through nametab and list all packet objects :
+ hashtable pointer := begin of hashtable ;
+ REP
+ nt link := hashtable pointer ;
+ list objects of current packet in this chain ;
+ next hash entry
+ UNTIL end of hashtable reached ENDREP .
+
+list objects of current packet in this chain :
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ put objects of this name
+ PER .
+
+put objects of this name :
+ IF there is at least one object of this name in the current packet
+ THEN into bulletin FI .
+
+there is at least one object of this name in the current packet :
+ REP
+ IF permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ THEN LEAVE there is at least one object of this name
+ in the current packet WITH TRUE FI ;
+ next procedure
+ UNTIL permanent pointer = 0 PER ;
+ FALSE .
+
+into bulletin :
+ object name := cdb text (nt link + two word length) ;
+ object names into bulletin (BOOL PROC within packet)
+ENDPROC list packet ;
+
+BOOL PROC within packet :
+ permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ENDPROC within packet ;
+
+PROC object names into bulletin (BOOL PROC link ok) :
+ scan (object name) ;
+ next symbol (object name, mode) ;
+ IF type definition THEN put type definition
+ ELSE put object definitions
+ FI .
+
+type definition :
+ mode = bold AND no params .
+
+no params :
+ cdb int (permanent pointer + word length) >= permanent type .
+
+put type definition :
+ put obj name (object name) ;
+ write bulletin line ("TYPE ") ;
+ writeline (1) .
+
+put object definitions :
+ WHILE link ok REP
+ put specifications (object name) ;
+ next procedure
+ ENDREP
+ENDPROC object names into bulletin ;
+
+PROC bulletin :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ list packet ;
+ write line (4) ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC bulletin ;
+
+PROC put obj name (TEXT CONST name) :
+ buffer := " " ;
+ bulletin name := point line ;
+ change (bulletin name, 1, end of line or name, name) ;
+ buffer CAT bulletin name ;
+ indentation := LENGTH buffer + 1 .
+
+end of line or name :
+ min (LENGTH name, LENGTH bulletin name)
+ENDPROC put obj name ;
+
+PROC packets :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ object name := packet name ;
+ put obj name (object name) ;
+ write line ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC packets ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 11. ELAN Run-Interface 09.01.1986 *)
+(* *)
+(* Uebersetzen von ELAN-Programmen *)
+(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *)
+(* *)
+(**************************************************************************)
+
+
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ listing enabled := FALSE ;
+
+FILE VAR listing file ;
+
+TEXT VAR listing file name := "" ;
+
+
+PROC run (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, no ins)
+END PROC run;
+
+PROC run :
+ run (last param)
+ENDPROC run ;
+
+PROC run again :
+ IF run again mod nr <> 0
+ THEN elan (run again mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+ ELSE errorstop ("'run again' nicht moeglich")
+ FI
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, ins)
+ENDPROC insert ;
+
+PROC insert :
+ insert (last param)
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+ FILE VAR source := sequential file (modify, file name) ;
+ IF listing enabled
+ THEN open listing file
+ FI ;
+
+ disable stop ;
+ no do again ;
+ elan (compile file mode, source, "" , run again mod nr,
+ insert option, list option, check option, sermon) ;
+
+ IF anything noted AND command dialogue
+ THEN ignore halt during compiling ;
+ note edit (source) ;
+ errorstop ("")
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+open listing file :
+ listing file := sequential file (output, listing file name) ;
+ max line length (listing file, 130)
+
+ENDPROC run elan ;
+(*
+PROC out text (TEXT CONST text, INT CONST out type) :
+ INTERNAL 257 ;
+ IF online
+ THEN out (text)
+ FI ;
+ IF out type = error message
+ THEN note (text) ;
+ number of errors INCR 1
+ ELIF out type = warning message
+ THEN note (text)
+ FI ;
+ IF listing enabled
+ THEN write (listing file, text)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+ INTERNAL 258 ;
+ IF online
+ THEN out (""13""10"")
+ FI ;
+ IF out type = error message OR out type = warning message
+ THEN note line
+ ELIF listing enabled
+ THEN line (listing file)
+ FI
+ENDPROC out line ;
+*)
+PROC prot (TEXT CONST file name) :
+ list option := TRUE ;
+ listing file name := file name ;
+ listing enabled := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE ;
+ listing enabled := FALSE
+ENDPROC prot off ;
+
+BOOL PROC prot :
+ list option
+ENDPROC prot ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+BOOL PROC check :
+ check option
+ENDPROC check ;
+
+ENDPACKET eumel coder ;
diff --git a/system/eumel-coder/1.8.0/src/eumel coder 1.8.0_mod b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0_mod
new file mode 100644
index 0000000..6914548
--- /dev/null
+++ b/system/eumel-coder/1.8.0/src/eumel coder 1.8.0_mod
@@ -0,0 +1,2043 @@
+PACKET eumel coder (* Autor: U. Bartling *)
+ DEFINES coder on, coder off, (* 1.8.0-Korr. M.St. *)
+ declare, define, apply, identify, (* 21.11.86 *)
+ :=, =, (* EXTERNAL 10...Nummern*)
+ dump, (* und coderon-flags *)
+ (* inspector/coder1 weg *)
+ LABEL,
+ gosub, goret,
+ complement condition code,
+
+ ADDRESS ,
+ GLOB, LOC, REF, DEREF,
+ ref length,
+ +,
+ adjust,
+ is global, is local, is ref,
+
+ DTYPE,
+ type class, type name,
+ void type, int type, real type, text type, bool type,
+ dataspace type, undefined type,
+ row type, struct type, proc type, end type,
+
+ OPN,
+ set length of local storage,
+ begin module, end module,
+ is proc, is eumel 0 instruction,
+ address, operation,
+ nop,
+ init op codes,
+ mnemonic,
+
+ parameter,
+ next param,
+ NEXTPARAM,
+ access ,
+ dtype ,
+ param address,
+ same type ,
+
+ reserve storage,
+ allocate denoter ,
+ allocate variable,
+ data allocation by coder ,
+ data allocation by user :
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 13.02.1986 *)
+(* Stand der Implementation : 21.03.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR memory management mode, global address offset,
+ nt link, permanent pointer, param link, index, mode, field pointer;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 12.03.1986 *)
+(* 1.7.5.4 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+(* before first pt entry = 22784 , *)
+(* first permanent entry = 22785 , *)
+(* end of permanent table = 32767 , *)
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+ four word length = 4 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+(* permanent param proc end marker = 0 , *)
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+ offset to row size = 12785 ,
+
+ void = 0 ,
+ int = 1 ,
+ real = 2 ,
+ string = 3 ,
+ bool = 5 ,
+ bool result = 6 ,
+ dataspace = 7 ,
+ undefined = 9 ,
+ row = 10 ,
+ struct = 11 ,
+ end = 0 ,
+
+ const = 1 ,
+ var = 2 ,
+(* proc = 3 , *)
+(* denoter = 5 , *)
+(* bold = 2 , *)
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+(* run again mode = 0 , *)
+(* compile file mode = 1 , *)
+ prep coder mode = 5 ,
+
+(* warning message = 2 , *)
+(* error message = 4 , *)
+
+ point line = "..............." ;
+(*
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+*)
+BOOL VAR coder active := FALSE ;
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+LET invalid coder off = "CODER not active" ;
+
+PROC coder on (INT CONST data allocation mode) :
+ mark coder on ;
+ init memory management ;
+ init opn section ;
+ init compiler .
+
+mark coder on :
+ coder active := TRUE .
+
+init memory management :
+ memory management mode := data allocation mode ;
+ prep pbase (global address offset) .
+
+init compiler :
+ no do again ;
+ elan (prep coder mode, bulletin file, "", run again mod nr,
+ no ins, prot, check, no sermon) (* prot, check f.test, M.St. *)
+
+ENDPROC coder on;
+
+PROC coder off (BOOL CONST insert, sermon, OPN CONST start proc) :
+ IF coder active
+ THEN mark coder off ;
+ end coder (insert, sermon, start mod nr if no insert)
+ ELSE errorstop (invalid coder off)
+ FI .
+
+start mod nr if no insert :
+ IF insert THEN run again mod nr := 0
+ ELSE run again mod nr := start proc.mod nr
+ FI ;
+ run again mod nr .
+
+mark coder off :
+ reset memory management mode ;
+ init opn section ;
+ coder active := FALSE
+ENDPROC coder off ;
+
+PROC end coder (BOOL CONST insert wanted, sermon wanted, INT CONST mod) :
+ EXTERNAL 10021
+ENDPROC end coder ;
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+ (***** Hash/Namenstabelle *****)
+
+. yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ next pt param ;
+ mode := cdb int (param link)
+ UNTIL mode = permanent type field PER ;
+ param link INCR wordlength
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode = permanent param proc THEN type of param proc
+ ELSE type of object
+ FI .
+
+type of param proc :
+ param link INCR wordlength ;
+ get type and mode (type) ;
+ mode := permanent param proc .
+
+type of object :
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 2. Spruenge und Marken 07.03.1986 *)
+(* *)
+(* Definition des Datentyps LABEL *)
+(* *)
+(* Deklaration, Definition und Applikation von Marken *)
+(* *)
+(**************************************************************************)
+
+
+TYPE LABEL = INT ;
+
+BOOL VAR invers :: FALSE ;
+
+PROC declare (LABEL VAR label) :
+ CONCR (label) := 0
+ENDPROC declare ;
+
+PROC define (LABEL VAR label) :
+ EXTERNAL 10083
+ENDPROC define ;
+
+PROC complement condition code :
+ invers := TRUE
+ENDPROC complement condition code ;
+
+PROC apply (LABEL VAR label) :
+ EXTERNAL 10148
+ENDPROC apply ;
+
+PROC apply (LABEL VAR label, BOOL CONST condition) :
+ IF condition xor invers THEN branch true (label)
+ ELSE branch false (label)
+ FI ;
+ invers := FALSE .
+
+condition xor invers :
+ IF condition THEN NOT invers
+ ELSE invers
+ FI
+ENDPROC apply ;
+
+OP := (LABEL VAR global label, local label) : (* EQUATE ! *)
+ EXTERNAL 10014
+ENDOP := ;
+
+TEXT PROC dump (LABEL CONST label) :
+ "LAB " + text (CONCR (label))
+ENDPROC dump ;
+
+PROC gosub (LABEL VAR label) :
+ EXTERNAL 10015
+ENDPROC gosub ;
+
+PROC goret :
+ s0 (q goret code)
+ENDPROC goret ;
+
+PROC branch true (LABEL VAR label) :
+ EXTERNAL 10028
+ENDPROC branch true ;
+
+PROC branch false (LABEL VAR label) :
+ EXTERNAL 10029
+ENDPROC branch false ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 3. Datenaddressen 21.03.1986 *)
+(* *)
+(* Definition des Datentyps ADDRESS *)
+(* *)
+(* Aufbau von Datenaddressen (Vercodung) *)
+(* Fortschalten und Ausrichten von Adressen *)
+(* Bereitstellen der Fehlermeldung "address overflow" (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE ADDRESS = STRUCT (INT kind, value) ;
+
+LET global = 0 ,
+ local = 1 ,
+ ref mask = 2 ,
+ global ref = 2 ,
+ local ref = 3 ,
+ module nr = 4 ,
+ immediate value = 5 ,
+
+ eumel0 stack offset = 4 ,
+ local address limit = 16 384 ,
+
+ illegal ref operation = "REF not allowed" ,
+ deref on non ref = "DEREF on non-ref address" ,
+ global ref not allowed = "GLOBAL REF not allowed" ,
+ unknown kind = "Unknown address kind" ,
+ address overflow = "Address Overflow" ,
+ illegal plus operation = "+ not allowed" ;
+
+ADDRESS VAR result addr;
+
+INT CONST ref length :: 2 ;
+
+OP := (ADDRESS VAR l, ADDRESS CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+ADDRESS OP GLOB (INT CONST address level) :
+ result addr.kind := global ;
+ result addr.value := address level ;
+ IF memory management mode = data allocation by user
+ THEN result addr.value INCR global address offset
+ FI ;
+ result addr
+ENDOP GLOB ;
+
+ADDRESS OP LOC (INT CONST address level) :
+ result addr.kind := local ;
+ result addr.value := address level + eumel0 stack offset ;
+ result addr
+ENDOP LOC ;
+
+ADDRESS OP REF (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ IF result addr.kind = local THEN result addr.kind INCR ref mask
+ ELIF result addr.kind = global THEN errorstop (global ref not allowed)
+ ELSE errorstop (illegal ref operation)
+ FI ;
+ result addr
+ENDOP REF ;
+
+ADDRESS OP DEREF (ADDRESS CONST ref address) :
+ CONCR (result addr) := CONCR (ref address) ;
+ IF is not local ref THEN errorstop (deref on non ref) FI ;
+ result addr.kind DECR ref mask ;
+ result addr .
+
+is not local ref :
+ result addr.kind <> local ref
+ENDOP DEREF ;
+
+INT OP REPR (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global :
+ CASE local : set bit (result addr.value, 15)
+ CASE global ref : errorstop (global ref not allowed)
+ CASE local ref : prep local ref
+ OTHERWISE errorstop (unknown kind)
+ ENDSELECT ;
+ result addr.value .
+
+prep local ref :
+ IF address limit exceeded THEN errorstop (address overflow) FI ;
+ set bit (result addr.value, 14) ;
+ set bit (result addr.value, 15) .
+
+address limit exceeded :
+ result addr.value < eumel0 stack offset OR
+ result addr.value > local address limit
+ENDOP REPR ;
+
+BOOL PROC is ref (ADDRESS CONST addr) :
+ addr.kind = local ref
+ENDPROC is ref ;
+
+BOOL PROC is global (ADDRESS CONST addr) :
+ addr.kind = global
+ENDPROC is global ;
+
+BOOL PROC is local (ADDRESS CONST addr) :
+ addr.kind = local
+ENDPROC is local ;
+
+ADDRESS OP + (ADDRESS CONST addr, INT CONST offset) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global : inc global
+ CASE local : inc local
+ OTHERWISE errorstop (illegal plus operation)
+ ENDSELECT ;
+ result addr .
+
+inc global :
+ result addr.value INCR offset ;
+ IF result addr.value < 0 THEN errorstop (address overflow) FI .
+
+inc local :
+ result addr.value INCR offset ;
+ IF result addr.value < eumel 0 stack offset OR
+ result addr.value > local address limit
+ THEN errorstop (address overflow)
+ FI
+ENDOP + ;
+
+PROC adjust (ADDRESS VAR addr, INT CONST adjust length) :
+ IF is local or global THEN adjust to length FI .
+
+is local or global :
+ addr.kind <= local .
+
+adjust to length :
+ mode := addr.value MOD adjust length ;
+ IF mode <> 0 THEN addr.value INCR (adjust length-mode) FI
+ENDPROC adjust ;
+
+TEXT PROC dump (ADDRESS CONST addr) :
+ kind + text (addr.value) .
+
+kind :
+ SELECT addr.kind OF
+ CASE global : "GLOBAL "
+ CASE local : "LOCAL "
+ CASE immediate value : "IMMEDIATE "
+ CASE module nr : "PARAM PROC "
+ CASE global ref : "GLOBAL REF "
+ CASE local ref : "LOCAL REF "
+ OTHERWISE "undef. Addr:"
+ ENDSELECT
+ENDPROC dump;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 4. Datentypen Teil I 03.12.1985 *)
+(* *)
+(* Definition des Datentyps DTYPE *)
+(* *)
+(* Interne Repraesentation der primitiven Datentypen *)
+(* Identifikation von DTYPEs *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE DTYPE = INT ;
+
+OP := (DTYPE VAR l, DTYPE CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+BOOL OP = (DTYPE CONST l, r) :
+ CONCR (l) = CONCR (r)
+ENDOP = ;
+
+DTYPE PROC void type : DTYPE :(void) ENDPROC void type ;
+
+DTYPE PROC int type : DTYPE :(int ) ENDPROC int type ;
+
+DTYPE PROC real type : DTYPE :(real) ENDPROC real type ;
+
+DTYPE PROC text type : DTYPE :(string) ENDPROC text type ;
+
+DTYPE PROC bool type : DTYPE :(bool) ENDPROC bool type ;
+
+DTYPE PROC dataspace type : DTYPE :(dataspace) ENDPROC dataspace type ;
+
+DTYPE PROC undefined type : DTYPE :(undefined) ENDPROC undefined type ;
+
+DTYPE PROC row type : DTYPE :(row) ENDPROC row type ;
+
+DTYPE PROC struct type : DTYPE :(struct) ENDPROC struct type ;
+
+DTYPE PROC proc type : DTYPE :(permanent param proc) ENDPROC proc type ;
+
+DTYPE PROC end type : DTYPE :(end) ENDPROC end type ;
+
+INT PROC type class (DTYPE CONST type) :
+ SELECT type id OF
+ CASE int, real, bool, string, dataspace, undefined : 1
+ CASE void : 0
+ CASE row : 3
+ CASE struct : 4
+ CASE permanent param proc : 5
+ OTHERWISE pt type
+ ENDSELECT .
+
+pt type :
+ IF type id > ptt limit THEN permanent row or struct
+ ELSE abstract type
+ FI .
+
+abstract type : 2 .
+
+permanent row or struct :
+ mode := cdbint (type link into pt) MOD ptt limit ;
+ IF mode = struct THEN 4
+ ELIF mode = row THEN 3
+ ELSE 2
+ FI .
+
+type link into pt :
+ type id + begin of pt minus ptt limit .
+
+type id : CONCR (type)
+ENDPROC type class ;
+
+PROC identify (TEXT CONST name,INT VAR size, align, DTYPE VAR type) :
+ SELECT type pos OF
+ CASE 1 : size := 0; align := 0; type id := void
+ CASE 6 : size := 1; align := 1; type id := int
+ CASE 10 : size := 4; align := 4; type id := real
+ CASE 15 : size := 8; align := 4; type id := string
+ CASE 20 : size := 1; align := 1; type id := bool
+ CASE 25 : size := 1; align := 1; type id := dataspace
+ OTHERWISE search for type in permanent table
+ ENDSELECT .
+
+type pos :
+ enclose in delimiters ;
+ pos (".VOID.INT.REAL.TEXT.BOOL.DATASPACE.", object name) .
+
+enclose in delimiters :
+ object name := "." ;
+ object name CAT name ;
+ object name CAT "." .
+
+search for type in permanent table :
+ to object (name) ;
+ IF NOT found THEN size := 0; align := 0; type id := undefined
+ ELSE size := cdbint (permanent pointer + two wordlength) ;
+ type id := permanent pointer - begin of permanent table ;
+ IF size < two wordlength THEN align := 1
+ ELIF size < four wordlength THEN align := 2
+ ELSE align := 4
+ FI
+ FI .
+
+type id : CONCR (type)
+ENDPROC identify ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 5. Operationen Teil I 21.03.1986 *)
+(* *)
+(* Definition des Datentyps OPN *)
+(* Primitive Operationen (:= etc.) *)
+(* Bereitstellen dee Fehlermeldung 'proc op expected' (coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+TYPE OPN = STRUCT (INT kind, mod nr, top of stack) ;
+
+LET proc op = 0 ,
+ param proc = 1 ,
+ eumel 0 = 2 ,
+ nil = 3 ,
+
+ param proc at non ref = "PARAM PROC at non-ref address" ,
+ proc op expected = "PROC expected" ;
+
+OPN VAR eumel0 opn;
+eumel0 opn.kind := eumel0 ;
+eumel0 opn.top of stack := 0 ;
+
+eumel0 opn.mod nr := q pp ;
+OPN CONST pp :: eumel0 opn ,
+ nop code :: OPN :(nil, 0, 0) ;
+
+THESAURUS VAR eumel 0 opcodes :: empty thesaurus ;
+
+PROC init op codes (FILE VAR eumelcodes) :
+ eumel 0 opcodes := empty thesaurus ;
+ WHILE NOT eof (eumelcodes) REP
+ getline (eumelcodes, object name) ;
+ delete trailing blanks ;
+ IF object name <> "" CAND NOT (eumel 0 opcodes CONTAINS object name)
+ THEN insert (eumel 0 opcodes, object name)
+ FI
+ PER .
+
+delete trailing blanks :
+ WHILE (object name SUB LENGTH object name) = " " REP
+ object name := subtext (object name, 1, LENGTH object name - 1)
+ PER
+ENDPROC init op codes ;
+
+ADDRESS PROC address (OPN CONST opn) :
+ IF opn.kind <> proc op THEN errorstop (proc op expected) FI ;
+ result addr.kind := module nr ;
+ result addr.value := opn.mod nr ;
+ result addr
+ENDPROC address ;
+
+OPN PROC operation (ADDRESS CONST addr) :
+ IF addr.kind <> local ref THEN errorstop (param proc at non ref) FI ;
+ OPN VAR opn ;
+ opn.kind := param proc ;
+ opn.mod nr :=addr.value ;
+ opn.top of stack := 0 ;
+ opn
+ENDPROC operation ;
+
+TEXT PROC mnemonic (OPN CONST op code) :
+ name (eumel 0 opcodes, op code.mod nr)
+ENDPROC mnemonic ;
+
+OPN PROC nop :
+ nop code
+ENDPROC nop ;
+
+OP := (OPN VAR r, OPN CONST l) :
+ CONCR (r) := CONCR (l)
+ENDOP := ;
+
+BOOL PROC is proc (OPN CONST operation) :
+ operation.kind = proc op
+ENDPROC is proc ;
+
+BOOL PROC is eumel 0 instruction (TEXT CONST op code name) :
+ link (eumel 0 opcodes, op code name) <> 0
+ENDPROC is eumel 0 instruction ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 6. Parameterfeld 10.01.1986 *)
+(* *)
+(* Bereitstellen des Parameterfeldes *)
+(* Schreiben und Lesen von Eintraegen im Parameterfeld *)
+(* Fortschalten von Zeigern in das Parameterfeld *)
+(* Bereitstellen der Konstanten 'size of param field' (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+LET PARAMDESCRIPTOR = STRUCT (DTYPE type, INT access,
+ ADDRESS addr, OPN push opn) ,
+
+ size of param field = 100 ,
+ param field exceeded = "Param Field Overflow",
+ param nr out of range = "Illegal Param Number" ;
+
+ROW size of param field PARAMDESCRIPTOR VAR param field ;
+
+
+ (***** Schreiben *****)
+
+PROC test param pos (INT CONST param nr) :
+ IF param nr < 1 OR param nr > size of param field
+ THEN errorstop (param nr out of range)
+ FI
+ENDPROC test param pos ;
+
+PROC declare (INT CONST param nr, DTYPE CONST type) :
+ test param pos (param nr) ;
+ enter type .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type)
+ENDPROC declare ;
+
+PROC declare (INT CONST param nr, access) :
+ test param pos (param nr) ;
+ enter access .
+
+enter access :
+ param field [param nr].access := access
+ENDPROC declare ;
+
+PROC define (INT CONST param nr, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter address .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr)
+ENDPROC define ;
+
+PROC define (INT CONST param nr, value) :
+ result addr.kind := immediate value ;
+ result addr.value := value ;
+ define (param nr, result addr)
+ENDPROC define ;
+
+PROC apply (INT CONST param nr, OPN CONST opn) :
+ test param pos (param nr) ;
+ enter push opn .
+
+enter push opn :
+ CONCR (param field [param nr].push opn) := CONCR (opn)
+ENDPROC apply ;
+
+PROC parameter (INT CONST param nr, DTYPE CONST type,
+ INT CONST access, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter type ;
+ enter access ;
+ enter address ;
+ enter pp as default .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type) .
+
+enter access :
+ param field [param nr].access := access .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr) .
+
+enter pp as default :
+ CONCR (param field [param nr].push opn) := CONCR (pp)
+ENDPROC parameter ;
+
+
+ (***** Lesen *****)
+
+ADDRESS PROC param address (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].addr
+ENDPROC param address ;
+
+DTYPE PROC dtype (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].type
+ENDPROC dtype ;
+
+INT PROC access (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].access
+ENDPROC access ;
+
+
+ (***** Fortschalten *****)
+
+OP NEXTPARAM (INT VAR param nr) :
+ test param pos (param nr) ;
+ IF long entry THEN read until end FI ;
+ param nr INCR 1 .
+
+long entry :
+ type class (param field [param nr].type) > 2 .
+
+read until end :
+ REP
+ param nr INCR 1 ;
+ NEXTPARAM param nr
+ UNTIL end marker read or end of field PER .
+
+end marker read or end of field :
+ param nr > size of param field OR
+ CONCR (param field [param nr].type) = end
+ENDOP NEXTPARAM ;
+
+INT PROC next param (INT CONST p) :
+ index := p ;
+ NEXTPARAM index ;
+ index
+ENDPROC next param ;
+
+TEXT PROC dump (INT CONST p) :
+ IF p > 0 AND p <= 100 THEN dump entry (param field (p))
+ ELSE param nr out of range
+ FI
+ENDPROC dump ;
+
+TEXT PROC dump entry (PARAMDESCRIPTOR CONST id) :
+ object name := dump (id.type) ;
+ object name CAT text (id.access) ;
+ object name CAT dump (id.addr) ;
+ object name CAT dump (id.push opn) ;
+ object name
+ENDPROC dump entry ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 7. Datentypen Teil II 20.01.1986 *)
+(* *)
+(* Deklaration neuer Datentypen *)
+(* Vergleich von DTYPEs im Parameterfeld und in der Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+
+DTYPE VAR pt type ;
+
+PROC declare (TEXT CONST name, INT CONST size, align, DTYPE VAR type) :
+ entry into name table ;
+ put next permanent (permanent type) ;
+ put next permanent (size) ;
+ put next permanent (nt link) ;
+ mark no offsets of text elements .
+
+entry into name table :
+ declare object (name, nt link, CONCR (type)) .
+
+mark no offsets of text elements :
+ put next permanent (0)
+ENDPROC declare ;
+
+BOOL PROC same type (INT CONST param 1, param 2) :
+ INT CONST left type :: CONCR (param field [param 1].type) ;
+ IF left type = right type
+ THEN same fine structure if there is one
+ ELSE left type = undefined OR right type = undefined
+ FI .
+
+right type : CONCR (param field [param 2].type) .
+
+same fine structure if there is one :
+ IF left type = row THEN compare row
+ ELIF left type = struct THEN compare struct
+ ELSE TRUE
+ FI .
+
+compare row :
+ equal sizes AND same type (param1 + 1, param2 + 1) .
+
+equal sizes :
+ param field [param1+1].access = param field [param2+1].access .
+
+compare struct :
+ INT VAR p1 :: param1+1, p2 :: param2+1 ;
+ REP
+ IF NOT same type (p1, p2) THEN LEAVE same type WITH FALSE
+ ELIF end type found THEN LEAVE same type WITH TRUE
+ FI ;
+ NEXTPARAM p1 ;
+ NEXTPARAM p2
+ UNTIL end of field PER ;
+ FALSE .
+
+end type found :
+ CONCR (param field [p1].type) = end .
+
+end of field :
+ p1 > size of param field OR p2 > size of param field
+ENDPROC same type ;
+
+BOOL PROC same type (INT CONST param nr, DTYPE CONST type) :
+ field pointer := param nr ;
+ CONCR (pt type) := CONCR (type) ;
+ equal types
+ENDPROC same type ;
+
+BOOL PROC equal types :
+ identical types OR one type is undefined .
+
+one type is undefined :
+ type of actual field = undefined OR CONCR(pt type) = undefined .
+
+identical types :
+ SELECT type class (pt type) OF
+ CASE 0, 1, 2 : type of actual field = CONCR (pt type)
+ CASE 3 : perhaps equal rows
+ CASE 4 : perhaps equal structs
+ OTHERWISE FALSE
+ ENDSELECT .
+
+perhaps equal rows :
+ is row AND equal row sizes AND equal row types .
+
+is row :
+ type of actual field = row .
+
+perhaps equal structs :
+ is struct AND same type fields .
+
+is struct :
+ type of actual field = struct .
+
+equal row sizes :
+ pt row size = row size within param field .
+
+equal row types :
+ same type (field pointer + 1, pt row type) .
+
+pt row size :
+ cdb int (CONCR(pt type) + offset to row size) .
+
+pt row type :
+ CONCR (pt type) INCR 2 ;
+ pt type .
+
+row size within param field :
+ param field [field pointer].access .
+
+same type fields :
+ field pointer INCR 1 ;
+ CONCR (pt type) INCR 1 ;
+ REP
+ IF NOT equal types THEN LEAVE same type fields WITH FALSE FI ;
+ IF type of actual field = end
+ THEN LEAVE same type fields WITH TRUE
+ FI ;
+ NEXTPARAM field pointer
+ UNTIL end of field PER ;
+ FALSE .
+
+end of field :
+ field pointer > size of param field .
+
+type of actual field :
+ CONCR (param field [field pointer].type) .
+ENDPROC equal types ;
+
+BOOL PROC is not void bool or undefined (DTYPE CONST dtype) :
+ type <> void AND type <> bool AND type <> undefined .
+
+type : CONCR (dtype)
+ENDPROC is not void bool or undefined ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 8. Operationen Teil II 07.03.1986 *)
+(* *)
+(* Definition der Opcodes *)
+(* Deklaration, Definition, Identifikation und Applikation *)
+(* Eroeffnen und Schliessen eines Moduls *)
+(* *)
+(**************************************************************************)
+
+
+
+LET module not opened = "Module not opened" ,
+ define missing = "DEFINE missing" ,
+ wrong nr of params = "Wrong Nr. of Params:" ,
+ illegal kind = "Opcode expected" ,
+ nested module = "Nested Modules" ,
+ no mod nr = "Param Proc expected" ,
+ no immediate value = "Value expected" ,
+ type error = "Type Error" ,
+
+ q ln = 1 ,
+ q move = 2 , q move code = 2 048 ,
+ q inc1 = 3 , q inc1 code = 3 072 ,
+ q dec1 = 4 , q dec1 code = 4 096 ,
+ q inc = 5 , q inc code = 5 120 ,
+ q dec = 6 , q dec code = 6 144 ,
+ q add = 7 , q add code = 7 168 ,
+ q sub = 8 , q sub code = 8 192 ,
+ q clear = 9 , q clear code = 9 216 ,
+ q test = 10 ,
+ q equ = 11 , q equ code = 11 264 ,
+ q lsequ = 12 , q lsequ code = 12 288 ,
+ q fmove = 13 , q fmove code = 13 312 ,
+ q fadd = 14 , q fadd code = 14 336 ,
+ q fsub = 15 , q fsub code = 15 360 ,
+ q fmult = 16 , q fmult code = 16 384 ,
+ q fdiv = 17 , q fdiv code = 17 408 ,
+ q flsequ = 18 , q flsequ code = 18 432 ,
+ q tmove = 19 , q tmove code = 19 456 ,
+ q tequ = 20 , q tequ code = 20 480 ,
+ q accds = 21 , q access ds code = 22 528 ,
+ q ref = 22 , q ref code = 23 552 ,
+ q subscript = 23 , q subscript code = 24 576 ,
+ q select = 24 , q select code = 25 600 ,
+ q ppv = 25 ,
+ q pp = 26 ,
+ q make false = 27 , (* q make false code = 65 513 *)
+ q movex = 28 ,
+(* q longa subs q longa subs code = 65 376 *)
+ q return = 29 , q return code = 32 512 ,
+ q true return = 30 , q true return code = 32 513 ,
+ q false return = 31 , q false return code = 32 514 ,
+ q goret code = 32 519 ,
+ q esc mult = 32 , q esc mult code = 32 553 ,
+ q esc div = 33 , q esc div code = 32 554 ,
+ q esc mod = 34 , q esc mod code = 32 555 ,
+ q pproc = 35 ,
+ q compl int = 36 , q compl int code = 32 551 ,
+ q compl real = 37 , q compl real code = 32 550 ,
+(* q alias ds = 38 , *)
+ q movim = 39 , q esc movim code = 32 547 ,
+ q fequ = 40 , q fequ code = 32 548 ,
+ q tlsequ = 41 , q tlsequ code = 32 549 ,
+(* q case = 42 , *)
+ q plus = 43 ,
+ q minus = 44 ,
+ q mult = 45 ,
+ q int div = 46 ,
+ q real div = 47 ,
+ q equal = 48 ,
+ q lessequal = 49 ;
+
+INT CONST q make false code :: - 1 022 ,
+ q longa subs code :: - 159 ;
+
+
+ (***** Deklaration *****)
+
+PROC declare (OPN VAR operation) :
+ operation.kind := proc op ;
+ get module nr (operation.mod nr) ;
+ operation.top of stack := 0
+ENDPROC declare ;
+
+PROC declare (TEXT CONST name, INT CONST first, params, OPN VAR operation) :
+ declare (operation) ;
+ entry into name and pt table if necessary ;
+ enter params ;
+ enter result ;
+ enter module number .
+
+entry into name and pt table if necessary :
+ declare object (name, nt link, permanent pointer) .
+
+enter params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO params REP
+ enter param (param field [field pointer]) ;
+ NEXTPARAM field pointer
+ PER .
+
+enter result :
+ enter param (param field[field pointer].type, permanent proc op) .
+
+enter module number :
+ put next permanent (operation.mod nr)
+ENDPROC declare ;
+
+PROC enter param (PARAMDESCRIPTOR CONST param) :
+ IF param.access = const
+ THEN enter param (param.type, permanent param const)
+ ELIF param.access = var
+ THEN enter param (param.type, permanent param var)
+ ELSE errorstop ("Unknown Access")
+ FI
+ENDPROC enter param ;
+
+PROC enter param (DTYPE CONST type, INT CONST permanent mode) :
+ SELECT type class (type) OF
+ CASE 0, 1, 2 : put next permanent (CONCR(type) + permanent mode)
+ OTHERWISE errorstop ("Illegal Type")
+ ENDSELECT
+ENDPROC enter param ;
+
+
+ (***** Definition *****)
+
+PROC define (OPN VAR opn) :
+ IF NOT module open THEN errorstop (module not opened)
+ ELSE proc head (opn.mod nr, opn.top of stack)
+ FI
+ENDPROC define ;
+
+PROC set length of local storage (OPN VAR opn, INT CONST size) :
+ IF size < 0 OR size > local address limit
+ THEN errorstop (address overflow)
+ ELIF opn.top of stack = 0
+ THEN errorstop (define missing)
+ ELIF opn.kind <> proc op
+ THEN errorstop (proc op expected)
+ FI ;
+ set length (opn.top of stack, size + eumel0 stack offset)
+ENDPROC set length of local storage ;
+
+PROC define (OPN VAR operation, INT CONST size) :
+ define (operation) ;
+ set length of local storage (operation, size)
+ENDPROC define ;
+
+
+ (***** Identifikation *****)
+
+INT VAR counter, result index, result type repr;
+
+PROC identify (TEXT CONST name, INT CONST first, params, OPN VAR operation,
+ BOOL VAR object exists) :
+ find result entry ;
+ to object (name) ;
+ IF found THEN first fit and leave if found FI ;
+ IF eumel0 THEN identify eumel0 instruction
+ ELSE yield undefined operation
+ FI .
+
+find result entry :
+ result index := first;
+ counter := 0 ;
+ WHILE counter < params REP
+ NEXTPARAM result index ;
+ counter INCR 1
+ PER ;
+ check on param field exceeded .
+
+check on param field exceeded :
+ IF result index > size of param field
+ THEN errorstop (param field exceeded)
+ FI .
+
+yield undefined operation :
+ declare (result index, undefined type) ;
+ apply (result index, nop) ;
+ object exists := FALSE .
+
+first fit and leave if found :
+ WHILE yet another procedure exists REP
+ check one procedure and leave if match ;
+ next procedure
+ PER .
+
+yet another procedure exists :
+ permanent pointer <> 0 .
+
+check one procedure and leave if match:
+ param link := permanent pointer + wordlength ;
+ set end marker if end of list ;
+ counter := params ;
+ field pointer := 1 ;
+ REP
+ IF end of params AND counter = 0
+ THEN procedure found
+ ELIF end of params OR counter = 0
+ THEN LEAVE check one procedure and leave if match
+ ELSE check next param
+ FI
+ PER .
+
+check next param :
+ get type and mode (CONCR(pt type)) ;
+ IF same types THEN set param mode ;
+ counter DECR 1 ;
+ field pointer INCR 1 ;
+ next pt param
+ ELSE LEAVE check one procedure and leave if match
+ FI .
+
+same types : (* inline version ! *)
+ equal types .
+
+set param mode :
+ param field [field pointer].access := mode .
+
+procedure found :
+ get result ;
+ operation.kind := proc op ;
+ operation.mod nr := module number ;
+ operation.top of stack := 0 ;
+ object exists := TRUE ;
+ LEAVE identify .
+
+get result :
+ get type and mode (result type) ;
+ declare (result index, mode) .
+
+module number :
+ cdbint (param link + 1) .
+
+result type :
+ CONCR (param field [result index].type) .
+
+eumel0 :
+ eumel0 opn.mod nr := link (eumel 0 opcodes, name) ;
+ eumel0 opn.mod nr <> 0 .
+
+identify eumel 0 instruction :
+ init result type with void ;
+ CONCR (operation) := CONCR (eumel0 opn) ;
+ object exists := check params and set result ;
+ declare (result index, DTYPE:(result type repr)) ;
+ declare (result index, const) .
+
+init result type with void :
+ result type repr := void .
+
+check params and set result :
+ SELECT operation.mod nr OF
+ CASE q return, q false return, q true return : no params
+ CASE q inc1, q dec1 : one int param yielding void
+ CASE q pproc, q pp, q ln : one param yielding void
+ CASE q test : one param yielding bool
+ CASE q clear, q ppv : one int or bool param yielding void
+ CASE q make false : one bool param yielding void
+ CASE q move : two int or bool params yielding void
+ CASE q compl int, q inc, q dec : two int params yielding void
+ CASE q compl real, q fmove : two real params yielding void
+ CASE q equ, q lsequ : two int params yielding bool
+ CASE q fequ, q flsequ : two real params yielding bool
+ CASE q tequ, q tlsequ : two text params yielding bool
+ CASE q tmove : two text params yielding void
+ CASE q accds, q ref : two params yielding void
+ CASE q add, q sub, q esc mult,
+ q esc div, q esc mod : three int params yielding void
+ CASE q fadd, q fsub, q fmult, q fdiv : three real params yielding void
+ CASE q select, q movex : three params
+ CASE q subscript : five params
+ CASE q plus, q minus, q mult : two intreals yielding intreal
+ CASE q int div : two int params yielding int
+ CASE q real div : two real params yielding real
+ CASE q equal, q lessequal : two intrealtexts yielding bool
+ OTHERWISE FALSE
+ ENDSELECT .
+
+no params :
+ params = 0 .
+
+one int param yielding void :
+ p1 void (int type, first, params) .
+
+one param yielding void :
+ params = 1 .
+
+one param yielding bool :
+ IF params = 1 THEN result type repr := bool ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+one int or bool param yielding void :
+ p1 void (int type, first, params) OR p1 void (bool type, first, params) .
+
+one bool param yielding void :
+ p1 void (bool type, first, params) .
+
+two int or bool params yielding void :
+ p2 (int type, first, params, void) OR
+ p2 (bool type, first, params, void) .
+
+two int params yielding void :
+ p2 (int type, first, params, void) .
+
+two real params yielding void :
+ p2 (real type, first, params, void) .
+
+two text params yielding void :
+ p2 (text type, first, params, void) .
+
+two int params yielding bool :
+ p2 (int type, first, params, bool) .
+
+two real params yielding bool :
+ p2 (real type, first, params, bool) .
+
+two text params yielding bool :
+ p2 (text type, first, params, bool) .
+
+two params yielding void :
+ params = 2 .
+
+three int params yielding void :
+ p3 void (int type, first, params) .
+
+three real params yielding void :
+ p3 void (real type, first, params) .
+
+three params :
+ params = 3 .
+
+five params :
+ params = 5 .
+
+two intreals yielding intreal :
+ two int params yielding int OR two real params yielding real .
+
+two intrealtexts yielding bool :
+ two int params yielding bool OR two real params yielding bool OR
+ two text params yielding bool .
+
+two int params yielding int :
+ p2 (int type, first, params, int) .
+
+two real params yielding real :
+ p2 (real type, first, params, real)
+ENDPROC identify ;
+
+BOOL PROC p1 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 1 AND param type is requested plain type .
+
+param type is requested plain type :
+ CONCR (param field [first].type) = CONCR (requested type)
+
+ENDPROC p1 void ;
+
+BOOL PROC p2 (DTYPE CONST requested type, INT CONST first, param nr,
+ INT CONST result type) :
+ IF param nr = 2 AND param types equal requested plain type
+ THEN result type repr := result type ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+param types equal requested plain type :
+ CONCR (param field [first] .type) = CONCR (requested type) AND
+ CONCR (param field [first+1].type) = CONCR (requested type)
+
+ENDPROC p2 ;
+
+BOOL PROC p3 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 3 AND param types ok .
+
+param types ok :
+ FOR index FROM first UPTO first+2 REP
+ IF different param types THEN LEAVE p3 void WITH FALSE FI
+ PER ;
+ TRUE .
+
+different param types :
+ CONCR (param field [index].type) <> CONCR (requested type)
+ENDPROC p3 void;
+
+
+ (***** Applikation *****)
+
+INT VAR address representation, left repr, right repr, result repr;
+
+PROC apply (INT CONST first, nr of params, OPN CONST opn) :
+ IF NOT module open THEN errorstop (module not opened) FI ;
+ SELECT opn.kind OF
+ CASE eumel 0 : generate eumel0 instruction
+ CASE proc op : call operation
+ CASE param proc : call param proc
+ CASE nil :
+ OTHERWISE errorstop (illegal kind)
+ ENDSELECT .
+
+call operation :
+ push params if necessary (first, nr of params, opn.mod nr) ;
+ call (opn.mod nr) .
+
+call param proc :
+ result addr.kind := local ref ;
+ result addr.value := opn.mod nr ;
+ address representation := REPR result addr ;
+ push params if necessary (first, nr of params, address representation) ;
+ call param (address representation) .
+
+generate eumel0 instruction :
+ SELECT real nr of params OF
+ CASE 0 : p0 instruction
+ CASE 1 : apply p1 (opn, first addr)
+ CASE 2 : apply p2 (opn, first addr, second addr)
+ CASE 3 : apply p3 (opn, left type, first addr, second addr, third addr)
+ CASE 5 : subscript operation
+ OTHERWISE errorstop (wrong nr of params + text (nr of params))
+ ENDSELECT .
+
+real nr of params :
+ IF operator denotation THEN nr of params + 1
+ ELSE nr of params
+ FI .
+
+operator denotation :
+ opn.mod nr >= q plus .
+
+p0 instruction :
+ IF opn.mod nr = q return THEN s0 (q return code)
+ ELIF opn.mod nr = q true return THEN s0 (q true return code)
+ ELIF opn.mod nr = q false return THEN s0 (q false return code)
+ ELSE errorstop (wrong nr of params +
+ mnemonic (opn))
+ FI .
+
+subscript operation :
+ IF opn.mod nr = q subscript
+ THEN subscription
+ ELSE errorstop (wrong nr of params + text (nr of params))
+ FI .
+
+subscription :
+ ADDRESS CONST element length :: param field [first+2].addr ,
+ limit :: param field [first+3].addr ;
+ check on immediates ;
+ IF element length.value < 1024
+ THEN s0 (q subscript code + element length.value)
+ ELSE s0 (q longa subs code) ;
+ s0 (element length.value)
+ FI ;
+ s3 (limit.value - 1, subs index, base addr, subs result) .
+
+check on immediates :
+ IF element length.kind <> immediate value OR
+ limit.kind <> immediate value
+ THEN errorstop (no immediate value)
+ FI .
+
+subs index : REPR param field [first+1].addr .
+
+base addr : REPR param field [first].addr .
+
+subs result : REPR param field [first+4].addr .
+
+first addr :
+ param field [first].addr .
+
+left type :
+ param field [first].type .
+
+second addr :
+ param field [nextparam (first)].addr .
+
+third addr :
+ param field [nextparam(nextparam(first))].addr
+ENDPROC apply ;
+
+PROC push params if necessary (INT CONST first, nr of params, mod nr) :
+ init param push (mod nr) ;
+ IF nr of params > 0 THEN push params ;
+ push result if there is one
+ FI .
+
+push params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO nr of params REP
+ apply p1 (push code, param addr) ;
+ NEXTPARAM field pointer
+ PER .
+
+push code :
+ param field [field pointer].push opn .
+
+param addr :
+ param field [field pointer].addr .
+
+push result if there is one :
+ IF push result necessary
+ THEN push result address (REPR param field [field pointer].addr)
+ FI .
+
+push result necessary :
+ param field [field pointer].push opn.kind <> nil AND
+ is not void bool or undefined (param field [field pointer].type)
+ENDPROC push params if necessary ;
+
+PROC apply p1 (OPN CONST opn, ADDRESS CONST addr) :
+ IF opn.mod nr = q ln THEN generate line number
+ ELIF opn.mod nr = q pproc THEN push module nr
+ ELSE gen p1 instruction
+ FI .
+
+gen p1 instruction :
+ address representation := REPR addr ;
+ SELECT opn.mod nr OF
+ CASE q inc1 : t1 (q inc1 code, address representation)
+ CASE q dec1 : t1 (q dec1 code, address representation)
+ CASE q clear : t1 (q clear code,address representation)
+ CASE q test : test bool object (address representation)
+ CASE q pp : push param (address representation)
+ CASE q make false : s1 (q make false code, address representation)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+generate line number :
+ IF addr.kind = immediate value THEN mark line (addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+push module nr :
+ IF addr.kind = module nr THEN push param proc (addr.value)
+ ELSE errorstop (no mod nr)
+ FI
+ENDPROC apply p1;
+
+PROC apply p2 (OPN CONST opn, ADDRESS CONST left addr, right addr):
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movim THEN move immediate
+ ELSE gen p2 instruction
+ FI .
+
+gen p2 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q move : t2 (q move code, right repr, left repr)
+ CASE q inc : t2 (q inc code, right repr, left repr)
+ CASE q dec : t2 (q dec code, right repr, left repr)
+ CASE q equ : compare (q equ code, left repr, right repr)
+ CASE q lsequ : compare (q lsequ code, left repr, right repr)
+ CASE q fmove : t2 (q fmove code, right repr, left repr)
+ CASE q flsequ : compare (q flsequ code, left repr, right repr)
+ CASE q tmove : t2 (q tmove code, right repr, left repr)
+ CASE q tequ : compare (q tequ code, left repr, right repr)
+ CASE q compl int : s2 (q compl int code, left repr, right repr)
+ CASE q compl real : s2 (q compl real code, left repr, right repr)
+ CASE q fequ : compare (q fequ code, left repr, right repr)
+ CASE q tlsequ : compare (q tlsequ code, left repr, right repr)
+ CASE q accds : t2 (q access ds code, left repr, right repr)
+ CASE q ref : t2 (q ref code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+move immediate :
+ IF right addr.kind = immediate value
+ THEN s0 (q esc movim code) ;
+ s1 (left repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI
+ENDPROC apply p2;
+
+PROC apply p3 (OPN CONST opn, DTYPE CONST left dtype,
+ ADDRESS CONST left addr, right addr, result addr ):
+ left repr := REPR left addr ;
+ result repr := REPR result addr ;
+ IF opn.mod nr = q select THEN gen select instruction
+ ELIF opn.mod nr = q movex THEN gen long move
+ ELSE gen p3 instruction
+ FI .
+
+gen p3 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q add : int add
+ CASE q sub : int sub
+ CASE q fadd : real add
+ CASE q fsub : real sub
+ CASE q fmult : real mult
+ CASE q fdiv, q real div : real div
+ CASE q esc mult : int mult
+ CASE q esc div, q int div : int div
+ CASE q esc mod : int mod
+ CASE q plus : int real add
+ CASE q minus : int real sub
+ CASE q mult : int real mult
+ CASE q equal, q lessequal : compare (comp code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+gen select instruction :
+ IF right addr.kind = immediate value
+ THEN t1 (q select code, left repr) ;
+ s1 (right addr.value, result repr)
+ ELSE errorstop (no immediate value)
+ FI .
+
+gen long move :
+ IF right addr.kind = immediate value
+ THEN long move (left repr, result repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+int add : compute (q add code, left repr, right repr, result repr) .
+
+int sub : compute (q sub code, left repr, right repr, result repr) .
+
+real add : compute (q fadd code, left repr, right repr, result repr) .
+
+real sub : compute (q fsub code, left repr, right repr, result repr) .
+
+real mult : compute (q fmult code, left repr, right repr, result repr) .
+
+real div : compute (q fdiv code, left repr, right repr, result repr) .
+
+int mult : s3 (q esc mult code, left repr, right repr, result repr) .
+
+int div : s3 (q esc div code, left repr, right repr, result repr) .
+
+int mod : s3 (q esc mod code, left repr, right repr, result repr) .
+
+int real add :
+ IF left type = int THEN int add
+ ELSE real add
+ FI .
+
+int real sub :
+ IF left type = int THEN int sub
+ ELSE real sub
+ FI .
+
+int real mult :
+ IF left type = int THEN int mult
+ ELSE real mult
+ FI .
+
+comp code :
+ SELECT left type OF
+ CASE int : IF opn.mod nr = q equal THEN q equ ELSE q lsequ FI
+ CASE real : IF opn.mod nr = q equal THEN q fequ ELSE q flsequ FI
+ CASE string : IF opn.mod nr = q equal THEN q tequ ELSE q tlsequ FI
+ OTHERWISE errorstop (type error); q equ
+ ENDSELECT .
+
+left type : CONCR (left dtype)
+
+ENDPROC apply p3;
+
+
+ (***** Modul *****)
+
+BOOL VAR module open ;
+
+.init opn section :
+ module open := FALSE .;
+
+PROC begin module :
+ IF module open THEN errorstop (nested module)
+ ELSE begin modul ;
+ module open := TRUE
+ FI
+ENDPROC begin module ;
+
+PROC end module :
+ IF NOT module open
+ THEN errorstop (module not opened)
+ ELSE end modul ;
+ module open := FALSE
+ FI
+ENDPROC end module ;
+
+TEXT PROC dump (OPN CONST operation) :
+ IF operation.kind = proc op THEN " PROC" + text (operation.mod nr, 5)
+ ELIF operation.kind = eumel 0 THEN " EUMEL0: " + mnemonic (operation)
+ ELSE " undef. Opn"
+ FI
+ENDPROC dump ;
+
+PROC begin modul :
+ EXTERNAL 10071
+ENDPROC begin modul ;
+
+PROC end modul :
+ EXTERNAL 10011
+ENDPROC end modul ;
+
+PROC proc head (INT VAR mod nr, top of stack) :
+ EXTERNAL 10012
+ENDPROC proc head ;
+
+PROC set length (INT CONST top of stack, size) :
+ EXTERNAL 10013
+ENDPROC set length ;
+
+PROC get module nr (INT VAR module nr) :
+ EXTERNAL 10016
+ENDPROC get module nr ;
+
+PROC compute (INT CONST op code, l addr, r addr, result address) :
+ EXTERNAL 10017
+ENDPROC compute ;
+
+PROC compare (INT CONST op code, l addr, r addr) :
+ EXTERNAL 10018
+ENDPROC compare ;
+
+PROC long move (INT CONST to, from, length) :
+ EXTERNAL 10019
+ENDPROC long move ;
+
+PROC put next permanent (INT CONST permanent value) :
+ EXTERNAL 10020
+ENDPROC put next permanent ;
+
+PROC call (INT CONST mod nr) :
+ EXTERNAL 10022
+ENDPROC call ;
+
+PROC call param (INT CONST mod nr) :
+ EXTERNAL 10023
+ENDPROC call param ;
+
+PROC push param (INT CONST addr) :
+ EXTERNAL 10024
+ENDPROC push param ;
+
+PROC push param proc (INT CONST mod nr) :
+ EXTERNAL 10025
+ENDPROC push param proc ;
+
+PROC init param push (INT CONST mod nr) :
+ EXTERNAL 10026
+ENDPROC init param push ;
+
+PROC push result address (INT CONST addr) :
+ EXTERNAL 10027
+ENDPROC push result address ;
+
+PROC test bool object (INT CONST addr) :
+ EXTERNAL 10186
+ENDPROC test bool object ;
+
+PROC mark line (INT CONST line number) :
+ EXTERNAL 10030
+ENDPROC mark line ;
+
+PROC s0 (INT CONST op code) :
+ EXTERNAL 10038
+ENDPROC s0 ;
+
+PROC s1 (INT CONST op code, addr) :
+ EXTERNAL 10039
+ENDPROC s1 ;
+
+PROC s2 (INT CONST op code , addr1, addr2) :
+ EXTERNAL 10040
+ENDPROC s2 ;
+
+PROC s3 (INT CONST op code, addr1, addr2, addr3) :
+ EXTERNAL 10041
+ENDPROC s3 ;
+
+PROC t1 (INT CONST op code, addr) :
+ EXTERNAL 10042
+ENDPROC t1 ;
+
+PROC t2 (INT CONST op code, addr1, addr2) :
+ EXTERNAL 10043
+ENDPROC t2 ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 9. Speicherverwaltung 21.03.1986 *)
+(* *)
+(* Ablage der Paketdaten *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR address value;
+
+INT CONST data allocation by coder := 1 ,
+ data allocation by user := 2 ;
+
+LET not initialized = 0 ,
+ wrong mm mode = "Wrong MM Mode" ,
+ define on non global = "Define for GLOB only" ,
+ text too long = "TEXT too long" ;
+
+TEXT VAR const buffer :: point line ;
+
+.reset memory management mode :
+ memory management mode := not initialized . ;
+
+PROC reserve storage (INT CONST size) :
+ IF memory management mode <> data allocation by user
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (address value, size) ;
+ memory management mode := not initialized
+ENDPROC reserve storage ;
+
+PROC allocate variable (ADDRESS VAR addr, INT CONST size) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (addr.value, size) ;
+ addr.kind := global
+ENDPROC allocate variable ;
+
+PROC allocate denoter (ADDRESS VAR addr, INT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate int denoter (addr.value) ;
+ put data word (value, addr.value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, REAL CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate real denoter (addr.value) ;
+ addr.kind := global ;
+ define (addr, value)
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, TEXT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate text denoter (addr.value, (LENGTH value+1) DIV 2 + 2) ;
+ addr.kind := global ;
+ skip heaplink;
+ define (addr, value) ;
+ reset heaplink .
+
+skip heaplink :
+ addr.value INCR 1 .
+
+reset heaplink :
+ addr.value DECR 1
+ENDPROC allocate denoter ;
+
+PROC define (ADDRESS CONST addr, INT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value, addr.value)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, REAL CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ replace (const buffer, 1, value) ;
+ address value := addr.value ;
+ FOR index FROM 1 UPTO 4 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, TEXT CONST value) :
+ IF addr.kind <> global THEN errorstop (define on non global)
+ ELIF LENGTH value > 255 THEN errorstop (text too long)
+ FI ;
+ address value := addr.value ;
+ const buffer := code (LENGTH value) ;
+ const buffer CAT value ;
+ const buffer CAT " " ;
+ FOR index FROM 1 UPTO LENGTH const buffer DIV 2 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER ;
+ const buffer := point line
+ENDPROC define ;
+
+PROC prep pbase (INT VAR offset) :
+ EXTERNAL 10032
+ENDPROC prep pbase;
+
+PROC allocate var (INT VAR addr, INT CONST length) :
+ EXTERNAL 10033
+ENDPROC allocate var ;
+
+PROC allocate int denoter (INT VAR addr) :
+ EXTERNAL 10034
+ENDPROC allocate int denoter ;
+
+PROC allocate real denoter (INT VAR addr) :
+ EXTERNAL 10035
+ENDPROC allocate real denoter ;
+
+PROC allocate text denoter (INT VAR addr, INT CONST length) :
+ EXTERNAL 10036
+ENDPROC allocate text denoter ;
+
+PROC put data word (INT CONST value, INT CONST addr) :
+ EXTERNAL 10037
+ENDPROC put data word ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 08.01.1986 *)
+(* *)
+(**************************************************************************)
+
+TEXT VAR type and mode ;
+
+TEXT PROC type name (DTYPE CONST type) :
+ type and mode := "" ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC type name ;
+
+TEXT PROC dump (DTYPE CONST type) :
+ type and mode := "TYPE " ;
+ name of type (CONCR (type)) ;
+ type and mode
+ENDPROC dump ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void :
+ CASE int : type and mode CAT "INT"
+ CASE real : type and mode CAT "REAL"
+ CASE string : type and mode CAT "TEXT"
+ CASE bool, bool result : type and mode CAT "BOOL"
+ CASE dataspace : type and mode CAT "DATASPACE"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+ENDPACKET eumel coder ;
diff --git a/system/eumel-coder/1.8.0/src/eumel0 codes b/system/eumel-coder/1.8.0/src/eumel0 codes
new file mode 100644
index 0000000..428f71e
--- /dev/null
+++ b/system/eumel-coder/1.8.0/src/eumel0 codes
@@ -0,0 +1,50 @@
+LN
+MOVE
+INC1
+DEC1
+INC
+DEC
+ADD
+SUB
+CLEAR
+TEST
+EQU
+LSEQU
+FMOVE
+FADD
+FSUB
+FMULT
+FDIV
+FLSEQU
+TMOVE
+TEQU
+ACCDS
+REF
+SUBSCRIPT
+SELECT
+PPV
+PP
+MAKE_FALSE
+MOVEX
+RETURN
+TRUE_RETURN
+FALSE_RETURN
+ESC_MULT
+ESC_DIV
+ESC_MOD
+PPROC
+COMPL_INT
+COMPL_REAL
+ALIAS_DS
+MOVIM
+FEQU
+TLSEQU
+CASE
++
+-
+*
+DIV
+/
+=
+<=
+
diff --git a/system/eumel-coder/1.8.1/source-disk b/system/eumel-coder/1.8.1/source-disk
new file mode 100644
index 0000000..972580b
--- /dev/null
+++ b/system/eumel-coder/1.8.1/source-disk
@@ -0,0 +1 @@
+debug/eumel-coder-1.8.1.img
diff --git a/system/eumel-coder/1.8.1/src/eumel coder 1.8.1 b/system/eumel-coder/1.8.1/src/eumel coder 1.8.1
new file mode 100644
index 0000000..0047067
--- /dev/null
+++ b/system/eumel-coder/1.8.1/src/eumel coder 1.8.1
@@ -0,0 +1,3086 @@
+PACKET eumel coder (* Autor: U. Bartling *)
+ DEFINES coder on, coder off,
+ declare, define, apply, identify,
+ :=, =,
+ dump,
+
+ LIB,
+
+ LABEL,
+ gosub, goret,
+ computed branch,
+ complement condition code,
+
+ ADDRESS ,
+ GLOB, LOC, REF, DEREF,
+ ref length,
+ +,
+ adjust,
+ get base,
+ is global, is local, is ref,
+
+ DTYPE,
+ type class, type name,
+ void type, int type, real type, text type, bool type,
+ bool result type, dataspace type, undefined type,
+ row type, struct type, proc type, end type,
+
+ OPN,
+ set length of local storage,
+ begin module, end module,
+ is proc, is eumel 0 instruction,
+ address, operation,
+ nop,
+ mnemonic,
+
+ parameter,
+ next param,
+ NEXTPARAM,
+ access ,
+ dtype ,
+ param address,
+ same type ,
+
+ reserve storage,
+ allocate denoter ,
+ allocate variable,
+ data allocation by coder ,
+ data allocation by user,
+
+ run, run again,
+ insert,
+ prot, prot off,
+ check, check on, check off,
+
+ help, bulletin, packets,
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 29.10.1986 *)
+(* Stand der Implementation : 03.09.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+#page#
+(**************************************************************************)
+(* *)
+(* 0. Datentyp DINT 03.09.1987 *)
+(* *)
+(* Definition des Datentyps *)
+(* arithmetischer Operationen *)
+(* und Konvertierungsprozeduren *)
+(* *)
+(**************************************************************************)
+
+
+ DINT,
+ -, *, DIV, MOD, <, <=,
+ AND, OR, XOR,
+ dput, dget, dmov,
+ ddec1, dinc1, dinc, ddec,
+ dadd, dsub,
+ dequ, dlseq,
+ INCR, DECR,
+ put, get, cout,
+ text, real, int, dint,
+ replace, DSUB :
+
+
+TYPE DINT = STRUCT (INT low, high) ;
+
+
+REAL VAR real value ; (* auch fuer Ausrichtung ! *)
+TEXT VAR convertion buffer ;
+
+DINT CONST dint0 :: dint(0) ;
+DINT VAR result :: dint 0 ;
+
+
+DINT PROC dint (INT CONST number) :
+ EXTERNAL 144
+ENDPROC dint ;
+
+INT PROC int (DINT CONST i) :
+ EXTERNAL 143
+ENDPROC int;
+
+REAL PROC real (DINT CONST number) :
+ real value := 65536.0 * real (number.high) ;
+
+ IF number.low >= 0
+ THEN real value INCR real (number.low)
+ ELSE real value INCR (real (number.low AND maxint) + 32768.0)
+ FI ;
+ real value
+ENDPROC real ;
+
+DINT PROC dint (REAL CONST number) :
+ real value := abs (number) ;
+ REAL CONST low := real value MOD 65536.0 ;
+
+ result.high := int(real value / 65536.0) ;
+ IF low < 32768.0
+ THEN result.low := int (low)
+ ELSE result.low := int (low-32768.0) OR minint
+ FI ;
+ IF number < 0.0 THEN dsub (dint0, result, result) FI ;
+ result
+ENDPROC dint ;
+
+TEXT PROC text (DINT CONST number) :
+ IF number.high = 0 THEN convert low part only
+ ELSE convert number
+ FI ;
+ convertion buffer .
+
+convert low part only :
+ IF number.low >= 0 THEN convertion buffer := text (number.low)
+ ELSE convertion buffer := text (real of low) ;
+ erase decimal point
+ FI .
+
+real of low :
+ real (number.low AND maxint) + 32768.0 .
+
+convert number :
+ convertion buffer := text (real(number)) ;
+ erase decimal point .
+
+erase decimal point :
+ convertion buffer := subtext (convertion buffer, 1, LENGTH convertion buffer-2)
+ENDPROC text;
+
+DINT PROC dint (TEXT CONST dint txt) :
+ convertion buffer := dint txt ;
+ INT CONST dot pos :: pos (convertion buffer, ".") ;
+ IF dot pos = 0 THEN convertion buffer CAT ".0" FI ;
+ dint (real(convertion buffer))
+ENDPROC dint ;
+
+PROC get (DINT VAR dest) :
+ REAL VAR number ;
+ get (number) ;
+ dest := dint (number)
+ENDPROC get ;
+
+PROC put (DINT CONST number) :
+ put (text (number));
+ENDPROC put ;
+
+PROC cout (DINT CONST number) :
+ EXTERNAL 61
+ENDPROC cout;
+
+OP := (DINT VAR a, DINT CONST b) :
+# INLINE ; #
+ dmov (b, a);
+ENDOP :=;
+
+OP INCR (DINT VAR a, DINT CONST b) :
+# INLINE ; #
+ dinc (b, a);
+ENDOP INCR;
+
+OP DECR (DINT VAR a, DINT CONST b) :
+# INLINE ; #
+ ddec (b, a);
+ENDOP DECR;
+
+BOOL OP = (DINT CONST a, b) :
+ EXTERNAL 137
+ENDOP =;
+
+BOOL OP <= (DINT CONST a, b) :
+ EXTERNAL 138
+ENDOP <=;
+
+BOOL OP < (DINT CONST a, b) :
+# INLINE ; #
+ NOT (b <= a)
+ENDOP <;
+
+BOOL PROC dequ (DINT CONST a, b) :
+ EXTERNAL 137
+ENDPROC dequ ;
+
+BOOL PROC dlseq (DINT CONST a, b) :
+ EXTERNAL 138
+ENDPROC dlseq ;
+
+PROC replace (TEXT VAR text, INT CONST index of dint, DINT CONST value) :
+ INT VAR subscript := index of dint * 2 ;
+ replace (text, subscript - 1,value.low);
+ replace (text, subscript, value.high);
+ENDPROC replace;
+
+DINT OP DSUB (TEXT CONST text, INT CONST index of dint) :
+ INT VAR subscript := index of dint * 2 ;
+ result.low := text ISUB subscript - 1;
+ result.high := text ISUB subscript;
+ result
+ENDOP DSUB;
+
+DINT OP + (DINT CONST a, b) :
+ EXTERNAL 135
+ENDOP + ;
+
+DINT OP - (DINT CONST a, b) :
+ EXTERNAL 136
+ENDOP - ;
+
+PROC dadd (DINT CONST a, b, DINT VAR res) :
+ EXTERNAL 135
+ENDPROC dadd ;
+
+PROC dsub (DINT CONST a, b, DINT VAR res) :
+ EXTERNAL 136
+ENDPROC dsub ;
+
+PROC dinc (DINT CONST source, DINT VAR dest) :
+ EXTERNAL 133
+ENDPROC dinc ;
+
+PROC ddec (DINT CONST source, DINT VAR dest) :
+ EXTERNAL 134
+ENDPROC ddec ;
+
+PROC dmov (DINT CONST source, DINT VAR dest) :
+ EXTERNAL 130
+ENDPROC dmov;
+
+DINT OP DIV (DINT CONST a,b) :
+ EXTERNAL 152
+ENDOP DIV ;
+
+DINT OP MOD (DINT CONST a,b) :
+ EXTERNAL 153
+ENDOP MOD ;
+
+DINT OP AND (DINT CONST a,b) :
+ result.low := a.low AND b.low ;
+ result.high := a.high AND b.high ;
+ result
+ENDOP AND ;
+
+DINT OP OR (DINT CONST a,b) :
+ result.low := a.low OR b.low ;
+ result.high := a.high OR b.high ;
+ result
+ENDOP OR ;
+
+DINT OP XOR (DINT CONST a,b) :
+ result.low := a.low XOR b.low ;
+ result.high := a.high XOR b.high ;
+ result
+ENDOP XOR ;
+
+PROC dput (ROW 32000 DINT VAR array, DINT CONST index, value) :
+ EXTERNAL 139
+ENDPROC dput ;
+
+PROC dget (ROW 32000 DINT VAR array, DINT CONST index, DINT VAR dest) :
+ EXTERNAL 140
+ENDPROC dget ;
+
+PROC dinc1 (DINT VAR dest) :
+ EXTERNAL 131
+ENDPROC dinc1 ;
+
+PROC ddec1 (DINT VAR dest) :
+ EXTERNAL 132
+ENDPROC ddec1 ;
+
+DINT OP * (DINT CONST a,b) :
+ EXTERNAL 151
+ENDOP * ;
+
+#page#
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR memory management mode, global address offset, packet base,
+ hash table pointer, nt link, permanent pointer, param link,
+ packet link, index, mode, field pointer, word,
+ number of errors := 0 ;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 13.11.1986 *)
+(* 1.8.1 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+TYPE LIB = STRUCT (TEXT name, INT nt link, pt link, ADDRESS base) ;
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+ before first pt entry = 22784 ,
+ first permanent entry = 22785 ,
+ end of permanent table = 32767 ,
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+ four word length = 4 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+ permanent param proc end marker = 0 ,
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+ begin of pt minus ptt limit 1 = 12785 , (* plus wordlength *)
+
+ void id = 0 ,
+ int id = 1 ,
+ real id = 2 ,
+ string id = 3 ,
+ bool id = 5 ,
+ bool result id = 6 ,
+ dataspace id = 7 ,
+ undefined id = 9 ,
+ row id = 10 ,
+ struct id = 11 ,
+ end id = 0 ,
+
+ const = 1 ,
+ var = 2 ,
+ proc id = 3 ,
+(* denoter = 5 , *)
+ bold = 2 ,
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+ prep coder mode = 5 ,
+
+ warning message = 2 ,
+ error message = 4 ,
+
+ point line = "..............." ;
+
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+
+BOOL VAR coder active := FALSE ;
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+LET coder not active = "CODER not active" ,
+ illegal define packet = "illegal define packet" ;
+
+PROC coder on (INT CONST data allocation mode) :
+ mark coder on ;
+ init opn section ;
+ init compiler ;
+ init memory management .
+
+mark coder on :
+ coder active := TRUE .
+
+init memory management :
+ memory management mode := data allocation mode .
+
+init compiler :
+ no do again ;
+ elan (prep coder mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+
+ENDPROC coder on;
+
+PROC coder off (BOOL CONST insert, sermon, OPN CONST start proc) :
+ IF coder active
+ THEN mark coder off ;
+ end coder (insert, sermon, start mod nr if no insert)
+ ELSE errorstop (coder not active)
+ FI .
+
+start mod nr if no insert :
+ IF insert THEN run again mod nr := 0
+ ELSE run again mod nr := start proc.mod nr
+ FI ;
+ run again mod nr .
+
+mark coder off :
+ reset memory management mode ;
+ init opn section ;
+ coder active := FALSE
+ENDPROC coder off ;
+
+PROC end coder (BOOL CONST insert wanted, sermon wanted, INT CONST mod) :
+ EXTERNAL 10021
+ENDPROC end coder ;
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+PROC unsigned arithmetic :
+ EXTERNAL 92
+ENDPROC unsigned arithmetic ;
+
+
+ (***** Paket-Rahmen *****)
+
+PROC declare (TEXT CONST name, LIB VAR packet) :
+ packet.name := name
+ENDPROC declare ;
+
+PROC define (LIB VAR packet) :
+ check if definition possible ;
+ declare object (packet.name, packet.nt link, packet.pt link) ;
+ open packet (packet.nt link, global address offset, packet base) ;
+ set to actual base (packet) .
+
+check if definition possible :
+ IF NOT coder active THEN errorstop (coder not active) FI ;
+ IF module open THEN errorstop (illegal define packet) FI
+ENDPROC define ;
+
+PROC open packet (INT CONST nt link of packet name, INT VAR offset, base) :
+ EXTERNAL 10032
+ENDPROC open packet ;
+
+PROC identify (TEXT CONST name, LIB VAR packet, BOOL VAR packet exists) :
+ to packet (name) ;
+ packet exists := found ;
+ IF found THEN packet.name := name ;
+ packet.nt link := nt link ;
+ packet.pt link := packet link ;
+ get pbas (packet.base)
+ FI
+ENDPROC identify ;
+
+
+ (***** Hash/Namenstabelle *****)
+.
+next hash entry :
+ hash table pointer INCR wordlength .
+
+end of hash table reached :
+ hash table pointer > end of hash table .
+
+yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ mode := cdb int (param link) ;
+ IF mode = permanent type field
+ THEN param link INCR wordlength ;
+ LEAVE skip over permanent struct
+ FI ;
+ next pt param
+ PER
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELIF mode = permanent param proc THEN translate type
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+PROC put next permanent (INT CONST permanent value) :
+ EXTERNAL 10020
+ENDPROC put next permanent ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 2. Spruenge und Marken 07.10.1986 *)
+(* *)
+(* Definition des Datentyps LABEL *)
+(* *)
+(* Deklaration, Definition und Applikation von Marken *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE LABEL = INT ;
+
+BOOL VAR invers :: FALSE ;
+
+PROC declare (LABEL VAR label) :
+ CONCR (label) := 0
+ENDPROC declare ;
+
+PROC define (LABEL VAR label) :
+ EXTERNAL 10085
+ENDPROC define ;
+
+PROC complement condition code :
+ invers := NOT invers
+ENDPROC complement condition code ;
+
+PROC apply (LABEL VAR label) :
+ EXTERNAL 10151
+ENDPROC apply ;
+
+PROC apply (LABEL VAR label, BOOL CONST condition) :
+ IF condition xor invers THEN branch true (label)
+ ELSE branch false (label)
+ FI ;
+ invers := FALSE .
+
+condition xor invers :
+ IF condition THEN NOT invers
+ ELSE invers
+ FI
+ENDPROC apply ;
+
+OP := (LABEL VAR global label, local label) : (* EQUATE ! *)
+ EXTERNAL 10014
+ENDOP := ;
+
+TEXT PROC dump (LABEL CONST label) :
+ "LAB " + text (CONCR (label))
+ENDPROC dump ;
+
+PROC gosub (LABEL VAR label) :
+ EXTERNAL 10015
+ENDPROC gosub ;
+
+PROC goret :
+ s0 (q goret code)
+ENDPROC goret ;
+
+PROC branch true (LABEL VAR label) :
+ EXTERNAL 10028
+ENDPROC branch true ;
+
+PROC branch false (LABEL VAR label) :
+ EXTERNAL 10029
+ENDPROC branch false ;
+
+PROC computed branch (ADDRESS CONST switch, INT CONST limit, LABEL VAR out) :
+ s1 (q esc case, REPR switch) ;
+ s0 (limit) ;
+ branch false (out)
+ENDPROC computed branch ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 3. Datenaddressen 13.11.1986 *)
+(* *)
+(* Definition des Datentyps ADDRESS *)
+(* *)
+(* Aufbau von Datenaddressen (Vercodung) *)
+(* Fortschalten und Ausrichten von Adressen *)
+(* Behandlung von Paketbasis-Adressen *)
+(* Bereitstellen der Fehlermeldung "address overflow" (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE ADDRESS = STRUCT (INT kind, value) ;
+
+LET global = 0 ,
+ local = 1 ,
+ ref mask = 2 ,
+ global ref = 2 ,
+ local ref = 3 ,
+ module nr = 4 ,
+ immediate value = 5 ,
+ p base = 6 ,
+
+ eumel0 stack offset = 4 ,
+ local address limit = 16 384 ,
+ global address zero = 0 ,
+
+ illegal ref operation = "REF not allowed" ,
+ deref on non ref = "DEREF on non-ref address" ,
+ global ref not allowed = "GLOBAL REF not allowed" ,
+ unknown kind = "Unknown address kind" ,
+ address overflow = "Address Overflow" ,
+ illegal plus operation = "+ not allowed" ;
+
+ADDRESS VAR result addr;
+
+INT CONST ref length :: 2 ;
+
+OP := (ADDRESS VAR l, ADDRESS CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+ADDRESS OP GLOB (INT CONST address level) :
+ result addr.kind := global ;
+ result addr.value := address level ;
+ IF memory management mode = data allocation by user
+ THEN result addr.value INCR global address offset
+ FI ;
+ result addr
+ENDOP GLOB ;
+
+ADDRESS OP LOC (INT CONST address level) :
+ result addr.kind := local ;
+ result addr.value := address level + eumel0 stack offset ;
+ result addr
+ENDOP LOC ;
+
+ADDRESS OP REF (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ IF result addr.kind = local THEN result addr.kind INCR ref mask
+ ELIF result addr.kind = global THEN errorstop (global ref not allowed)
+ ELSE errorstop (illegal ref operation)
+ FI ;
+ result addr
+ENDOP REF ;
+
+ADDRESS OP DEREF (ADDRESS CONST ref address) :
+ CONCR (result addr) := CONCR (ref address) ;
+ IF is not local ref THEN errorstop (deref on non ref) FI ;
+ result addr.kind DECR ref mask ;
+ result addr .
+
+is not local ref :
+ result addr.kind <> local ref
+ENDOP DEREF ;
+
+INT OP REPR (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global :
+ CASE local : set bit (result addr.value, 15)
+ CASE global ref : errorstop (global ref not allowed)
+ CASE local ref : prep local ref
+ OTHERWISE errorstop (unknown kind)
+ ENDSELECT ;
+ result addr.value .
+
+prep local ref :
+ IF address limit exceeded THEN errorstop (address overflow) FI ;
+ set bit (result addr.value, 14) ;
+ set bit (result addr.value, 15) .
+
+address limit exceeded :
+ result addr.value < eumel0 stack offset OR
+ result addr.value > local address limit
+ENDOP REPR ;
+
+PROC get base (LIB CONST packet, ADDRESS VAR base) :
+ CONCR (base) := CONCR (packet.base)
+ENDPROC get base ;
+
+PROC set to actual base (LIB VAR packet) :
+ packet.base.kind := p base ;
+ packet.base.value := packet base
+ENDPROC set to actual base ;
+
+PROC get pbas (ADDRESS VAR base) :
+ base.kind := p base ;
+ base.value := cdbint (packet link + 2)
+ENDPROC get pbas ;
+
+BOOL OP = (ADDRESS CONST l,r) :
+ l.kind = r.kind AND l.value = r.value
+ENDOP = ;
+
+BOOL PROC is ref (ADDRESS CONST addr) :
+ addr.kind = local ref
+ENDPROC is ref ;
+
+BOOL PROC is global (ADDRESS CONST addr) :
+ addr.kind = global
+ENDPROC is global ;
+
+BOOL PROC is local (ADDRESS CONST addr) :
+ addr.kind = local
+ENDPROC is local ;
+
+ADDRESS OP + (ADDRESS CONST addr, INT CONST offset) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global : inc global
+ CASE local : inc local
+ OTHERWISE errorstop (illegal plus operation)
+ ENDSELECT ;
+ result addr .
+
+inc global :
+ result addr.value INCR offset ;
+ IF result addr.value < 0 THEN errorstop (address overflow) FI .
+
+inc local :
+ result addr.value INCR offset ;
+ IF result addr.value < eumel 0 stack offset OR
+ result addr.value > local address limit
+ THEN errorstop (address overflow)
+ FI
+ENDOP + ;
+
+PROC adjust (ADDRESS VAR addr, INT CONST adjust length) :
+ IF is local or global THEN adjust to length FI .
+
+is local or global :
+ addr.kind <= local .
+
+adjust to length :
+ mode := addr.value MOD adjust length ;
+ IF mode <> 0 THEN addr.value INCR (adjust length-mode) FI
+ENDPROC adjust ;
+
+TEXT PROC dump (ADDRESS CONST addr) :
+ kind + text (addr.value) .
+
+kind :
+ SELECT addr.kind OF
+ CASE global : "GLOBAL "
+ CASE local : "LOCAL "
+ CASE immediate value : "IMMEDIATE "
+ CASE module nr : "PARAM PROC "
+ CASE global ref : "GLOBAL REF "
+ CASE local ref : "LOCAL REF "
+ CASE p base : "PBAS "
+ OTHERWISE "undef. Addr: "
+ ENDSELECT
+ENDPROC dump;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 4. Datentypen Teil I 08.09.1986 *)
+(* *)
+(* Definition des Datentyps DTYPE *)
+(* *)
+(* Interne Repraesentation der primitiven Datentypen *)
+(* Identifikation von DTYPEs *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE DTYPE = INT ;
+
+OP := (DTYPE VAR l, DTYPE CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+BOOL OP = (DTYPE CONST l, r) :
+ CONCR (l) = CONCR (r)
+ENDOP = ;
+
+DTYPE PROC void type : DTYPE :(void id) ENDPROC void type ;
+
+DTYPE PROC int type : DTYPE :(int id) ENDPROC int type ;
+
+DTYPE PROC real type : DTYPE :(real id) ENDPROC real type ;
+
+DTYPE PROC text type : DTYPE :(string id) ENDPROC text type ;
+
+DTYPE PROC bool type : DTYPE :(bool id) ENDPROC bool type ;
+
+DTYPE PROC bool result type : DTYPE :(bool result id) ENDPROC bool result type;
+
+DTYPE PROC dataspace type : DTYPE :(dataspace id) ENDPROC dataspace type ;
+
+DTYPE PROC undefined type : DTYPE :(undefined id) ENDPROC undefined type ;
+
+DTYPE PROC row type : DTYPE :(row id) ENDPROC row type ;
+
+DTYPE PROC struct type : DTYPE :(struct id) ENDPROC struct type ;
+
+DTYPE PROC proc type : DTYPE :(permanent param proc) ENDPROC proc type ;
+
+DTYPE PROC end type : DTYPE :(end id) ENDPROC end type ;
+
+INT PROC type class (DTYPE CONST type) :
+ SELECT type id OF
+ CASE int id, real id, bool id, bool result id, string id,
+ dataspace id, undefined id : 1
+ CASE void id : 0
+ CASE row id : 3
+ CASE struct id : 4
+ CASE permanent param proc : 5
+ OTHERWISE pt type
+ ENDSELECT .
+
+pt type :
+ IF type id > ptt limit THEN permanent row or struct
+ ELSE abstract type
+ FI .
+
+abstract type : 2 .
+
+permanent row or struct :
+ unsigned arithmetic ;
+ mode := cdbint (type link into pt) MOD ptt limit ;
+ IF mode = struct id THEN 4
+ ELIF mode = row id THEN 3
+ ELIF mode = permanent param proc THEN 5
+ ELSE 2
+ FI .
+
+type link into pt :
+ type id + begin of pt minus ptt limit .
+
+type id : CONCR (type)
+ENDPROC type class ;
+
+PROC identify (TEXT CONST name,INT VAR size, align, DTYPE VAR type) :
+ SELECT type pos OF
+ CASE 1 : size := 0; align := 0; type id := void id
+ CASE 6 : size := 1; align := 1; type id := int id
+ CASE 10 : size := 4; align := 4; type id := real id
+ CASE 15 : size := 8; align := 4; type id := string id
+ CASE 20 : size := 1; align := 1; type id := bool id
+ CASE 25 : size := 1; align := 1; type id := dataspace id
+ OTHERWISE search for type in permanent table
+ ENDSELECT .
+
+type pos :
+ enclose in delimiters ;
+ pos (".VOID.INT.REAL.TEXT.BOOL.DATASPACE.", object name) .
+
+enclose in delimiters :
+ object name := "." ;
+ object name CAT name ;
+ object name CAT "." .
+
+search for type in permanent table :
+ to object (name) ;
+ IF not found THEN size := 0; align := 0; type id := undefined id
+ ELSE size := cdbint (permanent pointer + two wordlength) ;
+ type id := permanent pointer - begin of permanent table ;
+ IF size < two wordlength THEN align := 1
+ ELIF size < four wordlength THEN align := 2
+ ELSE align := 4
+ FI
+ FI .
+
+not found :
+ NOT found OR invalid entry .
+
+invalid entry :
+ permanent pointer = 0 OR
+ cdb int (permanent pointer + wordlength) <> permanent type .
+
+type id : CONCR (type)
+ENDPROC identify ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 5. Operationen Teil I 30.09.1986 *)
+(* *)
+(* Definition des Datentyps OPN *)
+(* Primitive Operationen (:= etc.) *)
+(* Initialisieren mit den externen Namen der EUMEL-0-Codes *)
+(* Bereitstellen dee Fehlermeldung 'proc op expected' (coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+TYPE OPN = STRUCT (INT kind, mod nr, top of stack) ;
+
+LET proc op = 0 ,
+ param proc = 1 ,
+ eumel 0 = 2 ,
+ nil = 3 ,
+
+ param proc at non ref = "PARAM PROC at non-ref address" ,
+ proc op expected = "PROC expected" ;
+
+OPN VAR eumel0 opn;
+eumel0 opn.kind := eumel0 ;
+eumel0 opn.top of stack := 0 ;
+
+eumel0 opn.mod nr := q pp ;
+OPN CONST pp :: eumel0 opn ,
+ nop code :: OPN :(nil, 0, 0) ;
+
+IF NOT exists ("eumel0 codes")
+ THEN IF yes ("Archive 'eumel coder' eingelegt")
+ THEN archive ("eumel coder") ;
+ fetch ("eumel0 codes", archive) ;
+ release (archive)
+ ELSE errorstop ("""eumel0 codes"" gibt es nicht")
+ FI
+FI ;
+BOUND THESAURUS VAR initial opcodes :: old ("eumel0 codes") ;
+THESAURUS VAR eumel 0 opcodes :: initial opcodes ;
+forget ("eumel0 codes") ;
+
+ADDRESS PROC address (OPN CONST opn) :
+ IF opn.kind <> proc op THEN errorstop (proc op expected) FI ;
+ result addr.kind := module nr ;
+ result addr.value := opn.mod nr ;
+ result addr
+ENDPROC address ;
+
+OPN PROC operation (ADDRESS CONST addr) :
+ IF addr.kind <> local ref THEN errorstop (param proc at non ref) FI ;
+ OPN VAR opn ;
+ opn.kind := param proc ;
+ opn.mod nr :=addr.value ;
+ opn.top of stack := 0 ;
+ opn
+ENDPROC operation ;
+
+TEXT PROC mnemonic (OPN CONST op code) :
+ name (eumel 0 opcodes, op code.mod nr)
+ENDPROC mnemonic ;
+
+OPN PROC nop :
+ nop code
+ENDPROC nop ;
+
+OP := (OPN VAR r, OPN CONST l) :
+ CONCR (r) := CONCR (l)
+ENDOP := ;
+
+BOOL PROC is proc (OPN CONST operation) :
+ operation.kind = proc op
+ENDPROC is proc ;
+
+BOOL PROC is eumel 0 instruction (TEXT CONST op code name) :
+ link (eumel 0 opcodes, op code name) <> 0
+ENDPROC is eumel 0 instruction ;
+
+BOOL PROC is eumel 0 instruction (OPN CONST operation) :
+ operation.kind = eumel0
+ENDPROC is eumel 0 instruction ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 6. Parameterfeld 10.04.1986 *)
+(* *)
+(* Bereitstellen des Parameterfeldes *)
+(* Schreiben und Lesen von Eintraegen im Parameterfeld *)
+(* Fortschalten von Zeigern in das Parameterfeld *)
+(* Bereitstellen der Konstanten 'size of param field' (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+LET PARAMDESCRIPTOR = STRUCT (DTYPE type, INT access,
+ ADDRESS addr, OPN push opn) ,
+
+ size of param field = 100 ,
+ param field exceeded = "Param Field Overflow",
+ param nr out of range = "Illegal Param Number" ;
+
+ROW size of param field PARAMDESCRIPTOR VAR param field ;
+
+
+ (***** Schreiben *****)
+
+PROC test param pos (INT CONST param nr) :
+ IF param nr < 1 OR param nr > size of param field
+ THEN errorstop (param nr out of range)
+ FI
+ENDPROC test param pos ;
+
+PROC declare (INT CONST param nr, DTYPE CONST type) :
+ test param pos (param nr) ;
+ enter type .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type)
+ENDPROC declare ;
+
+PROC declare (INT CONST param nr, access) :
+ test param pos (param nr) ;
+ enter access .
+
+enter access :
+ param field [param nr].access := access
+ENDPROC declare ;
+
+PROC define (INT CONST param nr, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter address .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr)
+ENDPROC define ;
+
+PROC define (INT CONST param nr, value) :
+ result addr.kind := immediate value ;
+ result addr.value := value ;
+ define (param nr, result addr)
+ENDPROC define ;
+
+PROC apply (INT CONST param nr, OPN CONST opn) :
+ test param pos (param nr) ;
+ enter push opn .
+
+enter push opn :
+ CONCR (param field [param nr].push opn) := CONCR (opn)
+ENDPROC apply ;
+
+PROC parameter (INT CONST param nr, DTYPE CONST type,
+ INT CONST access, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter type ;
+ enter access ;
+ enter address ;
+ enter pp as default .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type) .
+
+enter access :
+ param field [param nr].access := access .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr) .
+
+enter pp as default :
+ CONCR (param field [param nr].push opn) := CONCR (pp)
+ENDPROC parameter ;
+
+
+ (***** Lesen *****)
+
+ADDRESS PROC param address (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].addr
+ENDPROC param address ;
+
+DTYPE PROC dtype (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].type
+ENDPROC dtype ;
+
+INT PROC access (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].access
+ENDPROC access ;
+
+
+ (***** Fortschalten *****)
+
+OP NEXTPARAM (INT VAR param nr) :
+ test param pos (param nr) ;
+ INT CONST class :: type class (param field [param nr].type) ;
+ param nr INCR 1 ;
+ SELECT class OF
+ CASE 3 : NEXTPARAM param nr
+ CASE 4,5 : read until end
+ ENDSELECT .
+
+read until end :
+ WHILE NOT end marker read or end of field REP
+ NEXTPARAM param nr
+ PER ;
+ param nr INCR 1 .
+
+end marker read or end of field :
+ param nr > size of param field OR
+ CONCR (param field [param nr].type) = end id
+ENDOP NEXTPARAM ;
+
+INT PROC next param (INT CONST p) :
+ INT VAR index := p ;
+ NEXTPARAM index ;
+ index
+ENDPROC next param ;
+
+TEXT PROC dump (INT CONST p) :
+ IF p > 0 AND p <= 100 THEN dump entry (param field (p))
+ ELSE param nr out of range
+ FI
+ENDPROC dump ;
+
+TEXT PROC dump entry (PARAMDESCRIPTOR CONST id) :
+(* object name := dump (id.type) ; *)
+ object name := "TYPE " ; (* siehe *)
+ object name CAT dump (id.type) ; (* TEXT PROC dump (DTYPE d) *)
+ object name CAT text (id.access) ;
+ object name CAT dump (id.addr) ;
+ object name CAT dump (id.push opn) ;
+ object name
+ENDPROC dump entry ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 7. Datentypen Teil II 08.09.1986 *)
+(* *)
+(* Deklaration neuer Datentypen *)
+(* Vergleich von DTYPEs im Parameterfeld und in der Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+
+DTYPE VAR pt type ;
+
+PROC declare (TEXT CONST name, INT CONST size, align, DTYPE VAR type) :
+ entry into name table ;
+ put next permanent (permanent type) ;
+ put next permanent (size) ;
+ put next permanent (nt link) ;
+ mark no offsets of text elements .
+
+entry into name table :
+ declare object (name, nt link, CONCR (type)) ;
+ CONCR (type) DECR begin of permanent table .
+
+mark no offsets of text elements :
+ put next permanent (0)
+ENDPROC declare ;
+
+BOOL PROC same type (INT CONST param 1, param 2) :
+ INT CONST left type :: CONCR (param field [param 1].type) ;
+ IF left type = right type
+ THEN same fine structure if there is one
+ ELSE left type = undefined id OR right type = undefined id
+ FI .
+
+right type : CONCR (param field [param 2].type) .
+
+same fine structure if there is one :
+ IF left type = row id THEN compare row
+ ELIF left is struct or proc THEN compare struct
+ ELSE TRUE
+ FI .
+
+left is struct or proc :
+ left type = struct id OR left type = proc id .
+
+compare row :
+ equal sizes AND same type (param1 + 1, param2 + 1) .
+
+equal sizes :
+ param field [param1+1].access = param field [param2+1].access .
+
+compare struct :
+ INT VAR p1 :: param1+1, p2 :: param2+1 ;
+ WHILE same type (p1, p2) AND NOT end type found REP
+ NEXTPARAM p1 ;
+ NEXTPARAM p2
+ UNTIL end of field PER ;
+ FALSE .
+
+end type found :
+ CONCR (param field [p1].type) = end id .
+
+end of field :
+ p1 > size of param field OR p2 > size of param field
+ENDPROC same type ;
+
+BOOL PROC same type (INT CONST param nr, DTYPE CONST type) :
+ field pointer := param nr ;
+ CONCR (pt type) := CONCR (type) ;
+ equal types
+ENDPROC same type ;
+
+BOOL PROC equal types :
+ identical types OR one type is undefined .
+
+one type is undefined :
+ type of actual field = undefined id OR CONCR(pt type) = undefined id .
+
+identical types :
+ SELECT type class (pt type) OF
+ CASE 0, 1, 2 : type of actual field = CONCR (pt type)
+ CASE 3 : perhaps equal rows
+ CASE 4 : perhaps equal structs
+ CASE 5 : perhaps equal param procs
+ OTHERWISE FALSE
+ ENDSELECT .
+
+perhaps equal rows :
+ param link := CONCR (pt type) + begin of pt minus ptt limit ;
+ is row AND equal row sizes AND equal row types .
+
+is row :
+ type of actual field = row id .
+
+perhaps equal structs :
+ param link := CONCR (pt type) + begin of pt minus ptt limit ;
+ is struct AND same type fields .
+
+is struct :
+ type of actual field = struct id .
+
+equal row sizes :
+ pt row size = row size within param field .
+
+equal row types :
+ field pointer INCR 1 ;
+ param link INCR 2 ;
+ get type and mode (CONCR(pt type)) ;
+ equal types .
+
+pt row size :
+ cdb int (param link + 1) .
+
+row size within param field :
+ param field [field pointer + 1].access .
+
+same type fields :
+ REP
+ field pointer INCR 1 ;
+ param link INCR 1 ;
+ IF type of actual field = end id
+ THEN LEAVE same type fields WITH pt struct end reached
+ FI ;
+ get type and mode (CONCR(pt type)) ;
+ IF NOT equal types THEN LEAVE same type fields WITH FALSE FI
+ UNTIL end of field PER ;
+ FALSE .
+
+pt struct end reached :
+ cdbint (param link) = permanent type field .
+
+end of field :
+ field pointer > size of param field .
+
+type of actual field :
+ CONCR (param field [field pointer].type) .
+
+perhaps equal param procs :
+ param link := CONCR (pt type) + begin of pt minus ptt limit ;
+ is proc AND same param list .
+
+is proc : cdbint (param link) = permanent param proc .
+
+same param list :
+ param link INCR wordlength ;
+ DTYPE VAR proc result type ;
+ get type and mode (CONCR (proc result type)) ;
+ compare param list ;
+ check results .
+
+compare param list :
+ INT VAR last param := field pointer + 1 ;
+ REP
+ field pointer INCR 1 ;
+ param link INCR wordlength ;
+ IF pt param list exhausted THEN LEAVE compare param list FI ;
+ IF type of actual field = end id
+ THEN LEAVE equal types WITH FALSE
+ FI ;
+ get type and mode (CONCR(pt type)) ;
+ last param := field pointer ;
+ UNTIL NOT equal types OR end of field PER .
+
+check results :
+ pt param list exhausted AND equal result types .
+
+equal result types :
+ save param link ;
+ IF same type (last param, proc result type)
+ THEN restore ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+pt param list exhausted :
+ cdbint (param link) = permanent param proc end marker .
+
+save param link :
+ INT CONST p :: param link .
+
+restore :
+ field pointer INCR 1 ;
+ param link := p
+
+ENDPROC equal types ;
+
+BOOL PROC is not void bool or undefined (DTYPE CONST dtype) :
+ type <> void id AND type <> bool result id AND type <> undefined id .
+
+type : CONCR (dtype)
+ENDPROC is not void bool or undefined ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 8. Operationen Teil II 08.09.1986 *)
+(* *)
+(* Definition der Opcodes *)
+(* Deklaration, Definition, Identifikation und Applikation *)
+(* Eroeffnen und Schliessen eines Moduls *)
+(* *)
+(**************************************************************************)
+
+
+
+LET module not opened = "Module not opened" ,
+ define missing = "DEFINE missing" ,
+ wrong nr of params = "Wrong Nr. of Params:" ,
+ illegal kind = "Opcode expected" ,
+ nested module = "Nested Modules" ,
+ no mod nr = "Param Proc expected" ,
+ no immediate value = "Value expected" ,
+ type error = "Type Error" ,
+
+ q ln = 1 ,
+ q move = 2 , q move code = 2 048 ,
+ q inc1 = 3 , q inc1 code = 3 072 ,
+ q dec1 = 4 , q dec1 code = 4 096 ,
+ q inc = 5 , q inc code = 5 120 ,
+ q dec = 6 , q dec code = 6 144 ,
+ q add = 7 , q add code = 7 168 ,
+ q sub = 8 , q sub code = 8 192 ,
+ q clear = 9 , q clear code = 9 216 ,
+ q test = 10 ,
+ q equ = 11 , q equ code = 11 264 ,
+ q lsequ = 12 , q lsequ code = 12 288 ,
+ q fmove = 13 , q fmove code = 13 312 ,
+ q fadd = 14 , q fadd code = 14 336 ,
+ q fsub = 15 , q fsub code = 15 360 ,
+ q fmult = 16 , q fmult code = 16 384 ,
+ q fdiv = 17 , q fdiv code = 17 408 ,
+ q flsequ = 18 , q flsequ code = 18 432 ,
+ q tmove = 19 , q tmove code = 19 456 ,
+ q tequ = 20 , q tequ code = 20 480 ,
+ q accds = 21 , q access ds code = 22 528 ,
+ q ref = 22 , q ref code = 23 552 ,
+ q subscript = 23 , q subscript code = 24 576 ,
+ q select = 24 , q select code = 25 600 ,
+ q ppv = 25 , q ppv code = 26 624 ,
+ q pp = 26 ,
+ q make false = 27 , (* q make false code = 65 513 *)
+ q movex = 28 ,
+(* q longa subs q longa subs code = 65 376 *)
+ q return = 29 , q return code = 32 512 ,
+ q true return = 30 , q true return code = 32 513 ,
+ q false return = 31 , q false return code = 32 514 ,
+ q goret code = 32 519 ,
+ q esc mult = 32 , q esc mult code = 32 553 ,
+ q esc div = 33 , q esc div code = 32 554 ,
+ q esc mod = 34 , q esc mod code = 32 555 ,
+ q pproc = 35 ,
+ q compl int = 36 , q compl int code = 32 551 ,
+ q compl real = 37 , q compl real code = 32 550 ,
+ q alias ds = 38 , q alias ds code = 32 546 ,
+ q movim = 39 , q esc movim code = 32 547 ,
+ q fequ = 40 , q fequ code = 32 548 ,
+ q tlsequ = 41 , q tlsequ code = 32 549 ,
+(* q case = 42 , *) q esc case = 32 544 ,
+ q plus = 43 ,
+ q minus = 44 ,
+ q mult = 45 ,
+ q int div = 46 ,
+ q real div = 47 ,
+ q equal = 48 ,
+ q lessequal = 49 ,
+ q ulseq = 50 , q ulseq code = 21 504 ,
+ q pdadd = 51 , q pdadd code = 32 653 ,
+ q ppsub = 52 , q ppsub code = 32 654 ,
+ q dimov = 53 , q dimov code = 32 655 ,
+ q idmov = 54 , q idmov code = 32 656 ;
+
+INT CONST q make false code :: - 1 022 ,
+ q longa subs code :: - 159 ,
+ q penter code :: - 511 ;
+
+
+ (***** Deklaration *****)
+
+PROC declare (OPN VAR operation) :
+ operation.kind := proc op ;
+ get module nr (operation.mod nr) ;
+ operation.top of stack := 0
+ENDPROC declare ;
+
+PROC declare (TEXT CONST name, INT CONST first, params, OPN VAR operation) :
+ declare (operation) ;
+ entry into name and pt table if necessary ;
+ enter params ;
+ enter result ;
+ enter module number .
+
+entry into name and pt table if necessary :
+ declare object (name, nt link, permanent pointer) .
+
+enter params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO params REP
+ enter param (param field [field pointer]) ;
+ NEXTPARAM field pointer
+ PER .
+
+enter result :
+ enter param (param field[field pointer].type, permanent proc op) .
+
+enter module number :
+ put next permanent (operation.mod nr)
+ENDPROC declare ;
+
+PROC enter param (PARAMDESCRIPTOR CONST param) :
+ IF param.access = const
+ THEN enter param (param.type, permanent param const)
+ ELIF param.access = var
+ THEN enter param (param.type, permanent param var)
+ ELSE errorstop ("Unknown Access")
+ FI
+ENDPROC enter param ;
+
+PROC enter param (DTYPE CONST type, INT CONST permanent mode) :
+ unsigned arithmetic ;
+ SELECT type class (type) OF
+ CASE 0, 1, 2 : put next permanent (CONCR(type) + permanent mode)
+ OTHERWISE errorstop ("Illegal Type")
+ ENDSELECT
+ENDPROC enter param ;
+
+
+ (***** Definition *****)
+
+PROC define (OPN VAR opn) :
+ IF NOT module open THEN errorstop (module not opened)
+ ELSE proc head (opn.mod nr, opn.top of stack)
+ FI
+ENDPROC define ;
+
+PROC set length of local storage (OPN VAR opn, INT CONST size) :
+ IF size < 0 OR size > local address limit
+ THEN errorstop (address overflow)
+ ELIF opn.top of stack = 0
+ THEN errorstop (define missing)
+ ELIF opn.kind <> proc op
+ THEN errorstop (proc op expected)
+ FI ;
+ set length (opn.top of stack, size + eumel0 stack offset)
+ENDPROC set length of local storage ;
+
+PROC define (OPN VAR operation, INT CONST size) :
+ define (operation) ;
+ set length of local storage (operation, size)
+ENDPROC define ;
+
+
+ (***** Identifikation *****)
+
+INT VAR counter, result index, result type repr;
+
+PROC identify (TEXT CONST name, INT CONST first, params, OPN VAR operation,
+ BOOL VAR object exists) :
+ find result entry ;
+ to object (name) ;
+ IF found THEN first fit and leave if found FI ;
+ IF eumel0 THEN identify eumel0 instruction
+ ELSE yield undefined operation
+ FI .
+
+find result entry :
+ result index := first;
+ counter := 0 ;
+ WHILE counter < params REP
+ NEXTPARAM result index ;
+ counter INCR 1
+ PER ;
+ check on param field exceeded .
+
+check on param field exceeded :
+ IF result index > size of param field
+ THEN errorstop (param field exceeded)
+ FI .
+
+yield undefined operation :
+ declare (result index, undefined type) ;
+ apply (result index, nop) ;
+ object exists := FALSE .
+
+first fit and leave if found :
+ WHILE yet another procedure exists REP
+ check one procedure and leave if match ;
+ next procedure
+ PER .
+
+yet another procedure exists :
+ permanent pointer <> 0 .
+
+check one procedure and leave if match:
+ param link := permanent pointer + wordlength ;
+ set end marker if end of list ;
+ counter := params ;
+ field pointer := first ;
+ REP
+ IF end of params AND counter = 0
+ THEN procedure found
+ ELIF end of params OR counter = 0
+ THEN LEAVE check one procedure and leave if match
+ ELSE check next param
+ FI
+ PER .
+
+check next param :
+ get type and mode (CONCR(pt type)) ;
+ IF same types THEN set param mode ;
+ field pointer INCR 1 ;
+ param link INCR 1 ;
+ set end marker if end of list ;
+ counter DECR 1 ;
+ ELSE LEAVE check one procedure and leave if match
+ FI .
+
+same types : (* inline version ! *)
+ equal types .
+
+set param mode :
+ param field [field pointer].access := mode .
+
+procedure found :
+ get result ;
+ operation.kind := proc op ;
+ operation.mod nr := module number ;
+ operation.top of stack := 0 ;
+ object exists := TRUE ;
+ LEAVE identify .
+
+get result :
+ get type and mode (result type) ;
+ declare (result index, mode) .
+
+module number :
+ cdbint (param link + 1) .
+
+result type :
+ CONCR (param field [result index].type) .
+
+eumel0 :
+ eumel0 opn.mod nr := link (eumel 0 opcodes, name) ;
+ eumel0 opn.mod nr <> 0 .
+
+identify eumel 0 instruction :
+ init result type with void ;
+ CONCR (operation) := CONCR (eumel0 opn) ;
+ object exists := check params and set result ;
+ declare (result index, DTYPE:(result type repr)) ;
+ declare (result index, const) .
+
+init result type with void :
+ result type repr := void id .
+
+check params and set result :
+ SELECT operation.mod nr OF
+ CASE q return, q false return, q true return : no params
+ CASE q inc1, q dec1 : one int param yielding void
+ CASE q pproc, q pp, q ln : one param yielding void
+ CASE q test : one param yielding bool
+ CASE q clear, q ppv : one int or bool param yielding void
+ CASE q make false : one bool param yielding void
+ CASE q move : two int or bool params yielding void
+ CASE q compl int, q inc, q dec : two int params yielding void
+ CASE q compl real, q fmove : two real params yielding void
+ CASE q equ, q lsequ, q ulseq : two int params yielding bool
+ CASE q fequ, q flsequ : two real params yielding bool
+ CASE q tequ, q tlsequ : two text params yielding bool
+ CASE q tmove : two text params yielding void
+ CASE q accds, q ref, q movim,
+ q dimov, q idmov : two params yielding void
+ CASE q add, q sub, q esc mult,
+ q esc div, q esc mod : three int params yielding void
+ CASE q fadd, q fsub, q fmult, q fdiv : three real params yielding void
+ CASE q select, q movex, q alias ds,
+ q pdadd, q ppsub : three params
+ CASE q subscript : five params
+ CASE q plus, q mult : two intreals yielding intreal
+ CASE q minus : monadic or dyadic minus
+ CASE q int div : two int params yielding int
+ CASE q real div : two real params yielding real
+ CASE q equal, q lessequal : two intrealtexts yielding bool
+ OTHERWISE FALSE
+ ENDSELECT .
+
+no params :
+ params = 0 .
+
+one int param yielding void :
+ p1 void (int type, first, params) .
+
+one param yielding void :
+ params = 1 .
+
+one param yielding bool :
+ IF params = 1 THEN result type repr := bool id ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+one int or bool param yielding void :
+ p1 void (int type, first, params) OR p1 void (bool type, first, params) .
+
+one bool param yielding void :
+ p1 void (bool type, first, params) .
+
+two int or bool params yielding void :
+ p2 (int type, first, params, void id) OR
+ p2 (bool type, first, params, void id) .
+
+two int params yielding void :
+ p2 (int type, first, params, void id) .
+
+two real params yielding void :
+ p2 (real type, first, params, void id) .
+
+two text params yielding void :
+ p2 (text type, first, params, void id) .
+
+two int params yielding bool :
+ p2 (int type, first, params, bool id) .
+
+two real params yielding bool :
+ p2 (real type, first, params, bool id) .
+
+two text params yielding bool :
+ p2 (text type, first, params, bool id) .
+
+two params yielding void :
+ params = 2 .
+
+three int params yielding void :
+ p3 void (int type, first, params) .
+
+three real params yielding void :
+ p3 void (real type, first, params) .
+
+three params :
+ params = 3 .
+
+five params :
+ params = 5 .
+
+two intreals yielding intreal :
+ two int params yielding int OR two real params yielding real .
+
+monadic or dyadic minus :
+ IF params = 2 THEN two intreals yielding intreal
+ ELIF params = 1 THEN monadic minus
+ ELSE FALSE
+ FI .
+
+monadic minus :
+ result type repr := CONCR (param field[first].type) ;
+ result type repr = int id OR result type repr = real id .
+
+two intrealtexts yielding bool :
+ two int params yielding bool OR two real params yielding bool OR
+ two text params yielding bool .
+
+two int params yielding int :
+ p2 (int type, first, params, int id) .
+
+two real params yielding real :
+ p2 (real type, first, params, real id)
+ENDPROC identify ;
+
+BOOL PROC p1 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 1 AND param type is requested plain type .
+
+param type is requested plain type :
+ CONCR (param field [first].type) = CONCR (requested type)
+
+ENDPROC p1 void ;
+
+BOOL PROC p2 (DTYPE CONST requested type, INT CONST first, param nr,
+ INT CONST result type) :
+ IF param nr = 2 AND param types equal requested plain type
+ THEN result type repr := result type ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+param types equal requested plain type :
+ CONCR (param field [first] .type) = CONCR (requested type) AND
+ CONCR (param field [first+1].type) = CONCR (requested type)
+
+ENDPROC p2 ;
+
+BOOL PROC p3 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 3 AND param types ok .
+
+param types ok :
+ FOR index FROM first UPTO first+2 REP
+ IF different param types THEN LEAVE p3 void WITH FALSE FI
+ PER ;
+ TRUE .
+
+different param types :
+ CONCR (param field [index].type) <> CONCR (requested type)
+ENDPROC p3 void;
+
+
+ (***** Applikation *****)
+
+INT VAR address representation, left repr, right repr, result repr;
+
+PROC apply (INT CONST first, nr of params, OPN CONST opn) :
+ IF NOT module open THEN errorstop (module not opened) FI ;
+ SELECT opn.kind OF
+ CASE eumel 0 : generate eumel0 instruction
+ CASE proc op : call operation
+ CASE param proc : call param proc
+ CASE nil :
+ OTHERWISE errorstop (illegal kind)
+ ENDSELECT .
+
+call operation :
+ push params if necessary (first, nr of params, opn.mod nr) ;
+ call (opn.mod nr) .
+
+call param proc :
+ result addr.kind := local ref ;
+ result addr.value := opn.mod nr ;
+ INT CONST module nr := REPR result addr ;
+ push params if necessary (first, nr of params, module nr) ;
+ call param (module nr) .
+
+generate eumel0 instruction :
+ SELECT real nr of params OF
+ CASE 0 : p0 instruction
+ CASE 1 : apply p1 (opn, first addr)
+ CASE 2 : apply p2 (opn, first addr, second addr)
+ CASE 3 : apply p3 (opn, left type, first addr, second addr, third addr)
+ CASE 5 : subscript operation
+ OTHERWISE errorstop (wrong nr of params + text (nr of params))
+ ENDSELECT .
+
+real nr of params :
+ IF operator denotation THEN nr of params + 1
+ ELSE nr of params
+ FI .
+
+operator denotation :
+ opn.mod nr >= q plus AND opn.mod nr < q ulseq .
+
+p0 instruction :
+ IF opn.mod nr = q return THEN s0 (q return code)
+ ELIF opn.mod nr = q true return THEN s0 (q true return code)
+ ELIF opn.mod nr = q false return THEN s0 (q false return code)
+ ELSE errorstop (wrong nr of params +
+ mnemonic (opn))
+ FI .
+
+subscript operation :
+ IF opn.mod nr = q subscript
+ THEN subscription
+ ELSE errorstop (wrong nr of params + text (nr of params))
+ FI .
+
+subscription :
+ ADDRESS CONST element length :: param field [first+2].addr ,
+ limit :: param field [first+3].addr ;
+ check on immediates ;
+ IF element length.value < 1024
+ THEN s0 (q subscript code + element length.value)
+ ELSE s0 (q longa subs code) ;
+ s0 (element length.value)
+ FI ;
+ s3 (limit.value - 1, subs index, base addr, subs result) .
+
+check on immediates :
+ IF element length.kind <> immediate value OR
+ limit.kind <> immediate value
+ THEN errorstop (no immediate value)
+ FI .
+
+subs index : REPR param field [first+1].addr .
+
+base addr : REPR param field [first].addr .
+
+subs result : REPR param field [first+4].addr .
+
+first addr :
+ param field [first].addr .
+
+left type :
+ param field [first].type .
+
+second addr :
+ param field [nextparam (first)].addr .
+
+third addr :
+ param field [nextparam(nextparam(first))].addr
+ENDPROC apply ;
+
+PROC push params if necessary (INT CONST first, nr of params, mod nr) :
+ init param push (mod nr) ;
+ field pointer := first ;
+ IF nr of params > 0 THEN push params FI ;
+ push result if there is one .
+
+push params :
+ FOR index FROM 1 UPTO nr of params REP
+ apply p1 (push code, param addr) ;
+ NEXTPARAM field pointer
+ PER .
+
+push code :
+ param field [field pointer].push opn .
+
+param addr :
+ param field [field pointer].addr .
+
+push result if there is one :
+ IF push result necessary
+ THEN push result address (REPR param field [field pointer].addr)
+ FI .
+
+push result necessary :
+ param field [field pointer].push opn.kind <> nil AND
+ is not void bool or undefined (param field [field pointer].type)
+ENDPROC push params if necessary ;
+
+PROC apply p1 (OPN CONST opn, ADDRESS CONST addr) :
+ IF opn.mod nr = q ln THEN generate line number
+ ELIF opn.mod nr = q pproc THEN push module nr
+ ELSE gen p1 instruction
+ FI .
+
+gen p1 instruction :
+ address representation := REPR addr ;
+ SELECT opn.mod nr OF
+ CASE q inc1 : t1 (q inc1 code, address representation)
+ CASE q dec1 : t1 (q dec1 code, address representation)
+ CASE q clear : t1 (q clear code,address representation)
+ CASE q test : test bool object (address representation)
+ CASE q pp : push param (address representation)
+ CASE q ppv : s1 (q ppv code, address representation)
+ CASE q make false : s1 (q make false code, address representation)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+generate line number :
+ IF addr.kind = immediate value THEN mark line (addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+push module nr :
+ IF addr.kind = module nr THEN push param proc (addr.value)
+ ELSE errorstop (no mod nr)
+ FI
+ENDPROC apply p1;
+
+PROC apply p2 (OPN CONST opn, ADDRESS CONST left addr, right addr):
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movim THEN move immediate
+ ELSE gen p2 instruction
+ FI .
+
+gen p2 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q move : t2 (q move code, right repr, left repr)
+ CASE q inc : t2 (q inc code, right repr, left repr)
+ CASE q dec : t2 (q dec code, right repr, left repr)
+ CASE q equ : compare (q equ code, left repr, right repr)
+ CASE q lsequ : compare (q lsequ code, left repr, right repr)
+ CASE q ulseq : compare (q ulseq code, left repr, right repr)
+ CASE q fmove : t2 (q fmove code, right repr, left repr)
+ CASE q flsequ : compare (q flsequ code, left repr, right repr)
+ CASE q tmove : t2 (q tmove code, right repr, left repr)
+ CASE q tequ : compare (q tequ code, left repr, right repr)
+ CASE q compl int : s2 (q compl int code, left repr, right repr)
+ CASE q compl real : s2 (q compl real code, left repr, right repr)
+ CASE q fequ : compare (q fequ code, left repr, right repr)
+ CASE q tlsequ : compare (q tlsequ code, left repr, right repr)
+ CASE q accds : t2 (q access ds code, left repr, right repr)
+ CASE q ref : t2 (q ref code, left repr, right repr)
+ CASE q dimov : s2 (q dimov code, left repr, right repr)
+ CASE q idmov : s2 (q idmov code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+move immediate :
+ IF right addr.kind = immediate value
+ THEN s0 (q esc movim code) ;
+ s1 (right addr.value, left repr)
+ ELSE errorstop (no immediate value)
+ FI
+ENDPROC apply p2;
+
+PROC apply p3 (OPN CONST opn, DTYPE CONST left dtype,
+ ADDRESS CONST left addr, right addr, result addr ):
+ result repr := REPR result addr ;
+ IF opn.mod nr = q pdadd THEN select with dint; LEAVE apply p3
+ ELIF opn.mod nr = q select THEN gen select instruction; LEAVE apply p3 FI ;
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movex THEN gen long move
+ ELIF opn.mod nr = q alias ds THEN alias dataspace
+ ELSE gen p3 instruction
+ FI .
+
+gen long move :
+ IF right addr.kind = immediate value
+ THEN long move (left repr, result repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+alias dataspace :
+ IF right addr.value = immediate value
+ THEN s0 (q alias ds code) ;
+ s2 (right addr.value, result repr, left repr)
+ ELSE errorstop (no immediate value)
+ FI .
+
+gen select instruction :
+ IF right addr.kind = immediate value
+ THEN IF different bases
+ THEN access external (left addr.value, right addr.value)
+ ELSE t1 (q select code, REPR left addr) ;
+ s1 (right addr.value, result repr)
+ FI
+ ELSE errorstop (no immediate value)
+ FI .
+
+select with dint :
+ right repr := REPR right addr ;
+ IF different bases THEN access external packet
+ ELSE simple access
+ FI .
+
+different bases :
+ left addr.kind = p base AND left addr.value <> packet base .
+
+simple access :
+ s3 (q pdadd code, REPR left addr, right repr, result repr) .
+
+access external packet :
+ access external (left addr.value, global address zero) ;
+ s3 (q pdadd code, REPR REF result addr, right repr, result repr) .
+
+gen p3 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q add : int add
+ CASE q sub : int sub
+ CASE q fadd : real add
+ CASE q fsub : real sub
+ CASE q fmult : real mult
+ CASE q fdiv, q real div : real div
+ CASE q esc mult : int mult
+ CASE q esc div, q int div : int div
+ CASE q esc mod : int mod
+ CASE q plus : int real add
+ CASE q minus : int real sub
+ CASE q mult : int real mult
+ CASE q equal, q lessequal : compare (comp code, left repr, right repr)
+ CASE q ppsub : distance between two objects
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+int add : compute (q add code, left repr, right repr, result repr) .
+
+int sub : compute (q sub code, left repr, right repr, result repr) .
+
+real add : compute (q fadd code, left repr, right repr, result repr) .
+
+real sub : compute (q fsub code, left repr, right repr, result repr) .
+
+real mult : compute (q fmult code, left repr, right repr, result repr) .
+
+real div : compute (q fdiv code, left repr, right repr, result repr) .
+
+int mult : s3 (q esc mult code, left repr, right repr, result repr) .
+
+int div : s3 (q esc div code, left repr, right repr, result repr) .
+
+int mod : s3 (q esc mod code, left repr, right repr, result repr) .
+
+int real add :
+ IF left type = int id THEN int add
+ ELSE real add
+ FI .
+
+int real sub :
+ IF left type = int id THEN int sub
+ ELSE real sub
+ FI .
+
+int real mult :
+ IF left type = int id THEN int mult
+ ELSE real mult
+ FI .
+
+comp code :
+ SELECT left type OF
+ CASE int id : IF opn.mod nr = q equal THEN q equ ELSE q lsequ FI
+ CASE real id : IF opn.mod nr = q equal THEN q fequ ELSE q flsequ FI
+ CASE string id : IF opn.mod nr = q equal THEN q tequ ELSE q tlsequ FI
+ OTHERWISE errorstop (type error); q equ
+ ENDSELECT .
+
+left type : CONCR (left dtype) .
+
+distance between two objects :
+ s3 (q ppsub code, left repr, right repr, result repr)
+
+ENDPROC apply p3;
+
+PROC access external (INT CONST old base, offset) :
+ s0 (q penter code + old base) ;
+ t2 (q ref code, offset, result repr) ;
+ s0 (q penter code + packet base)
+ENDPROC access external ;
+
+
+ (***** Modul *****)
+
+BOOL VAR module open ;
+
+.init opn section :
+ module open := FALSE .;
+
+PROC begin module :
+ IF module open THEN errorstop (nested module)
+ ELSE begin modul ;
+ module open := TRUE
+ FI
+ENDPROC begin module ;
+
+PROC end module :
+ IF NOT module open
+ THEN errorstop (module not opened)
+ ELSE end modul ;
+ module open := FALSE
+ FI
+ENDPROC end module ;
+
+TEXT PROC dump (OPN CONST operation) :
+ IF operation.kind = proc op THEN " PROC" + text (operation.mod nr, 5)
+ ELIF operation.kind = eumel 0 THEN " EUMEL0: " + mnemonic (operation)
+ ELSE " undef. Opn"
+ FI
+ENDPROC dump ;
+
+PROC begin modul :
+ EXTERNAL 10073
+ENDPROC begin modul ;
+
+PROC end modul :
+ EXTERNAL 10011
+ENDPROC end modul ;
+
+PROC proc head (INT VAR mod nr, top of stack) :
+ EXTERNAL 10012
+ENDPROC proc head ;
+
+PROC set length (INT CONST top of stack, size) :
+ EXTERNAL 10013
+ENDPROC set length ;
+
+PROC get module nr (INT VAR module nr) :
+ EXTERNAL 10016
+ENDPROC get module nr ;
+
+PROC compute (INT CONST op code, l addr, r addr, result address) :
+ EXTERNAL 10017
+ENDPROC compute ;
+
+PROC compare (INT CONST op code, l addr, r addr) :
+ EXTERNAL 10018
+ENDPROC compare ;
+
+PROC long move (INT CONST to, from, length) :
+ EXTERNAL 10019
+ENDPROC long move ;
+
+PROC call (INT CONST mod nr) :
+ EXTERNAL 10022
+ENDPROC call ;
+
+PROC call param (INT CONST mod nr) :
+ EXTERNAL 10023
+ENDPROC call param ;
+
+PROC push param (INT CONST addr) :
+ EXTERNAL 10024
+ENDPROC push param ;
+
+PROC push param proc (INT CONST mod nr) :
+ EXTERNAL 10025
+ENDPROC push param proc ;
+
+PROC init param push (INT CONST mod nr) :
+ EXTERNAL 10026
+ENDPROC init param push ;
+
+PROC push result address (INT CONST addr) :
+ EXTERNAL 10027
+ENDPROC push result address ;
+
+PROC test bool object (INT CONST addr) :
+ EXTERNAL 10192
+ENDPROC test bool object ;
+
+PROC mark line (INT CONST line number) :
+ EXTERNAL 10030
+ENDPROC mark line ;
+
+PROC s0 (INT CONST op code) :
+ EXTERNAL 10038
+ENDPROC s0 ;
+
+PROC s1 (INT CONST op code, addr) :
+ EXTERNAL 10039
+ENDPROC s1 ;
+
+PROC s2 (INT CONST op code , addr1, addr2) :
+ EXTERNAL 10040
+ENDPROC s2 ;
+
+PROC s3 (INT CONST op code, addr1, addr2, addr3) :
+ EXTERNAL 10041
+ENDPROC s3 ;
+
+PROC t1 (INT CONST op code, addr) :
+ EXTERNAL 10042
+ENDPROC t1 ;
+
+PROC t2 (INT CONST op code, addr1, addr2) :
+ EXTERNAL 10043
+ENDPROC t2 ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 9. Speicherverwaltung 03.06.1986 *)
+(* *)
+(* Ablage der Paketdaten *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR address value;
+
+INT CONST data allocation by coder := 1 ,
+ data allocation by user := 2 ;
+
+LET not initialized = 0 ,
+ wrong mm mode = "Wrong MM Mode" ,
+ define on non global = "Define for GLOB only" ,
+ text too long = "TEXT too long" ;
+
+TEXT VAR const buffer :: point line ;
+
+.reset memory management mode :
+ memory management mode := not initialized . ;
+
+PROC reserve storage (INT CONST size) :
+ IF memory management mode <> data allocation by user
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (address value, size) ;
+ memory management mode := not initialized
+ENDPROC reserve storage ;
+
+PROC allocate variable (ADDRESS VAR addr, INT CONST size) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (addr.value, size) ;
+ addr.kind := global
+ENDPROC allocate variable ;
+
+PROC allocate denoter (ADDRESS VAR addr, INT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate int denoter (addr.value) ;
+ put data word (value, addr.value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, REAL CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate real denoter (addr.value) ;
+ addr.kind := global ;
+ define (addr, value)
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, TEXT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate text denoter (addr.value, (LENGTH value+1) DIV 2 + 2) ;
+ addr.kind := global ;
+ skip heaplink;
+ define (addr, value) ;
+ reset heaplink .
+
+skip heaplink :
+ addr.value INCR 1 .
+
+reset heaplink :
+ addr.value DECR 1
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, DINT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate dint denoter (addr.value, value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate dint denoter (INT VAR addr offset, DINT CONST value) :
+ adjust to an even address if necessary ;
+ put data word (value.low, addr offset) ;
+ allocate int denoter (address value) ;
+ put data word (value.high, address value) .
+
+adjust to an even address if necessary :
+ allocate int denoter (addr offset) ;
+ IF (addr offset AND 1) <> 0 THEN allocate int denoter (addr offset) FI
+ENDPROC allocate dint denoter ;
+
+PROC define (ADDRESS CONST addr, INT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value, addr.value)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, DINT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value.low , addr.value);
+ put data word (value.high, addr.value + 1)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, REAL CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ replace (const buffer, 1, value) ;
+ address value := addr.value ;
+ FOR index FROM 1 UPTO 4 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, TEXT CONST value) :
+ IF addr.kind <> global THEN errorstop (define on non global)
+ ELIF LENGTH value > 255 THEN errorstop (text too long)
+ FI ;
+ address value := addr.value ;
+ const buffer := code (LENGTH value) ;
+ const buffer CAT value ;
+ const buffer CAT ""0"" ;
+ FOR index FROM 1 UPTO LENGTH const buffer DIV 2 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER ;
+ const buffer := point line
+ENDPROC define ;
+
+PROC allocate var (INT VAR addr, INT CONST length) :
+ EXTERNAL 10033
+ENDPROC allocate var ;
+
+PROC allocate int denoter (INT VAR addr) :
+ EXTERNAL 10034
+ENDPROC allocate int denoter ;
+
+PROC allocate real denoter (INT VAR addr) :
+ EXTERNAL 10035
+ENDPROC allocate real denoter ;
+
+PROC allocate text denoter (INT VAR addr, INT CONST length) :
+ EXTERNAL 10036
+ENDPROC allocate text denoter ;
+
+PROC put data word (INT CONST value, INT CONST addr) :
+ EXTERNAL 10037
+ENDPROC put data word ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 28.10.1987 *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR line number, pattern length, begin of packet,
+ last packet entry, indentation;
+
+TEXT VAR bulletin name, type and mode, pattern, buffer, dummy name;
+
+DATASPACE VAR bulletin ds :: nilspace ;
+
+.packet name :
+ cdb text (cdb int(packet link + wordlength) + two word length) .
+
+.packet entry :
+ permanent pointer = 0 OR
+ cdbint (permanent pointer) = permanent packet OR
+ cdbint (permanent pointer + wordlength) = permanent packet .
+
+.within editor :
+ aktueller editor > 0 . ;
+
+TEXT PROC type name (DTYPE CONST type) :
+ type and mode := "" ;
+ IF CONCR (type) = void id THEN type and mode CAT "VOID"
+ ELSE name of type (CONCR (type))
+ FI ;
+ type and mode
+ENDPROC type name ;
+
+TEXT PROC dump (DTYPE CONST type) :
+(* type and mode := "TYPE " ;
+ name of type (CONCR (type)) ;
+ type and mode
+*)
+ type name (type) (* aus Kompatibilitätsgründen zum 1.9.2 Coder / rr *)
+ENDPROC dump ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void id :
+ CASE int id : type and mode CAT "INT"
+ CASE real id : type and mode CAT "REAL"
+ CASE string id : type and mode CAT "TEXT"
+ CASE bool id, bool result id : type and mode CAT "BOOL"
+ CASE dataspace id : type and mode CAT "DATASPACE"
+ CASE row id : type and mode CAT "ROW "
+ CASE struct id : type and mode CAT "STRUCT"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ unsigned arithmetic ;
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+PROC help (TEXT CONST proc name) :
+ prep bulletin ;
+ prep help ;
+ scan (object name) ;
+ next symbol (pattern) ;
+ packet link := end of permanent table ;
+ IF function = 0 THEN standard help
+ ELSE asterisk help
+ FI .
+
+prep help :
+ object name := compress (proc name) ;
+ INT VAR function :: 0 ;
+ INT CONST l :: LENGTH object name ;
+ IF l > 1 AND object name <> "**"
+ THEN IF (object name SUB l) = "*"
+ THEN function INCR 2 ;
+ delete char (object name, l)
+ FI ;
+ IF (object name SUB 1) = "*"
+ THEN function INCR 1 ;
+ delete char (object name, 1)
+ FI ;
+ IF another asterisk THEN wrong function FI
+ FI.
+
+another asterisk :
+ pos (object name, "*") <> 0 .
+
+wrong function :
+ errorstop ("unzulaessige Sternfunktion") .
+
+standard help :
+ to object (pattern) ;
+ IF found THEN display
+ ELSE error stop ("unbekannt: " + proc name)
+ FI .
+
+display :
+ IF NOT packet entry
+ THEN WHILE permanent pointer <> 0 REP
+ put name of packet if necessary ;
+ put specifications (pattern) ;
+ next procedure
+ ENDREP ;
+ show bulletin file
+ FI .
+
+put name of packet if necessary :
+ IF new packet THEN packet link := permanent pointer ;
+ find begin of packet ;
+ writeline (2) ;
+ write packet name
+ FI .
+
+find begin of packet :
+ REP
+ packet link DECR wordlength
+ UNTIL begin of packet found PER .
+
+begin of packet found :
+ cdb int (packet link) = permanent packet .
+
+new packet :
+ permanent pointer < packet link .
+
+asterisk help :
+ hash table pointer := begin of hash table ;
+ pattern length := LENGTH pattern - 1 ;
+ REP
+ list all objects in current hash table chain ;
+ next hash entry
+ UNTIL end of hash table reached ENDREP ;
+ show bulletin file .
+
+list all objects in current hash table chain :
+ nt link := hash table pointer ;
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length) ;
+ IF matching THEN into bulletin FI
+ PER .
+
+matching :
+ INT CONST p :: pos (object name, pattern) ;
+ SELECT function OF
+ CASE 1 : p <> 0 AND p = LENGTH object name - pattern length
+ CASE 2 : p = 1
+ CASE 3 : p <> 0
+ OTHERWISE FALSE
+ ENDSELECT .
+
+into bulletin :
+ object names into bulletin (BOOL PROC not end of chain)
+ENDPROC help ;
+
+BOOL PROC not end of chain :
+ permanent pointer <> 0
+ENDPROC not end of chain ;
+
+PROC write packet name :
+ indentation := 0 ;
+ write line ;
+ write bulletin line ("PACKET ") ;
+ indentation := 7 ;
+ object name := packet name ;
+ write bulletin line (object name) ;
+ write bulletin line (":") ;
+ writeline (2)
+ENDPROC write packet name ;
+
+PROC put specifications (TEXT CONST proc name) :
+ put obj name (proc name) ;
+ to first param ;
+ IF NOT end of params THEN put param list FI ;
+ put result ;
+ writeline .
+
+to first param :
+ param link := permanent pointer + word length ;
+ set end marker if end of list .
+
+put result :
+ INT VAR type;
+ get type and mode (type) ;
+ IF type <> void id THEN type and mode := " --> " ;
+ name of type (type) ;
+ write bulletin line (type and mode)
+ FI
+ENDPROC put specifications ;
+
+PROC put param list :
+ write bulletin line (" (") ;
+ REP
+ INT VAR type, param mode;
+ get type and mode (type) ;
+ param mode := mode ;
+ put type and mode ;
+ maybe param proc ;
+ next pt param ;
+ IF end of params THEN write bulletin line (")") ;
+ LEAVE put param list
+ FI ;
+ write bulletin line (", ") ;
+ PER .
+
+put type and mode :
+ type and mode := "" ;
+ name of type (type) ;
+ type and mode CAT name of mode ;
+ write bulletin line (type and mode) .
+
+name of mode :
+ IF param mode = const THEN " CONST"
+ ELIF param mode = var THEN " VAR"
+ ELSE " PROC"
+ FI .
+
+maybe param proc :
+ IF mode = permanent param proc THEN put virtual params FI .
+
+put virtual params :
+ skip over result type if complex type ;
+ IF NOT end of virtual params THEN put param list FI.
+
+skip over result type if complex type :
+ next pt param .
+
+end of virtual params :
+ end of params
+ENDPROC put param list ;
+
+PROC to packet (TEXT CONST packet name) :
+ to object ( packet name) ;
+ IF found THEN find start of packet objects FI .
+
+find start of packet objects :
+ last packet entry := 0 ;
+ packet link := before first pt entry ;
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word < 0 THEN IF word = permanent packet THEN packet found
+ ELIF word = permanent end THEN return
+ FI
+ FI
+ ENDREP .
+
+packet found :
+ IF cdb int (packet link + wordlength) = nt link
+ THEN last packet entry := packet link FI .
+
+return :
+ IF last packet entry <> 0 THEN found := TRUE ;
+ packet link := last packet entry
+ ELSE found := FALSE
+ FI ;
+ LEAVE to packet
+ENDPROC to packet ;
+
+PROC next packet :
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word = permanent packet THEN true return
+ ELIF end of permanents THEN false return
+ FI ;
+ ENDREP .
+
+true return :
+ found := TRUE ;
+ LEAVE next packet .
+
+false return :
+ found := FALSE ;
+ LEAVE next packet .
+
+end of permanents :
+ word = permanent end OR packet link > end of permanent table
+ENDPROC next packet ;
+
+PROC prep bulletin :
+ forget (bulletin ds) ;
+ bulletin ds := nilspace ;
+ bulletin file := sequential file (output, bulletin ds) ;
+ line number := 0 ;
+ buffer := ""
+ENDPROC prep bulletin ;
+
+PROC show bulletin file :
+ IF within editor THEN ueberschrift neu FI ;
+ DATASPACE VAR local ds :: bulletin ds ;
+ FILE VAR local file :: sequential file (modify, local ds) ;
+ show (local file) ;
+ forget (local ds)
+ENDPROC show bulletin file ;
+
+PROC write bulletin line (TEXT CONST line) :
+ IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ;
+ buffer CAT line
+ENDPROC write bulletin line ;
+
+PROC writeline :
+ write (bulletin file, buffer) ;
+ line (bulletin file) ;
+ line number INCR 1 ;
+ cout (line number) ;
+ buffer := indentation * " "
+ENDPROC writeline ;
+
+PROC writeline (INT CONST times) :
+ IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
+ writeline
+ ELSE index := times
+ FI ;
+ line (bulletin file, index) ;
+ line number INCR index;
+ indentation := 0 ;
+ cout (line number)
+ENDPROC writeline ;
+
+PROC bulletin (TEXT CONST packet name) :
+ prep bulletin ;
+ scan (packet name) ;
+ next symbol (pattern) ;
+ to packet (pattern) ;
+ IF found THEN list packet ;
+ show bulletin file
+ ELSE error stop (packet name + " ist kein Paketname")
+ FI .
+
+ENDPROC bulletin ;
+
+PROC list packet :
+ begin of packet := packet link + word length ;
+ write packet name ;
+ find end of packet ;
+ run through nametab and list all packet objects .
+
+find end of packet :
+ last packet entry := begin of packet ;
+ REP
+ last packet entry INCR wordlength ;
+ word := cdb int (last packet entry) ;
+ UNTIL end of packet entries PER .
+
+end of packet entries :
+ word = permanent packet OR word = permanent end .
+
+run through nametab and list all packet objects :
+ hashtable pointer := begin of hashtable ;
+ REP
+ nt link := hashtable pointer ;
+ list objects of current packet in this chain ;
+ next hash entry
+ UNTIL end of hashtable reached ENDREP .
+
+list objects of current packet in this chain :
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ put objects of this name
+ PER .
+
+put objects of this name :
+ IF there is an entry THEN into bulletin FI .
+
+there is an entry :
+ NOT packet entry AND
+ there is at least one object of this name in the current packet .
+
+there is at least one object of this name in the current packet :
+ REP
+ IF permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ THEN LEAVE there is at least one object of this name
+ in the current packet WITH TRUE FI ;
+ next procedure
+ UNTIL permanent pointer = 0 PER ;
+ FALSE .
+
+into bulletin :
+ object name := cdb text (nt link + two word length) ;
+ object names into bulletin (BOOL PROC within packet)
+ENDPROC list packet ;
+
+BOOL PROC within packet :
+ permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ENDPROC within packet ;
+
+PROC object names into bulletin (BOOL PROC link ok) :
+ scan (object name) ;
+ next symbol (dummy name, mode) ;
+ IF type definition THEN put type definition
+ ELSE put object definitions
+ FI .
+
+type definition :
+ mode = bold AND no params .
+
+no params :
+ cdb int (permanent pointer + word length) >= permanent type .
+
+put type definition :
+ put obj name (object name) ;
+ write bulletin line ("TYPE ") ;
+ writeline (1) .
+
+put object definitions :
+ WHILE link ok REP
+ put specifications (object name) ;
+ next procedure
+ ENDREP
+ENDPROC object names into bulletin ;
+
+PROC bulletin :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ list packet ;
+ write line (4) ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC bulletin ;
+
+PROC put obj name (TEXT CONST name) :
+ buffer := " " ;
+ bulletin name := point line ;
+ change (bulletin name, 1, end of line or name, name) ;
+ buffer CAT bulletin name ;
+ indentation := LENGTH buffer + 1 .
+
+end of line or name :
+ min (LENGTH name, LENGTH bulletin name)
+ENDPROC put obj name ;
+
+PROC packets :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ object name := packet name ;
+ put obj name (object name) ;
+ write line ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC packets ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 11. ELAN Run-Interface 04.08.1986 *)
+(* *)
+(* Uebersetzen von ELAN-Programmen *)
+(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *)
+(* *)
+(**************************************************************************)
+
+
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ warning option := FALSE ,
+ listing enabled := FALSE ;
+
+FILE VAR listing file ;
+
+TEXT VAR listing file name := "" ;
+
+
+PROC run (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, no ins)
+END PROC run;
+
+PROC run :
+ run (last param)
+ENDPROC run ;
+
+PROC run again :
+ IF run again mod nr <> 0
+ THEN elan (run again mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+ ELSE errorstop ("'run again' nicht moeglich")
+ FI
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, ins)
+ENDPROC insert ;
+
+PROC insert :
+ insert (last param)
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+ FILE VAR source := sequential file (modify, file name) ;
+ IF listing enabled
+ THEN open listing file
+ FI ;
+
+ disable stop ;
+ no do again ;
+ elan (compile file mode, source, "" , run again mod nr,
+ insert option, list option, check option, sermon) ;
+
+ IF anything noted AND command dialogue
+ THEN ignore halt during compiling ;
+ note edit (source) ;
+ last param (file name) ;
+ errorstop ("")
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+open listing file :
+ listing file := sequential file (output, listing file name) ;
+ max line length (listing file, 130)
+
+ENDPROC run elan ;
+(*
+PROC out text (TEXT CONST text, INT CONST out type) :
+ INTERNAL 257 ;
+ IF online
+ THEN out (text)
+ FI ;
+ IF out type = error message OR (warning option AND out type = warning message)
+ THEN note (text) ;
+ FI ;
+ IF listing enabled
+ THEN write (listing file, text)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+ INTERNAL 258 ;
+ IF online
+ THEN out (""13""10"")
+ FI ;
+ IF out type = error message
+ OR (warning option AND out type = warning message)
+ THEN note line
+ ELIF listing enabled
+ THEN line (listing file)
+ FI
+ENDPROC out line ;
+*)
+PROC prot (TEXT CONST file name) :
+ list option := TRUE ;
+ listing file name := file name ;
+ listing enabled := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE ;
+ listing enabled := FALSE
+ENDPROC prot off ;
+
+BOOL PROC prot :
+ list option
+ENDPROC prot ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+BOOL PROC check :
+ check option
+ENDPROC check ;
+
+PROC warnings on :
+ warning option := TRUE
+ENDPROC warnings on ;
+
+PROC warnings off :
+ warning option := FALSE
+ENDPROC warnings off ;
+
+BOOL PROC warnings :
+ warning option
+ENDPROC warnings ;
+
+ENDPACKET eumel coder ;
+
+PACKET dint2 DEFINES dint type :
+
+INT VAR dummy ;
+DTYPE VAR d ;
+identify ("DINT", dummy, dummy, d) ;
+
+DTYPE CONST dint type := d
+
+ENDPACKET dint2 ;
+
diff --git a/system/multiuser/1.7.5/source-disk b/system/multiuser/1.7.5/source-disk
new file mode 100644
index 0000000..e24344a
--- /dev/null
+++ b/system/multiuser/1.7.5/source-disk
@@ -0,0 +1,2 @@
+175_src/source-code-1.7.5m_0.img
+175_src/source-code-1.7.5m_1.img
diff --git a/system/multiuser/1.7.5/src/archive b/system/multiuser/1.7.5/src/archive
new file mode 100644
index 0000000..8027b29
--- /dev/null
+++ b/system/multiuser/1.7.5/src/archive
@@ -0,0 +1,92 @@
+(* ------------------- VERSION 14 06.03.86 ------------------- *)
+PACKET archive DEFINES
+
+ archive ,
+ clear ,
+ release ,
+ format ,
+ check ,
+ reserve :
+
+
+LET clear code = 18 ,
+ reserve code = 19 ,
+ free code = 20 ,
+ check read code = 22 ,
+ format code = 23 ;
+
+
+TASK PROC archive :
+
+ task ("ARCHIVE")
+
+ENDPROC archive ;
+
+PROC archive (TEXT CONST archive name, TASK CONST task) :
+
+ call (reserve code, archive name, task)
+
+ENDPROC archive ;
+
+PROC reserve (TEXT CONST message, TASK CONST task) :
+
+ call (reserve code, message, task)
+
+END PROC reserve;
+
+PROC reserve (TASK CONST task) :
+
+ call(reserve code, "", task)
+
+END PROC reserve;
+
+PROC archive (TEXT CONST archive name, INT CONST station) :
+
+ call (reserve code, archive name, station/ "ARCHIVE")
+
+ENDPROC archive ;
+
+PROC archive (TEXT CONST archive name):
+
+ call (reserve code, archive name, archive)
+
+ENDPROC archive ;
+
+PROC release (TASK CONST task) :
+
+ call (free code, "", task)
+
+ENDPROC release ;
+
+PROC clear (TASK CONST task) :
+
+ call (clear code, "", task)
+
+ENDPROC clear ;
+
+PROC format (TASK CONST task) :
+
+ format (0, task)
+
+ENDPROC format ;
+
+PROC format (INT CONST code, TASK CONST task) :
+
+ call (format code , text (code), task)
+
+ENDPROC format ;
+
+PROC check (TEXT CONST file name, TASK CONST task) :
+
+ call (check read code, file name, task)
+
+ENDPROC check ;
+
+PROC check (THESAURUS CONST nameset, TASK CONST task) :
+
+ do (PROC (TEXT CONST, TASK CONST) check, nameset, task)
+
+ENDPROC check ;
+
+ENDPACKET archive ;
+
diff --git a/system/multiuser/1.7.5/src/archive manager b/system/multiuser/1.7.5/src/archive manager
new file mode 100644
index 0000000..c37d2e2
--- /dev/null
+++ b/system/multiuser/1.7.5/src/archive manager
@@ -0,0 +1,670 @@
+(* ------------------- VERSION 10 vom 17.04.86 ------------------- *)
+PACKET archive manager DEFINES (* Autor: J.Liedtke*)
+
+ archive manager ,
+ provide channel :
+
+
+
+LET std archive channel = 31 ,
+
+ ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ second phase ack = 5 ,
+ false code = 6 ,
+
+ fetch code = 11 ,
+ save code = 12 ,
+ exists code = 13 ,
+ erase code = 14 ,
+ list code = 15 ,
+ all code = 17 ,
+ clear code = 18 ,
+ reserve code = 19 ,
+ free code = 20 ,
+ check read code = 22 ,
+ format code = 23 ,
+
+ read error = 92 ,
+
+ max files = 200 ,
+
+ start of volume = 1000 ,
+ end of volume = 1 ,
+ file header = 3 ,
+
+ number of header blocks = 2 ,
+
+ quote = """" ,
+ dummy name = "-" ,
+ dummy date = " " ,
+
+
+ HEADER = STRUCT (TEXT name, date, INT type, TEXT password) ;
+
+
+BOUND STRUCT (TEXT name, pass) VAR msg ;
+
+INT VAR archive channel := std archive channel ;
+
+TASK VAR archive owner := niltask ,
+ order task ;
+TEXT VAR archive name := "" , write stamp ;
+
+REAL VAR last access time := 0.0 ;
+
+BOOL VAR was already write access ;
+
+
+DATASPACE VAR header space := nilspace ;
+BOUND HEADER VAR header ;
+
+TEXT VAR file name := "" ;
+
+LET invalid = 0 ,
+ read only = 1 ,
+ valid = 2 ;
+
+LET accept read errors = TRUE ,
+ ignore read errors = FALSE ;
+
+
+INT VAR directory state := invalid ;
+
+THESAURUS VAR directory ;
+INT VAR dir index ;
+
+INT VAR archive size ;
+
+INT VAR end of volume block ;
+ROW max files INT VAR header block ;
+ROW max files TEXT VAR header date ;
+
+
+
+PROC provide channel (INT CONST channel) :
+
+ archive channel := channel
+
+ENDPROC provide channel ;
+
+PROC archive manager :
+
+ archive manager (archive channel)
+
+ENDPROC archive manager ;
+
+PROC archive manager (INT CONST channel) :
+
+ archive channel := channel ;
+ task password ("-") ;
+ global manager
+ (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) archive manager)
+
+ENDPROC archive manager ;
+
+PROC archive manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST task) :
+
+
+ enable stop ;
+ order task := task ;
+ msg := ds ;
+ SELECT order OF
+ CASE fetch code : fetch file
+ CASE save code : save file
+ CASE exists code : exists file
+ CASE erase code : erase file
+ CASE list code : list (ds); manager ok (ds)
+ CASE all code : deliver directory
+ CASE clear code,
+ format code : clear or format
+ CASE reserve code : reserve
+ CASE free code : free
+ CASE check read code : check
+ OTHERWISE errorstop (name (myself) + ": unbekannter Auftrag")
+ ENDSELECT .
+
+deliver directory :
+ access archive ;
+ BOUND THESAURUS VAR all names := ds ;
+ all names := directory ;
+ WHILE all names CONTAINS dummy name REP
+ delete (all names, dummy name, dir index)
+ PER ;
+ manager ok (ds) .
+
+clear or format :
+ IF NOT (order task = archive owner)
+ THEN errorstop ("Archiv nicht angemeldet")
+ ELIF phase = 1
+ THEN ask for erase all
+ ELSE directory state := invalid ;
+ IF order <> clear code
+ THEN format archive (specification) ;
+ archive size := archive blocks
+ FI ;
+ rewind ;
+ write header (archive name, text (clock(1),13,1), start of volume);
+ write end of volume ;
+ manager ok (ds)
+ FI .
+
+ask for erase all :
+ IF order = format code AND specification > 3
+ THEN errorstop ("ungueltiger Format-Code")
+ FI ;
+ look at volume header ;
+ IF header.name <> ""
+ THEN IF order = clear code
+ THEN manager question ("Archiv """+header.name+""" loeschen", order task)
+ ELSE manager question ("Archiv """+header.name+""" formatieren", order task)
+ FI
+ ELSE IF order = clear code
+ THEN manager question ("Archiv initialisieren", order task)
+ ELSE manager question ("Archiv formatieren", order task)
+ FI
+ FI .
+
+specification :
+ int (msg.name) .
+
+reserve :
+ IF reserve or free permitted
+ THEN continue archive channel;
+ disable stop ;
+ directory state := invalid ;
+ archive owner := order task ;
+ archive name := msg.name ;
+ manager ok (ds)
+ ELSE errorstop ("Archiv wird von Task """+name(archive owner)+""" benutzt")
+ FI .
+
+continue archive channel :
+ continue channel (archive channel) .
+
+free :
+ IF reserve or free permitted
+ THEN archive owner := niltask ;
+ break (quiet) ;
+ manager ok (ds)
+ ELSE manager message ("Archiv nicht angemeldet", order task)
+ FI.
+
+reserve or free permitted :
+ order task = archive owner OR last access more than five minutes ago
+ OR archive owner = niltask OR NOT
+ (exists (archive owner) OR station (archive owner) <> station (myself)) .
+
+last access more than five minutes ago :
+ abs (last access time - clock (1)) > 300.0 .
+
+fetch file :
+ access archive ;
+ access file (msg.name) ;
+ IF no read error remarked
+ THEN disable stop ;
+ fetch (ds, accept read errors) ;
+ IF read error occurred
+ THEN remark read error
+ FI ;
+ enable stop
+ ELSE fetch (ds, ignore read errors)
+ FI ;
+ manager ok (ds) .
+
+no read error remarked :
+ pos (file name, " mit Lesefehler") = 0 .
+
+read error occurred :
+ is error AND error code = read error .
+
+remark read error :
+ dir index := link (directory, file name) ;
+ REP
+ file name CAT " mit Lesefehler" ;
+ UNTIL NOT (directory CONTAINS file name) PER ;
+ IF LENGTH file name < 100
+ THEN rename (directory, dir index, file name)
+ FI .
+
+save file :
+ IF phase = 1
+ THEN access archive ;
+ access file (msg.name) ;
+ IF file in directory
+ THEN manager question (""""+file name +""" ueberschreiben", order task)
+ ELSE send (order task, second phase ack, ds)
+ FI
+ ELSE access archive ;
+ access file (file name) ;
+ erase ;
+ save (ds) ;
+ forget (ds) ;
+ ds := nilspace ;
+ manager ok (ds)
+ FI .
+
+exists file :
+ access archive ;
+ access file (msg.name) ;
+ IF file in directory
+ THEN manager ok (ds)
+ ELSE send (order task, false code, ds)
+ FI .
+
+erase file :
+ access archive ;
+ access file (msg.name) ;
+ IF file in directory
+ THEN IF phase = 1
+ THEN manager question (""""+file name+""" loeschen", order task)
+ ELSE erase ; manager ok (ds)
+ FI
+ ELSE manager message ("gibt es nicht", order task)
+ FI .
+
+check :
+ access archive ;
+ access file (msg.name) ;
+ IF file in directory
+ THEN position to file ;
+ disable stop ;
+ check read ;
+ IF is error
+ THEN clear error; error ("fehlerhaft")
+ ELSE last access time := clock (1) ;
+ manager message ("""" + file name + """ ohne Fehler gelesen", order task)
+ FI
+ ELSE error ("gibt es nicht")
+ FI .
+
+file in directory : dir index > 0 .
+
+position to file :
+ seek (header block (dir index) + number of header blocks) .
+
+ENDPROC archive manager ;
+
+PROC manager ok (DATASPACE VAR ds) :
+
+ send (order task, ack, ds) ;
+ last access time := clock (1) .
+
+ENDPROC manager ok ;
+
+PROC access archive :
+
+ IF NOT (order task = archive owner)
+ THEN errorstop ("Archiv nicht angemeldet")
+ ELIF directory state = invalid
+ THEN open archive
+ ELIF last access more than two seconds ago
+ THEN check volume name ;
+ new open if somebody changed medium
+ FI .
+
+last access more than two seconds ago :
+ abs (clock (1) - last access time) > 2.0 .
+
+new open if somebody changed medium :
+ IF header.date <> write stamp
+ THEN directory state := invalid ;
+ access archive
+ FI .
+
+open archive :
+ directory state := invalid ;
+ check volume name ;
+ write stamp := header.date ;
+ was already write access := FALSE ;
+ read directory ;
+ make directory valid if no read errors occurred .
+
+read directory :
+ directory := empty thesaurus ;
+ rewind ;
+ get next header ;
+ WHILE header.type = file header REP
+ IF directory CONTAINS header.name
+ THEN rename (directory, header.name, dummy name)
+ FI ;
+ insert (directory, header.name, dir index) ;
+ header block (dir index) := end of volume block ;
+ header date (dir index) := header.date ;
+ get next header ;
+ PER .
+
+make directory valid if no read errors occurred :
+ IF directory state = invalid
+ THEN directory state := valid
+ FI .
+
+ENDPROC access archive ;
+
+PROC access file (TEXT CONST name) :
+
+ file name := name ;
+ dir index := link (directory, file name) .
+
+ENDPROC access file ;
+
+
+PROC check volume name :
+
+ disable stop ;
+ archive size := archive blocks ;
+ read volume header ;
+ IF header.type <> start of volume
+ THEN simulate header (start of volume, "?????")
+ ELIF header.name <> archive name
+ THEN errorstop ("Archiv heisst """ + header.name + """")
+ FI .
+
+read volume header :
+ rewind ;
+ read header ;
+ IF is error AND error code = read error
+ THEN clear error ;
+ simulate header (start of volume, "?????")
+ FI .
+
+ENDPROC check volume name ;
+
+PROC get next header :
+
+ disable stop ;
+ skip dataspace ;
+ IF NOT is error
+ THEN read header
+ FI ;
+ IF is error
+ THEN clear error ;
+ directory state := read only ;
+ search header
+ FI ;
+ end of volume block := block number - number of header blocks .
+
+search header :
+ INT VAR ds pages ;
+ search dataspace (ds pages) ;
+ IF ds pages < 0
+ THEN simulate header (end of volume, "")
+ ELIF NOT is header space
+ THEN simulate header (file header, "????? " + text (block number))
+ FI .
+
+is header space :
+ IF ds pages <> 1
+ THEN FALSE
+ ELSE remember position ;
+ read header ;
+ IF read error occurred
+ THEN clear error; back to old position; FALSE
+ ELIF header format looks ok
+ THEN TRUE
+ ELSE back to old position ; FALSE
+ FI
+ FI .
+
+read error occurred :
+ is error CAND error code = read error .
+
+header format looks ok :
+ header.type = file header OR header.type = end of volume .
+
+remember position :
+ INT CONST old block nr := block number .
+
+back to old position :
+ seek (old block nr) .
+
+ENDPROC get next header ;
+
+PROC fetch (DATASPACE VAR ds, BOOL CONST error accept):
+
+ enable stop ;
+ IF file name <> dummy name
+ THEN fetch from archive
+ ELSE error ("Name unzulaessig")
+ FI .
+
+fetch from archive :
+ IF file in directory
+ THEN position to file ;
+ read (ds, 30000, error accept)
+ ELIF directory state = read only
+ THEN error ("gibt es nicht (oder Lesefehler)")
+ ELSE error ("gibt es nicht")
+ FI .
+
+position to file :
+ seek (header block (dir index) + number of header blocks) .
+
+file in directory : dir index > 0 .
+
+ENDPROC fetch ;
+
+PROC erase :
+
+ IF directory state = read only
+ THEN errorstop ("'save'/'erase' wegen Lesefehler verboten")
+ ELSE update write stamp if first write access ;
+ erase archive
+ FI .
+
+update write stamp if first write access :
+ IF NOT was already write access
+ THEN rewind ;
+ write stamp := text (clock (1), 13, 1) ;
+ write header (archive name, write stamp, start of volume) ;
+ was already write access := TRUE
+ FI .
+
+erase archive :
+ IF file in directory
+ THEN IF is last file of archive
+ THEN cut off all erased files
+ ELSE rename to dummy
+ FI
+ FI .
+
+file in directory : dir index > 0 .
+
+is last file of archive : dir index = highest entry (directory) .
+
+cut off all erased files :
+ directory state := invalid ;
+ REP
+ delete (directory, dir index) ;
+ dir index DECR 1
+ UNTIL dir index = 0 COR name (directory, dir index) <> dummy name PER ;
+ behind last valid file ;
+ write end of volume ;
+ directory state := valid .
+
+behind last valid file :
+ seek (header block (dir index + 1)) ;
+ end of volume block := block number .
+
+rename to dummy :
+ directory state := invalid ;
+ to file header ;
+ read header ;
+ to file header ;
+ header.name := dummy name ;
+ header.date := dummy date ;
+ write (header space) ;
+ rename (directory, file name, dummy name) ;
+ header date (dir index) := dummy date ;
+ directory state := valid .
+
+to file header :
+ seek (header block (dir index)) .
+
+ENDPROC erase ;
+
+PROC save (DATASPACE VAR ds) :
+
+ IF file name <> dummy name
+ THEN save to archive
+ ELSE error ("Name unzulaessig")
+ FI .
+
+save to archive :
+ IF file too large OR highest entry (directory) >= max files
+ THEN error ( "kann nicht geschrieben werden (Archiv voll)")
+ ELSE write new file
+ FI .
+
+file too large :
+ end of volume block + ds pages (ds) + 5 > archive size .
+
+write new file :
+ seek (end of volume block) ;
+ disable stop ;
+ write file (ds) ;
+ IF is error
+ THEN seek (end of volume block)
+ ELSE insert (directory, file name, dir index) ;
+ remember begin of header block ;
+ remember date
+ FI ;
+ write end of volume .
+
+remember begin of header block :
+ header block (dir index) := end of volume block .
+
+remember date :
+ header date (dir index) := date .
+
+ENDPROC save ;
+
+PROC write file (DATASPACE CONST ds) :
+
+ enable stop ;
+ write header (file name, date, file header) ;
+ write (ds)
+
+ENDPROC write file ;
+
+PROC write end of volume :
+
+ disable stop ;
+ end of volume block := block number ;
+ write header ("", "", end of volume)
+
+ENDPROC write end of volume ;
+
+PROC write header (TEXT CONST name, date, INT CONST header type) :
+
+ forget (header space) ;
+ header space := nilspace ;
+ header := header space ;
+
+ header.name := subtext (name,1,100) ;
+ header.date := date ;
+ header.type := header type ;
+
+ write (header space)
+
+ENDPROC write header ;
+
+PROC read header :
+
+ IF archive size > 0
+ THEN forget (header space) ;
+ header space := nilspace ;
+ read (header space, 1, accept read errors) ;
+ header := header space
+ ELSE errorstop ("Lesen unmoeglich (Archiv)")
+ FI .
+
+ENDPROC read header ;
+
+PROC simulate header (INT CONST type, TEXT CONST name) :
+
+ forget (header space) ;
+ header space := nilspace ;
+ header := header space ;
+ header.name := name ;
+ header.date := "??.??.??" ;
+ header.type := type ;
+ header.password := ""
+
+ENDPROC simulate header ;
+
+PROC look at volume header :
+
+ rewind ;
+ archive size := archive blocks ;
+ forget (header space) ;
+ header space := nilspace ;
+ INT VAR return code ;
+ read block (header space, 1, 1, return code) ;
+ header := header space ;
+ disable stop ;
+ IF return code <> 0 OR
+ LENGTH header.name < 0 OR LENGTH header.name > 100 OR is error
+ THEN header.name := "" ;
+ clear error
+ FI
+
+ENDPROC look at volume header ;
+
+PROC list (DATASPACE VAR ds) :
+
+ access archive ;
+ open list file ;
+ INT VAR file number := 0 ;
+ get (directory, file name, file number) ;
+ WHILE file number > 0 REP
+ generate list line ;
+ get (directory, file name, file number)
+ PER ;
+ IF directory state = read only
+ THEN putline (list file, "Lesefehler: Evtl. fehlen Eintraege")
+ FI ;
+ write list head .
+
+open list file :
+ forget (ds) ;
+ ds := nilspace ;
+ FILE VAR list file := sequential file (output, ds) ;
+ putline (list file, "") .
+
+generate list line :
+ write (list file, header date (file number)) ;
+ write (list file, text (file blocks DIV 2, 5)) ;
+ write (list file, " K ") ;
+ IF file name = dummy name
+ THEN write (list file, dummy name)
+ ELSE write (list file, quote) ;
+ write (list file, file name) ;
+ write (list file, quote)
+ FI ;
+ line (list file) .
+
+file blocks :
+ IF file number < highest entry (directory)
+ THEN header block (file number+1) - header block (file number)
+ ELSE end of volume block - header block (file number)
+ FI .
+
+write list head : (* wk 22.08.85 *)
+ headline (list file, archive name +
+ " (" + used + " K belegt von " + text (archive size DIV 2) + " K)") .
+
+used : text ((end of volume block + 3) DIV 2) .
+
+ENDPROC list ;
+
+PROC error (TEXT CONST error msg) :
+
+ errorstop ("""" + file name + """ " + error msg)
+
+ENDPROC error ;
+
+ENDPACKET archive manager ;
+
diff --git a/system/multiuser/1.7.5/src/basic archive b/system/multiuser/1.7.5/src/basic archive
new file mode 100644
index 0000000..8235607
--- /dev/null
+++ b/system/multiuser/1.7.5/src/basic archive
@@ -0,0 +1,401 @@
+(* ------------------- VERSION 11 06.03.86 ------------------- *)
+PACKET basic archive DEFINES
+
+ archive blocks ,
+ block number ,
+ check read ,
+ format archive ,
+ read block ,
+ read ,
+ rewind ,
+ search dataspace ,
+ seek ,
+ size ,
+ skip dataspace ,
+ write block ,
+ write :
+
+INT VAR blocknr := 0 ,
+ rerun := 0 ,
+ page := -1 ,
+ bit word := 1 ,
+ unreadable sequence length := 0 ;
+INT CONST all ones :=-1 ;
+
+
+DATASPACE VAR label ds ;
+
+LET write normal = 0 ,
+ archive version = 1 ,
+ first page stored = 2 ,
+ dr size = 3 ,
+ first bit word = 4 ,
+(* write deleted data mark = 64 , *)
+ inconsistent = 90 ,
+ read error = 92 ,
+ label size = 131 ;
+
+BOUND STRUCT (ALIGN dummy for page1,
+ (* Page 2 begins: *)
+ ROW label size INT lab) VAR label;
+
+
+INT PROC block number :
+ block nr
+ENDPROC block number ;
+
+PROC seek (INT CONST block) :
+ block nr := block
+ENDPROC seek ;
+
+PROC rewind :
+ forget (label ds);
+ label ds := nilspace;
+ label := label ds;
+ block nr := 0;
+ rerun := session
+END PROC rewind;
+
+PROC skip dataspace:
+ check rerun;
+ get label;
+ IF is error
+ THEN
+ ELIF olivetti
+ THEN block nr INCR label.lab (dr size+1)
+ ELSE block nr INCR label.lab (dr size)
+ FI
+END PROC skip dataspace;
+
+PROC read (DATASPACE VAR ds):
+ read (ds, 30000, FALSE)
+ENDPROC read ;
+
+PROC read (DATASPACE VAR ds, INT CONST max pages, BOOL CONST error accept) :
+ enable stop ;
+ check rerun;
+ get label;
+ init next page;
+ INT VAR i ;
+ FOR i FROM 1 UPTO max pages REP
+ next page;
+ IF no further page THEN LEAVE read FI;
+ check storage ;
+ check rerun ;
+ read block ;
+ block nr INCR 1;
+ PER .
+
+read block :
+ disable stop ;
+ get external block (ds, page, block nr) ;
+ ignore read error if no errors accepted ;
+ enable stop .
+
+ignore read error if no errors accepted :
+ IF is error CAND error code = read error CAND NOT error accept
+ THEN clear error
+ FI .
+
+check storage :
+ INT VAR size, used ;
+ storage (size, used) ;
+ IF used > size
+ THEN forget (ds) ;
+ ds := nilspace ;
+ errorstop ("Speicherengpass") ;
+ LEAVE read
+ FI .
+
+check rerun :
+ IF rerun <> session
+ THEN errorstop ("RERUN beim Archiv-Zugriff") ;
+ LEAVE read
+ FI .
+
+END PROC read;
+
+PROC check read :
+
+ enable stop ;
+ get label ;
+ INT VAR pages, i;
+ IF olivetti
+ THEN pages := label.lab (dr size+1)
+ ELSE pages := label.lab (dr size)
+ FI ;
+ FOR i FROM 1 UPTO pages REP
+ get external block (label ds, 2, block nr) ;
+ block nr INCR 1
+ PER .
+
+ENDPROC check read ;
+
+PROC write (DATASPACE CONST ds):
+ enable stop ;
+ check rerun;
+ INT VAR label block nr := block nr;
+ block nr INCR 1;init label;
+ INT VAR page := -1,i;
+ FOR i FROM 1 UPTO ds pages (ds) REP
+ check rerun ;
+ page := next ds page(ds,page);
+ put external block (ds, page, block nr) ;
+ reset archive bit;
+ label.lab(dr size) INCR 1;
+ block nr INCR 1
+ PER;
+ put label.
+
+
+ init label:
+ label.lab(archive version) := 0 ;
+ label.lab(first page stored) := 0 ;
+ label.lab(dr size) := 0;
+ INT VAR j;
+ FOR j FROM first bit word UPTO label size REP
+ label.lab (j) := all ones
+ PER.
+
+ put label:
+ put external block (label ds, 2, label block nr).
+
+ reset archive bit:
+ reset bit (label.lab (page DIV 16+first bit word), page MOD 16).
+
+END PROC write;
+
+PROC get label:
+
+ enable stop ;
+ get external block (label ds, 2, block nr) ;
+ block nr INCR 1;
+ check label.
+
+check label:
+ IF may be z80 format label OR may be old olivetti format label
+ THEN
+ ELSE errorstop (inconsistent, "Archiv inkonsistent")
+ FI.
+
+may be z80 format label :
+ z80 archive AND label.lab(dr size) > 0 .
+
+may be old olivetti format label :
+ olivetti AND label.lab(first page stored)=0 AND label.lab(dr size+1) > 0 .
+
+END PROC get label;
+
+PROC next page:
+ IF z80 archive
+ THEN
+ WHILE labelbits = all ones REP
+ bitword INCR 1;
+ IF bitword >= label size THEN
+ no further page := true; LEAVE next page FI
+ PER;
+ INT VAR p := lowest reset (labelbits);
+ set bit (labelbits, p);
+ page := 16*(bitword-first bit word)+p
+ ELSE
+ WHILE oli bits = 0 REP
+ bitword INCR 1;
+ IF bitword >= labelsize-64 THEN
+ no further page := true; LEAVE next page FI
+ PER;
+ p := lowest set (oli bits);
+ reset bit (olibits, p);
+ page := 16*(bitword-firstbitword)+p;
+ FI.
+
+ label bits : label.lab (bitword).
+ oli bits : label.lab (bitword+1).
+
+END PROC next page;
+.
+olivetti : label.lab (archive version) = -1.
+
+z80 archive : label.lab (archive version) = 0.
+
+init next page:
+ BOOL VAR no further page := false;
+ bitword := first bit word.
+
+check rerun :
+ IF rerun <> session
+ THEN errorstop ("RERUN beim Archiv-Zugriff")
+ FI .
+
+PROC get external block (DATASPACE VAR ds, INT CONST page,
+ INT CONST block nr):
+
+ INT VAR error ;
+ read block (ds, page, block nr, error) ;
+ SELECT error OF
+ CASE 0: read succeeded
+ CASE 1: error stop ("Lesen unmoeglich (Archiv)")
+ CASE 2: read failed
+ CASE 3: error stop ("Archiv-Ueberlauf")
+ OTHERWISE error stop ("??? (Archiv)")
+ END SELECT .
+
+read succeeded :
+ unreadable sequence length := 0 .
+
+read failed :
+ unreadable sequence length INCR 1 ;
+ IF unreadable sequence length >= 30
+ THEN errorstop ("30 unlesbare Bloecke hintereinander")
+ ELSE error stop (read error, "Lesefehler (Archiv)")
+ FI .
+
+END PROC get external block;
+
+PROC put external block (DATASPACE CONST ds, INT CONST page,
+ INT CONST block nr):
+ INT VAR error;
+ write block (ds, page, write normal, block nr, error) ;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Schreiben unmoeglich (Archiv)")
+ CASE 2: error stop ("Schreibfehler (Archiv)")
+ CASE 3: error stop ("Archiv-Ueberlauf")
+ OTHERWISE error stop ("??? (Archiv)")
+ END SELECT .
+
+END PROC put external block;
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code) :
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, 0, block no, return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST mode,
+ INT CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, mode * 256, block no, return code) .
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+INT PROC size (INT CONST key) :
+
+ INT VAR return code ;
+ control (5, key, 0, return code) ;
+ return code .
+
+ENDPROC size ;
+
+INT PROC archive blocks :
+ size (0)
+ENDPROC archive blocks ;
+
+PROC search dataspace (INT VAR ds pages) :
+
+ disable stop ;
+ ds pages := -1 ;
+ INT CONST last block := archive blocks ;
+
+ WHILE block nr < last block REP
+ IF block is dataspace label
+ THEN ds pages := pages counted ;
+ LEAVE search dataspace
+ FI ;
+ block nr INCR 1
+ UNTIL is error PER .
+
+block is dataspace label :
+ look at label block ;
+ IF is error
+ THEN IF error code = read error OR error code = inconsistent
+ THEN clear error
+ FI ;
+ FALSE
+ ELSE count pages ;
+ pages counted = number of pages as label says
+ FI .
+
+look at label block :
+ INT CONST
+ old block nr := block nr ;
+ get label ;
+ block nr := old block nr.
+
+count pages :
+ INT VAR
+ pages counted := 0 ;
+ init next page ;
+ next page ;
+ WHILE NOT no further page REP
+ pages counted INCR 1 ;
+ next page
+ PER .
+
+number of pages as label says : label.lab (dr size) .
+
+ENDPROC search dataspace ;
+
+PROC format archive (INT CONST format code) :
+
+ IF format is possible
+ THEN format
+ ELSE errorstop ("'format' ist hier nicht implementiert")
+ FI .
+
+format is possible :
+ INT VAR return code ;
+ control (1,0,0, return code) ;
+ bit (return code, 4) .
+
+format :
+ control (7, format code, 0, return code) ;
+ IF return code = 1
+ THEN errorstop ("Formatieren unmoeglich")
+ ELIF return code > 1
+ THEN errorstop ("Schreibfehler (Archiv)")
+ FI .
+
+ENDPROC format archive ;
+
+END PACKET basic archive;
+
diff --git a/system/multiuser/1.7.5/src/canal b/system/multiuser/1.7.5/src/canal
new file mode 100644
index 0000000..ad0baa8
--- /dev/null
+++ b/system/multiuser/1.7.5/src/canal
@@ -0,0 +1,227 @@
+(* ------------------- VERSION 6 20.05.86 ------------------- *)
+PACKET canal DEFINES (* Autor: J.Liedtke *)
+
+ analyze supervisor command :
+
+
+
+LET command list =
+
+"begin:1.12end:3.0break:4.0continue:5.01halt:7.0
+taskinfo:8.0storageinfo:9.0help:10.0 ",
+
+ supervisor command text =
+
+""6""20""1"ESC ? --> help
+"6""21""1"ESC b --> begin ("""")
+"6""22""1"ESC c --> continue ("""")
+"6""23""1"ESC q --> break
+"6""21""50"ESC h --> halt
+"6""22""50"ESC s --> storage info
+"6""23""50"ESC t --> task info
+"6""8""6"gib supervisor kommando :" ,
+
+ text type = 4 ,
+ ack = 0 ,
+ error nak = 2 ,
+ begin code = 4 ,
+ end code = 5 ,
+ break code = 6 ,
+ halt code = 8 ,
+ password code = 9 ,
+ continue code = 100 ,
+
+ home = ""1"" ;
+
+
+TASK VAR sv ;
+
+DATASPACE VAR ds ;
+
+BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg ;
+BOUND TEXT VAR error msg ;
+
+INT VAR command index , number of params , reply ;
+TEXT VAR param 1, param 2 , task password ;
+
+
+ lernsequenz auf taste legen ("b", ""1""8""1""12"begin ("""")"8""8""11"") ;
+ lernsequenz auf taste legen ("c", ""1""8""1""12"continue ("""")"8""8""11"") ;
+ lernsequenz auf taste legen ("q", ""1""8""1""12"break"13"") ;
+ lernsequenz auf taste legen ("h", ""1""8""1""12"halt"13"") ;
+ lernsequenz auf taste legen ("s", ""1""8""1""12"storage info"13"") ;
+ lernsequenz auf taste legen ("t", ""1""8""1""12"task info"13"") ;
+ lernsequenz auf taste legen ("?", ""1""8""1""12"help"13"") ;
+
+PROC analyze supervisor command :
+
+ disable stop ;
+ sv := supervisor ;
+ ds := nilspace ;
+ REP
+ command dialogue (TRUE) ;
+ command pre ;
+ cry if not enough storage ;
+ get command (supervisor command text) ;
+ analyze command (command list, text type,
+ command index, number of params,
+ param1, param2) ;
+ execute command ;
+ PER .
+
+command pre :
+ IF NOT is error
+ THEN wait for terminal; eumel must advertise
+ ELSE forget (ds) ; ds := nilspace
+ FI .
+
+wait for terminal :
+ out (home) .
+
+cry if not enough storage :
+ INT VAR size, used ;
+ storage (size, used) ;
+ IF used > size
+ THEN out (""7"Speicher Engpass!"13""10"") ;
+ FI .
+
+ENDPROC analyze supervisor command ;
+
+PROC execute command :
+
+ enable stop ;
+ SELECT command index OF
+ CASE 1 : begin ("PUBLIC")
+ CASE 2 : begin (param2)
+ CASE 3 : end via canal
+ CASE 4 : break
+ CASE 5 : quiet
+ CASE 6 : continue (param1)
+ CASE 7 : halt
+ CASE 8 : task info (0); eumel must advertise; quiet
+ CASE 9 : storage info; quiet
+ CASE 10 : help; eumel must advertise; quiet
+ OTHERWISE analyze command error
+ ENDSELECT ;
+ IF reply = error nak
+ THEN error msg := ds ;
+ errorstop (CONCR (error msg))
+ FI .
+
+end via canal :
+ IF yes ("Task """ + name (task (channel (myself))) + """ loeschen")
+ THEN eumel must advertise ;
+ call (sv, end code, ds, reply)
+ FI .
+
+break :
+ eumel must advertise ;
+ call (sv, break code, ds, reply) .
+
+halt :
+ call (sv, halt code, ds, reply) .
+
+quiet :
+ call (sv, ack, ds, reply) .
+
+analyze command error :
+ command error ;
+ IF command index = 0
+ THEN errorstop ("kein supervisor kommando")
+ ELIF number of params = 0
+ THEN errorstop ("Taskname fehlt")
+ ELSE errorstop ("Parameter ueberfluessig")
+ FI .
+
+ENDPROC execute command ;
+
+PROC begin (TEXT CONST father name) :
+
+ IF param1 = "-"
+ THEN errorstop ("Name ungueltig")
+ FI ;
+ sv msg := ds ;
+ CONCR (sv msg).tname := param1 ;
+ CONCR (sv msg).tpass := "" ;
+ call (task (father name), begin code, ds, reply) ;
+ IF reply = password code
+ THEN get password ;
+ sv msg := ds ;
+ CONCR (sv msg).tpass := task password ;
+ call (task (father name), begin code, ds, reply)
+ FI ;
+ IF reply = ack
+ THEN continue (param1)
+ FI .
+
+get password :
+ put (" Passwort:") ;
+ get secret line (task password) .
+
+ENDPROC begin ;
+
+PROC continue (TEXT CONST task name) :
+
+ sv msg := ds ;
+ CONCR (sv msg).tname := task name ;
+ CONCR (sv msg).tpass := "" ;
+ call (sv, continue code + channel, ds, reply) ;
+ IF reply = password code
+ THEN get password ;
+ sv msg := ds ;
+ CONCR (sv msg).tpass := task password ;
+ call (sv, continue code + channel, ds, reply)
+ FI .
+
+get password :
+ put (" Passwort:") ;
+ get secret line (task password) .
+
+ENDPROC continue ;
+
+PROC help:
+
+ LET page = ""1""4""
+ ,bell = ""7""
+ ,cr = ""13""
+ ,end mark = ""14""
+ ,begin mark = ""15""
+ ,esc = ""27""
+ ;
+
+ REP
+ out (page) ;
+ show page ;
+ UNTIL is quit command PER .
+
+ show page :
+ putline(begin mark + (31 * ".") + " supervisor help " + (31 * ".") + end mark) ;
+ putline("Hier finden Sie einige Kommandos, die Ihnen den Einstieg ins System er -") ;
+ putline("leichtern sollen:") ;
+ out(""6""05""07"1. Informations-Kommandos") ;
+ out(""6""07""11"storage info physisch belegten Hintergrundplatz melden") ;
+ out(""6""08""11"task info Taskbaum zeigen") ;
+ out(""6""14""07"2. Verbindung zum Supervisor") ;
+ out(""6""16""11"break Task vom Terminal abkoppeln") ;
+ out(""6""17""11"begin(""task"") neue Task `task` einrichten") ;
+ out(""6""18""11"continue(""task"") Task `task` an ein Terminal ankoppeln") ;
+ out(""6""21""01"Näheres: Benutzerhandbuch, Teil 2, Kap. 2") ;
+ out(""6""23""05"Wenn Sie den Hilfe-Modus beenden wollen, tippen Sie die Taste `q`. ") ;
+ out(cr) .
+
+ is quit command :
+ TEXT VAR char ;
+ get char (char) ;
+ IF char = esc
+ THEN get char (char)
+ FI;
+ IF char = "q" COR char = "Q"
+ THEN true
+ ELSE out (bell);
+ FALSE
+ FI.
+
+END PROC help ;
+
+ENDPACKET canal ;
+
diff --git a/system/multiuser/1.7.5/src/configuration manager b/system/multiuser/1.7.5/src/configuration manager
new file mode 100644
index 0000000..5eaea52
--- /dev/null
+++ b/system/multiuser/1.7.5/src/configuration manager
@@ -0,0 +1,553 @@
+(* ------------------- VERSION 11 02.06.86 ------------------- *)
+PACKET configuration manager DEFINES
+
+ configurate ,
+ exec configuration ,
+ setup ,
+ define collector ,
+ configuration manager :
+
+
+LET baudrates = ""1"50"2"75"3"110"4"134.5"5"150"6"300"7"600
+"8"1200"9"1800"10"2400"11"3600"12"4800"13"7200
+"14"9600"15"19200"16"38400"17"",
+ parities = ""0"no"1"odd"2"even"3"" ,
+ bits per char = ""0"1"1"2"2"3"3"4"4"5"5"6"6"7"7"8"8"" ,
+ stopbits = ""0"1"1"1.5"2"2"3"" ,
+ flow modes = ""0"ohne Protokoll"1"XON/XOFF"2"RTS/CTS
+"3""4""5"XON/XOFF - ausgabeseitig"6"RTS/CTS - ausgabeseitig"7""8"
+"9"XON/XOFF - eingabeseitig"10"RTS/CTS - eingabeseitig"11"" ,
+
+ ok = "j" ,
+ esc = ""27"" ,
+ cr = ""13"" ,
+ right = ""2"" ,
+
+ psi = "psi" ,
+ transparent = "transparent" ,
+
+ std rate = 14 ,
+ std bits = 22 ,
+ std flow = 0 ,
+ std inbuffer size = 16 ,
+
+ device table = 32000 ,
+
+ max edit terminal = 15 ,
+ configuration channel = 32 ,
+
+ fetch code = 11 ,
+ save code = 12 ,
+ erase code = 14 ,
+ system start interrupt = 100 ,
+
+ CONF = STRUCT (TEXT dev type,
+ INT baud, bits par stop, flow control, inbuffer size) ;
+
+
+BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ;
+
+BOUND ROW max edit terminal CONF VAR conf ;
+
+INT VAR channel no ;
+
+TEXT VAR prelude , last feature , answer , collector := "" ;
+
+
+
+BOOL PROC shard permits (INT CONST code, key) :
+
+ INT VAR reply ;
+ IF key > -128
+ THEN control (code, channel no, key, reply)
+ ELSE control (code, channel no, -maxint-1, reply)
+ FI ;
+ reply = 0 .
+
+ENDPROC shard permits ;
+
+PROC ask user (TEXT CONST feature, question) :
+
+ last feature := feature ;
+ put question ;
+ skip pretyped chars ;
+ get valid answer .
+
+put question :
+ clear line ;
+ out (prelude) ;
+ out (feature) ;
+ out (question) ;
+ out (" (j/n) ") .
+
+clear line :
+ out (cr) ;
+ 79 TIMESOUT " " ;
+ out (cr) .
+
+skip pretyped chars :
+ REP UNTIL incharety = "" PER .
+
+get valid answer :
+ REP
+ inchar (answer)
+ UNTIL pos ("jJyYnN"27"", answer) > 0 PER ;
+ IF answer > ""31""
+ THEN out (answer)
+ FI ;
+ out (cr) ;
+ normalize answer .
+
+normalize answer :
+ IF pos ("jJyY", answer) > 0
+ THEN answer := ok
+ FI .
+
+ENDPROC ask user ;
+
+BOOL PROC yes (TEXT CONST question) :
+
+ ask user ("", question) ;
+ answer = ok
+
+ENDPROC yes ;
+
+PROC chose key (INT VAR old key, INT CONST max key, TEXT CONST key string,
+ key entity, BOOL PROC (INT CONST) shard permits):
+
+ IF shard permits at least one standard key
+ THEN try all keys
+ FI .
+
+shard permits at least one standard key :
+ INT VAR key ;
+ FOR key FROM 0 UPTO max key REP
+ IF shard permits (key)
+ THEN LEAVE shard permits at least one standard key WITH TRUE
+ FI
+ PER ;
+ FALSE .
+
+try all keys :
+ key := old key ;
+ REP
+ examine this key ;
+ next key
+ PER .
+
+examine this key :
+ IF shard permits (key) CAND key value <> ""
+ THEN ask user (key value, key entity) ;
+ IF answer = ok
+ THEN chose this key
+ ELIF answer = esc
+ THEN key := -129
+ FI
+ FI .
+
+key value :
+ IF key >= 0
+ THEN subtext (key string, key pos + 1, next key pos - 1)
+ ELSE text (key)
+ FI .
+
+key pos : pos (key string, code (key)) .
+next key pos : pos (key string, code (key+1)) .
+
+chose this key :
+ remember calibration ;
+ old key := key ;
+ LEAVE chose key .
+
+next key :
+ IF key < max key
+ THEN key INCR 1
+ ELSE key := 0
+ FI .
+
+remember calibration :
+ prelude CAT last feature ;
+ prelude CAT ", " .
+
+ENDPROC chose key ;
+
+BOOL PROC rate ok (INT CONST key) :
+
+ shard permits (8, key)
+
+ENDPROC rate ok ;
+
+BOOL PROC bits ok (INT CONST key) :
+
+ IF key < 0
+ THEN shard permits (9, key)
+ ELSE some standard combination ok
+ FI .
+
+some standard combination ok :
+ INT VAR combined := key ;
+ REP
+ IF shard permits (9, combined)
+ THEN LEAVE bits ok WITH TRUE
+ FI ;
+ combined INCR 8
+ UNTIL combined > 127 PER ;
+ FALSE
+
+ENDPROC bits ok ;
+
+BOOL PROC parity ok (INT CONST key) :
+
+ INT VAR combined := 8 * key + data bits ;
+ key >= 0 AND (shard permits (9, combined) OR
+ shard permits (9, combined + 32) OR
+ shard permits (9, combined + 64) )
+
+ENDPROC parity ok ;
+
+BOOL PROC stopbits ok (INT CONST key) :
+
+ key >= 0 AND shard permits (9, 32 * key + 8 * parity + data bits)
+
+ENDPROC stopbits ok ;
+
+BOOL PROC flow mode ok (INT CONST key) :
+
+ shard permits (6, key)
+
+ENDPROC flow mode ok ;
+
+
+
+INT VAR data bits ,
+ parity ,
+ stop ;
+
+INT VAR old session := 0 ;
+
+
+TEXT VAR table name, dummy ;
+
+
+PROC configurate :
+
+ new configuration ;
+ access configuration table ;
+ show all device types ;
+ channel no := 1 ;
+ REP
+ IF channel hardware exists
+ THEN try this channel ;
+ setup this channel
+ FI ;
+ channel no INCR 1
+ UNTIL channel no > 15 PER ;
+ prelude := "" ;
+ IF yes ("Koennen unbenutzte Geraetetypen geloescht werden")
+ THEN forget unused device tables
+ FI .
+
+access configuration table :
+ IF exists ("configuration")
+ THEN conf := old ("configuration")
+ ELSE conf := new ("configuration") ;
+ initialize configuration
+ FI .
+
+initialize configuration :
+ FOR channel no FROM 1 UPTO max edit terminal REP
+ conf (channel no) :=
+ CONF:(transparent, std rate, std bits, std flow, std inbuffer size)
+ PER ;
+ conf (1).dev type := psi .
+
+show all device types :
+ show prelude ;
+ begin list ;
+ get list entry (table name, dummy) ;
+ WHILE table name <> "" REP
+ IF dataspace is device table
+ THEN show table name
+ FI ;
+ get list entry (table name, dummy)
+ PER ;
+ line (2) .
+
+show prelude :
+ line (30) ;
+ outtext (psi, 1, 20) ;
+ outtext (transparent, 1, 20) .
+
+dataspace is device table :
+ type (old (table name)) = device table .
+
+show table name :
+ outtext (table name, 1, 20) .
+
+try this channel :
+ prelude := "Kanal " ;
+ ask user ("", text (channel no)) ;
+ IF answer = ok
+ THEN prelude CAT text (channel no) + ": " ;
+ get configuration from user (conf (channel no)) ;
+ line
+ FI .
+
+channel hardware exists :
+ INT VAR
+ operators channel := channel ;
+ INT VAR channel type ;
+ disable stop ;
+ continue (channel no) ;
+ IF is error
+ THEN IF error message = "kein Kanal"
+ THEN channel type := 0
+ ELSE channel type := inout mask
+ FI
+ ELSE get channel type from shard
+ FI ;
+ clear error ;
+ disable stop ;
+ continue operators channel ;
+ (channel type AND inout mask) <> 0 .
+
+get channel type from shard :
+ control (1, 0, 0, channel type) .
+
+inout mask : 3 .
+
+forget unused device tables :
+ begin list ;
+ get list entry (table name, dummy) ;
+ WHILE table name <> "" REP
+ IF type (old (table name)) = device table
+ THEN forget if unused
+ FI ;
+ get list entry (table name, dummy)
+ PER .
+
+forget if unused :
+ FOR channel no FROM 1 UPTO max edit terminal REP
+ IF conf (channel no).dev type = table name
+ THEN LEAVE forget if unused
+ FI
+ PER ;
+ forget (table name, quiet) .
+
+setup this channel :
+ operators channel := channel ;
+ disable stop ;
+ continue (configuration channel) ;
+ set up channel (channel no, conf (channel no)) ;
+ continue operators channel .
+
+continue operators channel :
+ continue (operators channel) ;
+ IF is error
+ THEN clear error ;
+ break (quiet) ;
+ LEAVE configurate
+ FI ;
+ enable stop .
+
+ENDPROC configurate ;
+
+PROC get configuration from user (CONF VAR conf) :
+
+ get device type ;
+ get baud rate ;
+ get bits and parity and stopbits ;
+ get protocol ;
+ get buffer size .
+
+
+get device type :
+ begin list ;
+ table name := conf.dev type ;
+ IF NOT is valid device type
+ THEN next device type
+ FI ;
+ REP
+ IF NOT (table name = transparent AND channel no = 1)
+ THEN ask user ("", table name) ;
+ IF answer = ok COR was esc followed by type table name
+ THEN IF is valid device type
+ THEN remember device type ;
+ LEAVE get device type
+ ELSE out (""7" unbekannter Typ"); pause (20)
+ FI
+ FI
+ FI ;
+ next device type
+ PER .
+
+was esc followed by type table name :
+ IF answer = esc
+ THEN 9 TIMESOUT right ;
+ put ("Typ:") ;
+ editget (table name) ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+is valid device type :
+ table name = psi OR table name = transparent OR
+ (exists (table name) CAND type (old (table name)) = device table) .
+
+remember device type :
+ prelude CAT table name ;
+ conf.dev type := table name ;
+ prelude CAT ", " .
+
+next device type :
+ IF table name = psi
+ THEN table name := transparent
+ ELSE IF table name = transparent
+ THEN begin list
+ FI ;
+ search next device type space
+ FI .
+
+search next device type space :
+ REP
+ get list entry (table name, dummy)
+ UNTIL table name = "" COR type (old (table name)) = device table PER;
+ IF table name = ""
+ THEN table name := psi
+ FI .
+
+get baud rate :
+ chose key (conf.baud, 16, baudrates, " Baud", PROC rate ok) .
+
+get bits and parity and stopbits :
+ data bits := conf.bits par stop MOD 8 ;
+ parity := (conf.bits par stop DIV 8) MOD 4 ;
+ stop := (conf.bits par stop DIV 32) MOD 4 ;
+ chose key (data bits, 7, bits per char, " Bits", PROC bits ok) ;
+ IF data bits >= 0
+ THEN chose key (parity, 2, parities, " parity", PROC parity ok) ;
+ chose key (stop, 2, stopbits, " Stopbits", PROC stopbits ok);
+ conf.bits par stop := data bits + 8 * parity + 32 * stop
+ ELSE conf.bits par stop := data bits
+ FI .
+
+get protocol :
+ chose key (conf.flow control, 10, flow modes,
+ "", PROC flow mode ok) .
+
+get buffer size :
+ IF dev type is transparent
+ THEN chose buffer size
+ ELSE conf.inbuffer size := std inbuffer size
+ FI .
+
+dev type is transparent :
+ conf.dev type = "transparent" .
+
+chose buffer size :
+ REP
+ IF conf.inbuffer size = 16 CAND yes ("normaler Puffer")
+ THEN LEAVE chose buffer size
+ FI ;
+ conf.inbuffer size := 512 ;
+ IF yes ("grosser Puffer")
+ THEN LEAVE chose buffer size
+ FI ;
+ conf.inbuffer size := 16
+ PER .
+
+ENDPROC get configuration from user ;
+
+PROC exec configuration :
+
+ setup
+
+ENDPROC exec configuration ;
+
+PROC setup :
+
+ conf := old ("configuration") ;
+ continue (configuration channel) ;
+ FOR channel no FROM 1 UPTO max edit terminal REP
+ set up channel (channel no, conf (channel no))
+ PER ;
+ set up collector task ;
+ break but do not forget error message if any .
+
+set up collector task :
+ IF collector <> "" CAND collector <> "-" CAND exists task (collector)
+ THEN define collector (task (collector))
+ FI .
+
+break but do not forget error message if any :
+ IF is error
+ THEN dummy := error message ;
+ clear error ;
+ break (quiet) ;
+ errorstop (dummy)
+ ELSE break (quiet)
+ FI .
+
+ENDPROC set up ;
+
+PROC set up channel (INT CONST channel no, CONF CONST conf) :
+
+ link (channel no, conf.dev type) ;
+ baudrate (channel no, conf.baud) ;
+ bits (channel no, conf.bits par stop) ;
+ flow (channel no, conf.flow control) ;
+ input buffer size (channel no, conf.inbuffer size) .
+
+ENDPROC setup channel ;
+
+PROC configuration manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+
+ enable stop ;
+ IF order <> system start interrupt
+ THEN font manager
+ FI ;
+ IF session <> old session
+ THEN disable stop ;
+ set up ;
+ clear error ;
+ old session := session ;
+ set autonom
+ FI .
+
+ font manager :
+ IF (order <> save code AND order <> erase code ) OR order task < supervisor
+ THEN delete password if there is one;
+ free manager (ds, order, phase, order task)
+ ELSE errorstop ("kein Zugriffsrecht auf Task """ + name (myself) + """")
+ FI .
+
+ delete password if there is one :
+ IF order >= fetch code AND order <= erase code AND phase = 1
+ THEN msg := ds;
+ msg. write pass := "";
+ msg. read pass := "";
+ FI .
+
+ENDPROC configuration manager ;
+
+PROC configuration manager :
+
+ configurate ;
+ break ;
+ global manager
+ (PROC (DATASPACE VAR,INT CONST,INT CONST,TASK CONST) configuration manager)
+
+ENDPROC configuration manager ;
+
+PROC define collector (TEXT CONST task table name) :
+
+ collector := task table name ;
+ IF exists task (collector)
+ THEN define collector (task (collector))
+ FI
+
+ENDPROC define collector ;
+
+ENDPACKET configuration manager ;
+
diff --git a/system/multiuser/1.7.5/src/eumel printer b/system/multiuser/1.7.5/src/eumel printer
new file mode 100644
index 0000000..94858b5
--- /dev/null
+++ b/system/multiuser/1.7.5/src/eumel printer
@@ -0,0 +1,3066 @@
+PACKET eumel printer (* Autor : Rudolf Ruland *)
+ (* Version : 4 *)
+ (* Stand : 05.05.86 *)
+ DEFINES print,
+ with elan listings,
+ is elan source,
+ bottom label for elan listings,
+ x pos,
+ y pos,
+ y offset index,
+ line type,
+ material,
+ pages printed :
+
+
+LET std x wanted = 2.54,
+ std y wanted = 2.35,
+ std limit = 16.0,
+ std pagelength = 25.0,
+ std linefeed faktor = 1.0,
+ std material = "";
+
+LET blank = " ",
+ blank code 1 = 33,
+ geschuetztes blank = ""223"",
+ keine blankanalyse = 0,
+ einfach blank = 1,
+ doppel blank = 2,
+
+ anweisungszeichen = "#",
+ anweisungszeichen code 1 = 36,
+ geschuetztes anweisungszeichen = ""222"",
+ druckerkommando zeichen = "/",
+ quote = """",
+
+ erweiterungs ausgang = 32767,
+ blank ausgang = 32766,
+ anweisungs ausgang = 32765,
+ d code ausgang = 32764,
+ max breite = 32763,
+
+ punkt = ".",
+
+ leer = 0,
+
+ kommando token = 0,
+ text token = 1,
+
+ underline linetype = 1,
+ underline bit = 0,
+ bold bit = 1,
+ italics bit = 2,
+ modifikations liste = "ubir",
+ anzahl modifikationen = 4,
+
+ document = 1,
+ page = 2,
+
+ write text = 1,
+ write cmd = 2,
+ carriage return = 3,
+ move = 4,
+ draw = 5,
+ on = 6,
+ off = 7,
+ type = 8,
+
+ tag type = 1,
+ bold type = 2,
+ number type = 3,
+ text type = 4,
+ delimiter type = 6,
+ eof type = 7;
+
+
+INT CONST null ausgang := -32767-1;
+
+ROW anzahl modifikationen INT CONST modifikations werte :=
+ ROW anzahl modifikationen INT : (1, 2, 4, 8);
+
+TEXT CONST anweisungsliste :=
+ "type:1.1on:2.1off:3.1center:4.0right:5.0u:6.0d:7.0e:8.0b:9.0" +
+ "fillchar:10.1mark:11.2markend:12.0" +
+ "ub:13.0ue:14.0fb:15.0fe:16.0" +
+ "block:20.0columns:21.2columnsend:22.0free:23.1limit:24.1linefeed:25.1" +
+ "material:26.1page:27.01pagelength:29.1start:30.2" +
+ "table:31.0tableend:32.0clearpos:33.01" +
+ "lpos:35.1rpos:36.1cpos:37.1dpos:38.2bpos:39.2" +
+ "textbegin:40.02textend:42.0" +
+ "indentation:43.1ytab:44.1";
+
+LET a type = 1, a block = 20,
+ a on = 2, a columns = 21,
+ a off = 3, a columnsend = 22,
+ a center = 4, a free = 23,
+ a right = 5, a limit = 24,
+ a up = 6, a linefeed = 25,
+ a down = 7, a material = 26,
+ a end up or down = 8, a page0 = 27,
+ a bsp = 9, a page1 = 28,
+ a fill char = 10, a pagelength = 29,
+ a mark = 11, a start = 30,
+ a markend = 12, a table = 31,
+ a ub = 13, a tableend = 32,
+ a ue = 14, a clearpos0 = 33,
+ a fb = 15, a clearpos1 = 34,
+ a fe = 16, a lpos = 35,
+ a rpos = 36,
+ a cpos = 37,
+ a dpos = 38,
+ a bpos = 39,
+ a textbegin0 = 40,
+ a textbegin2 = 41,
+ a textend = 42,
+ a indentation = 43,
+ a y tab = 44;
+
+INT VAR a xpos, a breite, a font, a modifikationen,
+ a modifikationen fuer x move, a ypos, aktuelle ypos,
+ letzter font, letzte modifikationen,
+ d ypos, d xpos, d font, d modifikationen,
+
+ zeilenpos, alte zeilenpos, zeilen laenge, anzahl zeichen, ausgang,
+ anzahl einrueck blanks, blankbreite,
+ einrueckbreite, aktuelle einrueckbreite, alte einrueckbreite,
+ font durchschuss, fonthoehe, font tiefe,
+ groesste fonthoehe, aktuelle zeilenhoehe, letzte zeilenhoehe,
+ blankmodus, alter blankmodus,
+ token zeiger, erstes token der zeile,
+
+ erstes tab token, tab anfang, anzahl blanks,
+ d code 1, d pitch, fuell zeichen breite, erstes fuell token,
+ letztes fuell token,
+
+ x size, y size, x wanted, y wanted, x start, y start,
+ pagelength, limit, indentation,
+ left margin, top margin, seitenlaenge,
+ papierlaenge, papierbreite,
+ luecke, anzahl spalten, aktuelle spalte,
+
+ verschiebung, rest, neue modifikationen, modifikations modus, pass,
+
+ int param, anweisungs index, anzahl params, index,
+
+ gedruckte seiten;
+
+BOOL VAR zeile ist absatzzeile, letzte zeile war absatzzeile,
+ zeile muss geblockt werden, rechts, a block token, offsets,
+ tabellen modus, block modus, center modus, right modus,
+ seite ist offen, vor erster seite;
+
+REAL VAR linefeed faktor, real param;
+
+TEXT VAR zeile, anweisung, par1, par2, material wert, replacements,
+ fuell zeichen, d string, font offsets;
+
+ROW 256 INT VAR zeichenbreiten, replacement tabelle, zeichen zaehler;
+
+INITFLAG VAR in dieser task := FALSE;
+
+. zeile ist zu ende : zeilenpos > zeilen laenge
+
+. zeilen breite : a xpos - left margin
+
+. neue zeilenhoehe : int (linefeed faktor * real (fonthoehe) + 0.5)
+
+. naechstes zeichen ist blank : pos (zeile, blank, zeilenpos + 1, zeilenpos + 1) <> 0
+
+. naechstes nicht blankes zeichen : pos (zeile, ""33"", ""255"", zeilenpos)
+
+. in letzter spalte : aktuelle spalte >= anzahl spalten
+
+. anfangs blankmodus :
+ INT VAR dummy;
+ IF center modus OR right modus
+ THEN dummy
+ ELIF index zaehler = 0
+ THEN blankmodus
+ ELSE alter blankmodus
+ FI
+
+. initialisiere tab variablen :
+ erstes tab token := token index f + 1;
+ tab anfang := zeilen breite;
+ anzahl blanks := 0;
+.;
+
+(******************************************************************)
+
+LET zeilen nr laenge = 4,
+ teil einrueckung = 5,
+
+ headline pre = "Zeile **** E L A N EUMEL 1.7.5 **** ",
+ headline post = " **** ";
+
+INT VAR zeilen nr, rest auf seite,
+ max zeichen zeile, max zeichen fuss, layout laenge, layout laenge name,
+ symbol type, naechster symbol type;
+
+BOOL VAR vor erstem packet, innerhalb der define liste;
+
+TEXT VAR bottom label, dateiname, layout blanks, refinement layout zeile;
+
+
+. symbol : fuell zeichen
+. naechstes symbol : d string
+. elan text : d token. text
+.;
+
+(******************************************************************)
+(*** tokenspeicher ***)
+
+LET max token = 3000,
+ max ypos = 1000,
+
+ TOKEN = STRUCT (TEXT text,
+ INT xpos, breite, font, modifikationen,
+ modifikationen fuer x move,
+ offset index, naechster token index,
+ BOOL block token ),
+
+ YPOS = STRUCT (INT ypos, vorheriger ypos index, naechster ypos index,
+ erster token index, letzter token index ),
+
+ TOKENLISTE = STRUCT (ROW max token TOKEN token liste,
+ ROW max ypos YPOS ypos liste );
+
+DATASPACE VAR ds;
+
+BOUND TOKENLISTE VAR tokenspeicher;
+
+TOKEN VAR d token, offset token;
+
+INT VAR erster ypos index a, letzter ypos index a,
+ erster ypos index d, letzter ypos index d,
+ ypos index, ypos index f, ypos index a, ypos index d,
+ token index, token index f;
+
+. t : tokenspeicher. token liste (token index)
+. tf : tokenspeicher. token liste (token index f)
+
+. y : tokenspeicher. ypos liste (ypos index)
+. yf : tokenspeicher. ypos liste (ypos index f)
+. ya : tokenspeicher. ypos liste (ypos index a)
+. yd : tokenspeicher. ypos liste (ypos index d)
+
+. loesche druckspeicher :
+ erster ypos index d := 0;
+ ypos index f := 0;
+ token index f := 0;
+
+. druckspeicher ist nicht leer :
+ erster ypos index d <> 0
+
+. loesche analysespeicher :
+ erster ypos index a := 0;
+
+. analysespeicher ist nicht leer :
+ erster ypos index a <> 0
+.;
+
+(******************************************************************)
+(*** anweisungsspeicher ***)
+
+INT VAR anweisungszaehler;
+TEXT VAR anweisungs indizes, params1 zeiger, params2 zeiger;
+THESAURUS VAR params1, params2;
+
+PROC loesche anweisungsspeicher :
+
+ anweisungs zaehler := 0;
+ anweisungs indizes := "";
+ params1 zeiger := "";
+ params2 zeiger := "";
+ params1 := empty thesaurus;
+ params2 := empty thesaurus;
+
+END PROC loesche anweisungsspeicher;
+
+(******************************************************************)
+(*** indexspeicher ***)
+
+INT VAR index zaehler;
+TEXT VAR grosse fonts, verschiebungen;
+
+PROC loesche indexspeicher :
+
+ index zaehler := 0;
+ grosse fonts := "";
+ verschiebungen := "";
+
+END PROC loesche indexspeicher;
+
+
+(******************************************************************)
+(*** tabellenspeicher ***)
+
+LET max tabs = 30,
+ TABELLENEINTRAG = STRUCT (INT tab typ, tab position, tab param);
+
+TEXT VAR tab liste, fill char;
+THESAURUS VAR d strings;
+ROW max tabs TABELLENEINTRAG VAR tabspeicher;
+
+INT VAR tab index;
+
+. tab typ : tab speicher (tab liste ISUB tab index). tab typ
+. tab position : tab speicher (tab liste ISUB tab index). tab position
+. tab param : tab speicher (tab liste ISUB tab index). tab param
+. anzahl tabs : LENGTH tab liste DIV 2
+.;
+
+PROC loesche tabellenspeicher :
+
+ fill char := " ";
+ tabliste := "";
+ d strings := empty thesaurus;
+ FOR tab index FROM 1 UPTO max tabs
+ REP tab speicher (tab index). tab typ := leer PER;
+
+END PROC loesche tabellenspeicher;
+
+(******************************************************************)
+(*** markierungsspeicher ***)
+
+INT VAR mark index l, mark index r, alter mark index l, alter mark index r;
+
+ROW 4 TOKEN VAR mark token;
+
+. markierung links : mark index l > 0
+. markierung rechts : mark index r > 0
+.;
+
+PROC loesche markierung :
+
+ mark index l := 0;
+ mark index r := 0;
+
+END PROC loesche markierung;
+
+
+PROC loesche alte markierung :
+
+ alter mark index l := 0;
+ alter mark index r := 0;
+
+END PROC loesche alte markierung;
+
+
+PROC initialisiere markierung :
+
+ FOR mark index l FROM 1 UPTO 4
+ REP mark token (mark index l). modifikationen fuer x move := 0;
+ mark token (mark index l). offset index := text token;
+ mark token (mark index l). block token := FALSE;
+ mark token (mark index l). naechster token index := 0;
+ PER;
+
+END PROC initialisiere markierung;
+
+(******************************************************************)
+(*** durchschuss ***)
+
+INT VAR durchschuss 1, durchschuss 2, anzahl durchschuss 1,
+ anzahl durchschuss, zeilen zaehler;
+
+BOOL VAR wechsel := TRUE;
+
+INT PROC durchschuss :
+
+ zeilen zaehler INCR 1;
+ IF zeilen zaehler <= anzahl durchschuss 1
+ THEN durchschuss 1
+ ELIF zeilen zaehler <= anzahl durchschuss
+ THEN durchschuss 2
+ ELSE 0
+ FI
+
+END PROC durchschuss;
+
+
+PROC neuer durchschuss (INT CONST anzahl, rest) :
+
+ zeilen zaehler := 0;
+ anzahl durchschuss := anzahl;
+ IF anzahl > 0
+ THEN IF wechsel
+ THEN durchschuss 1 := rest DIV anzahl durchschuss;
+ durchschuss 2 := durchschuss 1 + sign (rest);
+ anzahl durchschuss 1 := anzahl durchschuss -
+ abs (rest) MOD anzahl durchschuss;
+ wechsel := FALSE;
+ ELSE durchschuss 2 := rest DIV anzahl durchschuss;
+ durchschuss 1 := durchschuss 2 + sign (rest);
+ anzahl durchschuss 1 := abs (rest) MOD anzahl durchschuss;
+ wechsel := TRUE;
+ FI;
+ ELSE loesche durchschuss
+ FI;
+
+END PROC neuer durchschuss;
+
+
+PROC loesche durchschuss :
+
+ durchschuss 1 := 0;
+ durchschuss 2 := 0;
+ anzahl durchschuss 1 := 0;
+ anzahl durchschuss := 0;
+ zeilen zaehler := 0;
+
+END PROC loesche durchschuss;
+
+(****************************************************************)
+
+PROC initialisierung :
+
+ forget (ds);
+ ds := nilspace; tokenspeicher := ds;
+ loesche druckspeicher;
+ loesche anweisungsspeicher;
+ loesche indexspeicher;
+ initialisiere markierung;
+ right modus := FALSE;
+ center modus := FALSE;
+ seite ist offen := FALSE;
+ pass := 0;
+ a breite := 0;
+ a block token := FALSE;
+ a modifikationen fuer x move := 0;
+ d code 1 := leer;
+ erstes fuell token := leer;
+ IF two bytes
+ THEN FOR index FROM 1 UPTO 129 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 130 UPTO 160 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 161 UPTO 224 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 225 UPTO 240 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 241 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ ELSE FOR index FROM 1 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ FI;
+
+END PROC initialisierung;
+
+(****************************************************************)
+(*** print - Kommando ***)
+
+BOOL VAR elan listings erlaubt;
+FILE VAR eingabe;
+
+with elan listings (TRUE);
+
+PROC with elan listings (BOOL CONST flag) :
+ elan listings erlaubt := flag;
+END PROC with elan listings;
+
+BOOL PROC with elan listings : elan listings erlaubt END PROC with elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute ):
+
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ FALSE, "");
+
+END PROC print;
+
+
+PROC print (FILE VAR file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ eingabe := file;
+ input (eingabe);
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ elan listings erlaubt CAND is elan source (eingabe),
+ headline (eingabe) );
+
+END PROC print;
+
+PROC lese zeile (TEXT VAR zeile) : getline (eingabe, zeile) END PROC lese zeile;
+
+BOOL PROC eof : eof (eingabe) END PROC eof;
+
+BOOL PROC is elan source (FILE VAR eingabe) :
+
+hole erstes symbol;
+elan programm tag COR elan programm bold COR kommentar
+
+. elan programm tag :
+ symbol type = tag type CAND pos (zeile, ";") > 0
+
+. elan programm bold :
+ symbol type = bold type CAND is elan bold
+
+ . is elan bold :
+ symbol = "PACKET" COR symbol = "LET"
+ COR proc oder op (symbol) COR deklaration
+
+ . deklaration :
+ next symbol (symbol);
+ symbol = "VAR" OR symbol = "CONST"
+
+. kommentar :
+ pos (zeile, "(*") > 0 OR pos (zeile, "{") > 0
+
+.
+ hole erstes symbol :
+ hole erstes nicht blankes symbol;
+ scan (zeile);
+ next symbol (symbol, symbol type);
+
+ . hole erstes nicht blankes symbol :
+ IF eof (eingabe) THEN LEAVE is elan source WITH FALSE FI;
+ REP getline (eingabe, zeile);
+ UNTIL pos (zeile, ""33"",""254"", 1) > 0 OR eof (eingabe) PER;
+ reset (eingabe);
+
+END PROC is elan source;
+
+(****************************************************************)
+
+bottom label for elan listings ("");
+
+PROC bottom label for elan listings (TEXT CONST label) :
+ bottom label := label;
+END PROC bottom label for elan listings;
+
+TEXT PROC bottom label for elan listings : bottom label END PROC bottom label for elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ BOOL CONST elan listing, TEXT CONST file name) :
+
+disable stop;
+gedruckte seiten := 0;
+drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ elan listing, file name );
+IF is error THEN behandle fehlermeldung FI;
+
+. behandle fehlermeldung :
+ par1 := error message;
+ int param := error line;
+ clear error;
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ clear error;
+ close (document, 0);
+ clear error;
+ FI;
+ initialisierung;
+ errorstop (par1 (* + " -> " + text (int param) *) );
+
+END PROC print;
+
+INT PROC x pos : d xpos END PROC x pos;
+INT PROC y pos : d ypos END PROC y pos;
+INT PROC y offset index : d token. offset index END PROC y offset index;
+INT PROC linetype : underline linetype END PROC linetype;
+TEXT PROC material : material wert END PROC material;
+INT PROC pages printed : gedruckte seiten END PROC pages printed;
+
+(****************************************************************)
+
+PROC drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ BOOL CONST elan listing, TEXT CONST file name ) :
+
+
+enable stop;
+IF elan listing
+ THEN dateiname := file name;
+ drucke elan listing;
+ ELSE drucke text datei;
+FI;
+
+.
+ drucke text datei :
+ initialisiere druck;
+ WHILE NOT eof
+ REP next line (zeile);
+ analysiere zeile;
+ drucke token soweit wie moeglich;
+ werte anweisungsspeicher aus;
+ PER;
+ schliesse druck ab;
+
+.
+ initialisiere druck :
+ IF NOT initialized (in dieser task)
+ THEN ds := nilspace;
+ initialisierung
+ FI;
+ vor erster seite := TRUE;
+ tabellen modus := FALSE;
+ block modus := FALSE;
+ zeile ist absatzzeile := TRUE;
+ x wanted := x step conversion (std x wanted);
+ y wanted := y step conversion (std y wanted);
+ limit := x step conversion (std limit);
+ pagelength := y step conversion (std pagelength);
+ linefeed faktor := std linefeed faktor;
+ material wert := std material;
+ indentation := 0;
+ modifikations modus := maxint;
+ seitenlaenge := maxint;
+ papierlaenge := maxint;
+ left margin := 0;
+ top margin := 0;
+ a ypos := top margin;
+ a font := -1;
+ a modifikationen := 0;
+ aktuelle spalte := 1;
+ anzahl spalten := 1;
+ stelle neuen font ein (1);
+ loesche tabellenspeicher;
+ loesche markierung;
+ loesche alte markierung;
+ loesche durchschuss;
+
+.
+ schliesse druck ab :
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ close (document, 0);
+ FI;
+
+.
+ drucke token soweit wie moeglich :
+ IF analysespeicher ist nicht leer
+ THEN letztes token bei gleicher ypos;
+ IF NOT seite ist offen
+ THEN eroeffne seite (x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ FI;
+ gehe zur letzten neuen ypos;
+ IF seitenlaenge ueberschritten OR papierlaenge ueberschritten
+ THEN neue seite oder spalte;
+ analysiere zeile nochmal;
+ ELSE sortiere neue token ein;
+ IF in letzter spalte
+ THEN drucke tokenspeicher (a ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ FI;
+ FI;
+
+ . gehe zur letzten neuen ypos :
+ ypos index a := letzter ypos index a
+
+ . seitenlaenge ueberschritten :
+ ya. ypos > seitenlaenge
+
+ . papierlaenge ueberschritten :
+ ya. ypos > papierlaenge
+
+ . neue seite oder spalte :
+ IF in letzter spalte
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ eroeffne seite (x wanted, aktuelles y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ ELSE neue spalte;
+ FI;
+
+ . aktuelles y wanted :
+ IF seitenlaenge ueberschritten
+ THEN y wanted
+ ELSE 0
+ FI
+
+ . analysiere zeile nochmal :
+ setze auf alte werte zurueck;
+ loesche anweisungsspeicher;
+ analysiere zeile;
+ letztes token bei gleicher ypos;
+ sortiere neue token ein;
+
+ . setze auf alte werte zurueck :
+ zeile ist absatzzeile := letzte zeile war absatzzeile;
+ a modifikationen := letzte modifikationen;
+ stelle neuen font ein (letzter font);
+
+.
+ werte anweisungsspeicher aus :
+ INT VAR index;
+ FOR index FROM 1 UPTO anweisungszaehler
+ REP
+ SELECT anweisungs indizes ISUB index OF
+ CASE a block : block anweisung
+ CASE a columns : columns anweisung
+ CASE a columnsend : columnsend anweisung
+ CASE a free : free anweisung
+ CASE a limit : limit anweisung
+ CASE a linefeed : linefeed anweisung
+ CASE a material : material anweisung
+ CASE a page0, a page1 : page anweisung
+ CASE a pagelength : pagelength anweisung
+ CASE a start : start anweisung
+ CASE a table : table anweisung
+ CASE a tableend : tableend anweisung
+ CASE a clearpos0 : clearpos0 anweisung
+ CASE a clearpos1 : clearpos1 anweisung
+ CASE a lpos, a rpos, a cpos, a dpos
+ : lpos rpos cpos dpos anweisung
+ CASE a bpos : bpos anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a textbegin0 : textbegin0 anweisung
+ CASE a textbegin2 : textbegin2 anweisung
+ CASE a textend : textend anweisung
+ CASE a indentation : indentation anweisung
+ CASE a y tab : y tab anweisung
+ END SELECT
+ PER;
+ loesche anweisungsspeicher;
+
+ . block anweisung :
+ blockmodus := TRUE;
+
+ . columns anweisung :
+ IF anzahl spalten = 1 AND int conversion ok (param1)
+ AND real conversion ok (param2)
+ THEN anzahl spalten := max (1, int param);
+ luecke := x step conversion (real param);
+ FI;
+
+ . columnsend anweisung :
+ anzahl spalten := 1;
+ aktuelle spalte := 1;
+ left margin := x wanted - x start + indentation;
+
+ . free anweisung :
+ IF real conversion ok (param1) THEN a ypos INCR y step conversion (real param) FI;
+
+ . limit anweisung :
+ IF real conversion ok (param1) THEN limit := x step conversion (real param) FI;
+
+ . linefeed anweisung :
+ IF real conversion ok (param1)
+ THEN linefeed faktor := real param;
+ letzte zeilenhoehe := neue zeilenhoehe;
+ FI;
+
+ . material anweisung :
+ material wert := param1;
+
+ . page anweisung :
+ IF seite ist offen
+ THEN IF NOT in letzter spalte
+ THEN neue spalte
+ ELSE schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ papier laenge := maxint;
+ FI;
+ ELSE a ypos := top margin;
+ papier laenge := maxint;
+ FI;
+
+ . pagelength anweisung :
+ IF real conversion ok (param1)
+ THEN pagelength := y step conversion (real param);
+ FI;
+
+ . start anweisung :
+ IF real conversion ok (param1) THEN x wanted := x step conversion (real param) FI;
+ IF real conversion ok (param2) THEN y wanted := y step conversion (real param) FI;
+
+ . table anweisung :
+ tabellenmodus := TRUE;
+
+ . tableend anweisung :
+ tabellenmodus := FALSE;
+
+ . clearpos0 anweisung :
+ loesche tabellenspeicher;
+
+ . clearpos1 anweisung :
+ IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = int param
+ THEN tab typ := leer;
+ delete int (tab liste, tab index);
+ LEAVE clearpos1 anweisung;
+ FI;
+ PER;
+ FI;
+
+ . lpos rpos cpos dpos anweisung :
+ IF real conversion ok (param1)
+ THEN neuer tab eintrag (anweisungs indizes ISUB index, param2) FI;
+
+ . bpos anweisung :
+ IF real conversion ok (param2) CAND real conversion ok (param1)
+ CAND real (param2) > real param
+ THEN neuer tab eintrag (a bpos, param2) FI;
+
+ . fillchar anweisung :
+ fill char := param1;
+
+ . textbegin0 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+
+ . textbegin2 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+ neuer durchschuss (int (param1), y step conversion (real (param 2)));
+
+ . textend anweisung :
+ alte einrueckbreite := aktuelle einrueckbreite;
+ alter mark index l := mark index l;
+ alter mark index r := mark index r;
+ loesche markierung;
+ loesche durchschuss;
+
+ . indentation anweisung :
+(* IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ left margin INCR (int param - indentation);
+ indentation := int param;
+ FI;
+ *)
+ . y tab anweisung :
+(* IF real conversion ok (param1)
+ THEN int param := y step conversion (real param);
+ IF int param <= seitenlaenge THEN a ypos := int param FI;
+ FI;
+ *)
+ . param1 :
+ IF (params1 zeiger ISUB index) <> 0
+ THEN name (params1, params1 zeiger ISUB index)
+ ELSE ""
+ FI
+
+ . param2 :
+ IF (params2 zeiger ISUB index) <> 0
+ THEN name (params2, params2 zeiger ISUB index)
+ ELSE ""
+ FI
+
+
+.
+ drucke elan listing :
+ initialisiere elan listing;
+ WHILE NOT eof
+ REP next line (zeile);
+ zeilen nr INCR 1;
+ drucke elan zeile;
+ PER;
+ schliesse elan listing ab;
+
+.
+ initialisiere elan listing :
+ open document cmd;
+ hole elan list font;
+ initialisiere variablen;
+ elan fuss und kopf (1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . open document cmd :
+ material wert := "";
+ d token. offset index := 1;
+ erster ypos index d := 0;
+ vor erster seite := FALSE;
+ seite ist offen := FALSE;
+ open (document, x size, y size);
+ vor erster seite := TRUE;
+
+ . hole elan list font :
+ d font := max (1, font ("elanlist"));
+ get replacements (d font, replacements, replacement tabelle);
+ einrueckbreite := indentation pitch (d font) ;
+ font hoehe := font lead (d font) + font height (d font) + font depth (d font);
+
+ . initialisiere variablen :
+ innerhalb der define liste := FALSE;
+ vor erstem packet := TRUE;
+ zeilen nr := 0;
+ y wanted := y size DIV 23;
+ pagelength := y size - y wanted - y wanted;
+ x wanted := (min (x size DIV 10, x step conversion (2.54))
+ DIV einrueckbreite) * einrueckbreite;
+ max zeichen zeile := (x size - x wanted - (x wanted DIV 3)) DIV einrueckbreite;
+ max zeichen fuss := fusszeilenbreite;
+ layout laenge := min (38, max zeichen zeile DIV 3);
+ layout laenge name := layout laenge - zeilen nr laenge - 8;
+ layout blanks := (layout laenge - zeilen nr laenge - 1) * " ";
+ refinement layout zeile := (layout laenge - 1) * " " ;
+ refinement layout zeile CAT "|" ;
+ IF pagelength DIV fonthoehe - 6 < 35 OR max zeichen zeile < 65
+ THEN errorstop ("Schreibfeld fuer 'elan listing' zu klein") FI;
+
+ . fusszeilenbreite :
+ INT CONST dina 4 breite := x step conversion (21.0);
+ IF x size <= dina 4 breite
+ THEN (x size - 2 * x wanted) DIV einrueckbreite
+ ELIF 120 * einrueckbreite <= dina 4 breite - 2 * x wanted
+ THEN (dina 4 breite - 2 * x wanted) DIV einrueckbreite
+ ELSE min (120, (x size - 2 * x wanted) DIV einrueckbreite)
+ FI
+
+.
+ schliesse elan listing ab :
+ elan fuss und kopf (-1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ close (document, 0);
+
+.
+ drucke elan zeile :
+ IF pos (zeile, "#page#") = 1
+ THEN IF nicht am seiten anfang THEN seiten wechsel FI;
+ ELSE bestimme elan layout;
+ bestimme elan zeile;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ seitenwechsel wenn noetig;
+ FI;
+
+ . nicht am seitenanfang :
+ rest auf seite < pagelength - 3 * font hoehe
+
+ . seiten wechsel :
+ elan fuss und kopf (0,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+.
+ bestimme elan layout :
+ IF pos (zeile, "P") = 0 AND pos (zeile, ":") = 0
+ THEN leeres layout
+ ELSE analysiere elan zeile
+ FI;
+ elan text CAT "|";
+
+ . leeres layout :
+ elan text := text (zeilen nr, zeilen nr laenge);
+ elan text CAT layout blanks;
+
+ . analysiere elan zeile :
+ scan (zeile);
+ next symbol (symbol, symbol type);
+ next symbol (naechstes symbol, naechster symbol type) ;
+ IF packet anfang THEN packet layout
+ ELIF innerhalb der define liste THEN leeres layout; pruefe ende der define liste
+ ELIF proc op anfang THEN proc op layout
+ ELIF refinement anfang THEN refinement layout
+ ELSE leeres layout
+ FI;
+
+ . packet anfang :
+ symbol = "PACKET"
+
+ . proc op anfang :
+ IF proc oder op (symbol)
+ THEN naechster symbol type <> delimiter type
+ ELIF (symbol <> "END") AND proc oder op (naechstes symbol)
+ THEN symbol := naechstes symbol;
+ next symbol (naechstes symbol, naechster symbol type) ;
+ naechster symbol type <> delimiter type
+ ELSE FALSE
+ FI
+
+ . refinement anfang :
+ symbol type = tag type AND naechstes symbol = ":"
+ AND NOT innerhalb der define liste
+
+ . packet layout :
+ IF nicht am seiten anfang AND
+ (NOT vor erstem packet OR gedruckte seiten > 0)
+ THEN seiten wechsel FI;
+ layout (" ", naechstes symbol, "*") ;
+ vor erstem packet := FALSE ;
+ innerhalb der define liste := TRUE;
+ pruefe ende der define liste;
+
+ . pruefe ende der define liste :
+ IF pos (zeile, ":") <> 0
+ THEN scan (zeile);
+ WHILE innerhalb der define liste
+ REP next symbol (symbol);
+ IF symbol = ":" THEN innerhalb der define liste := FALSE FI;
+ UNTIL symbol = "" PER;
+ FI;
+
+ . proc op layout :
+ IF keine vier zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", naechstes symbol, ".");
+
+ . keine vier zeilen mehr :
+ rest auf seite <= 8 * font hoehe
+
+ . refinement layout :
+ IF keine drei zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN elan text := refinement layout zeile;
+ gib elan text aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", symbol, " ");
+
+ . keine drei zeilen mehr :
+ rest auf seite <= 7 * font hoehe
+
+.
+ bestimme elan zeile :
+ IF zeile ist nicht zu lang
+ THEN elan text CAT zeile;
+ ELSE drucke zeile in teilen
+ FI;
+
+ . zeile ist nicht zu lang :
+ zeilen laenge := LENGTH zeile;
+ zeilen laenge <= rest auf zeile
+
+ . rest auf zeile :
+ max zeichen zeile - LENGTH elan text
+
+ . drucke zeile in teilen :
+ zeilen pos := 1;
+ bestimme einrueckung;
+ WHILE zeile noch nicht ganz gedruckt REP teil layout PER;
+
+ . bestimme einrueckung :
+ anzahl einrueck blanks := naechstes nicht blankes zeichen - 1;
+ IF anzahl einrueck blanks > rest auf zeile - 20
+ THEN anzahl einrueck blanks := 0 FI;
+
+ . zeile noch nicht ganz gedruckt :
+ bestimme zeilenteil;
+ NOT zeile ist zu ende
+
+ . bestimme zeilenteil :
+ bestimme laenge;
+ zeilen teil := subtext (zeile, zeilen pos, zeilen pos + laenge - 1);
+ elan text CAT zeilen teil;
+ zeilen pos INCR laenge;
+
+ . zeilen teil : par1
+
+ . bestimme laenge :
+ INT VAR laenge := zeilen laenge - zeilen pos + 1;
+ IF laenge > rest auf zeile
+ THEN laenge := rest auf zeile;
+ WHILE (zeile SUB (zeilen pos + laenge - 1)) <> " "
+ REP laenge DECR 1 UNTIL laenge = 0 PER;
+ IF laenge = 0 THEN laenge := rest auf zeile FI;
+ FI;
+
+ . teil layout :
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ elan text := (zeilen nr laenge - 1) * " ";
+ elan text CAT "+";
+ elan text CAT layout blanks;
+ elan text CAT "|";
+ elan text cat blanks (anzahl einrueck blanks + teil einrueckung);
+
+.
+ seiten wechsel wenn noetig :
+ IF keine zeilen mehr AND NOT eof THEN seiten wechsel FI;
+
+ . keine zeilen mehr :
+ rest auf seite <= 4 * font hoehe
+
+END PROC drucke datei;
+
+
+BOOL PROC real conversion ok (TEXT CONST param) :
+ real param := real (param);
+ last conversion ok AND real param >= 0.0
+END PROC real conversion ok;
+
+
+BOOL PROC int conversion ok (TEXT CONST param) :
+ int param := int (param);
+ last conversion ok AND int param >= 0
+END PROC int conversion ok;
+
+
+PROC neuer tab eintrag (INT CONST typ, TEXT CONST param) :
+
+ suche neuen eintrag;
+ sortiere neue tab position ein;
+ tab typ := typ;
+ tab position := neue tab position;
+ tab param := eventueller parameter;
+
+ . suche neuen eintrag :
+ INT VAR index := 0;
+ REP index INCR 1;
+ IF tab speicher (index). tab typ = leer
+ THEN LEAVE suche neuen eintrag FI;
+ UNTIL index = max tabs PER;
+ LEAVE neuer tab eintrag;
+
+ . sortiere neue tab position ein :
+ INT VAR neue tab position := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = neue tab position
+ THEN LEAVE neuer tab eintrag
+ ELIF tab position > neue tab position
+ THEN insert int (tab liste, tab index, index);
+ LEAVE sortiere neue tab position ein;
+ FI;
+ PER;
+ tab liste CAT index;
+ tab index := anzahl tabs;
+
+ . eventueller parameter :
+ INT VAR link;
+ SELECT typ OF
+ CASE a dpos : insert (d strings, param, link); link
+ CASE a bpos : x step conversion (real(param))
+ OTHERWISE : 0
+ END SELECT
+
+END PROC neuer tab eintrag;
+
+
+PROC neue spalte :
+ a ypos := top margin;
+ left margin INCR (limit + luecke);
+ aktuelle spalte INCR 1;
+END PROC neue spalte ;
+
+
+BOOL PROC proc oder op (TEXT CONST symbol) :
+
+ symbol = "PROC" OR symbol = "PROCEDURE"
+ OR symbol = "OP" OR symbol = "OPERATOR"
+
+ENDPROC proc oder op ;
+
+
+PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) :
+
+name := subtext (name, 1, layout laenge name) ;
+elan text := text (zeilen nr, zeilen nr laenge);
+elan text CAT pre;
+elan text CAT name;
+elan text CAT " ";
+generiere strukturiertes layout;
+
+. generiere strukturiertes layout :
+ INT VAR index;
+ FOR index FROM 1 UPTO layout laenge - LENGTH elan text - 1
+ REP elan text CAT post PER;
+
+ENDPROC layout ;
+
+
+PROC elan text cat blanks (INT CONST anzahl) :
+
+ par2 := anzahl * " ";
+ elan text CAT par2;
+
+END PROC elan text cat blanks;
+
+
+(***********************************************************************)
+
+PROC analysiere zeile :
+
+loesche analysespeicher;
+behandle fuehrende blanks;
+pruefe ob anweisungszeile;
+pruefe ob markierung links;
+
+IF tabellen modus
+ THEN analysiere tabellenzeile
+ELIF letzte zeile war absatzzeile
+ THEN analysiere zeile nach absatzzeile
+ ELSE analysiere zeile nach blockzeile
+FI;
+
+pruefe center und right modus;
+pruefe ob tabulation vorliegt;
+werte indexspeicher aus;
+berechne zeilenhoehe;
+pruefe ob markierung rechts;
+
+.
+ analysiere zeile nach absatzzeile :
+ test auf aufzaehlung;
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach absatzzeile
+ ELSE analysiere absatzzeile nach absatzzeile
+ FI;
+.
+ analysiere zeile nach blockzeile :
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach blockzeile
+ ELSE analysiere absatzzeile nach blockzeile
+ FI;
+
+
+.
+ behandle fuehrende blanks :
+ zeilenpos := 1;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN behandle leerzeile;
+ LEAVE analysiere zeile;
+ ELSE letzte zeile war absatzzeile := zeile ist absatzzeile;
+ IF letzte zeile war absatzzeile THEN neue einrueckung FI;
+ initialisiere analyse;
+ FI;
+
+ . behandle leerzeile :
+ a ypos INCR (letzte zeilenhoehe + durchschuss);
+ zeile ist absatzzeile := LENGTH zeile > 0;
+ pruefe ob markierung links;
+ pruefe ob markierung rechts;
+
+ . neue einrueckung :
+ aktuelle einrueckbreite := einrueckbreite;
+
+ . initialisiere analyse :
+ zeile ist absatzzeile := (zeile SUB LENGTH zeile) = blank;
+ zeile muss geblockt werden := block modus AND NOT zeile ist absatzzeile;
+ erstes token der zeile := token index f + 1;
+ groesste fonthoehe := fonthoehe;
+ aktuelle zeilenhoehe := letzte zeilenhoehe;
+ zeilen laenge := laenge der zeile;
+ anzahl einrueck blanks := zeilen pos - 1;
+ anzahl zeichen := anzahl einrueck blanks;
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := 0;
+ letzter font := a font;
+ letzte modifikationen := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+
+ . laenge der zeile :
+ IF zeile ist absatzzeile
+ THEN LENGTH zeile - 1
+ ELSE LENGTH zeile
+ FI
+.
+ pruefe ob anweisungszeile :
+ IF erstes zeichen ist anweisungszeichen
+ THEN REP analysiere anweisung;
+ IF zeile ist zu ende THEN LEAVE analysiere zeile FI;
+ UNTIL zeichen ist kein anweisungs zeichen PER;
+ FI;
+
+ . erstes zeichen ist anweisungszeichen :
+ pos (zeile, anweisungszeichen, 1, 1) <> 0
+
+ . zeichen ist kein anweisungszeichen :
+ pos (zeile, anweisungszeichen, zeilen pos, zeilen pos) = 0
+
+.
+ pruefe ob markierung links :
+ IF markierung links
+ THEN mark token (mark index l). xpos :=
+ left margin - mark token (mark index l). breite;
+ lege markierungs token an (mark index l);
+ erstes token der zeile := token index f + 1;
+ initialisiere tab variablen;
+ FI;
+
+.
+ analysiere tabellenzeile :
+ anfangs blankmodus := doppel blank;
+ alte zeilenpos := zeilen pos;
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP lege fuell token an wenn noetig;
+ initialisiere tab variablen;
+ SELECT tab typ OF
+ CASE a lpos : linksbuendige spalte
+ CASE a rpos : rechtsbuendige spalte
+ CASE a cpos : zentrierte spalte
+ CASE a dpos : dezimale spalte
+ CASE a bpos : geblockte spalte
+ END SELECT;
+ berechne fuell token wenn noetig;
+ tabulation;
+ PER;
+ analysiere rest der zeile;
+
+ . lege fuell token an wenn noetig :
+ IF fill char <> blank
+ THEN fuellzeichen := fill char;
+ fuellzeichen breite := string breite (fuellzeichen);
+ token zeiger := zeilen pos;
+ erstes fuell token := token index f + 1;
+ lege text token an;
+ letztes fuell token := token index f;
+ a modifikationen fuer x move := a modifikationen
+ FI;
+
+ . berechne fuell token wenn noetig :
+ IF erstes fuell token <> leer
+ THEN IF letztes fuell token <> token index f
+ THEN berechne fuell token;
+ ELSE loesche letzte token;
+ FI;
+ erstes fuell token := leer
+ FI;
+
+ . berechne fuell token :
+ INT VAR anzahl fuellzeichen, fuell breite;
+ token index := erstes fuell token;
+ anzahl fuellzeichen := (tab anfang - t. xpos + left margin)
+ DIV fuellzeichen breite;
+ rest := (tab anfang - t. xpos + left margin)
+ MOD fuellzeichen breite;
+ IF anzahl fuell zeichen > 0
+ THEN fuell text := anzahl fuellzeichen * fuellzeichen;
+ fuell breite := anzahl fuellzeichen * fuellzeichen breite;
+ FOR token index FROM erstes fuell token UPTO letztes fuell token
+ REP t. text := fuell text;
+ t. breite := fuell breite;
+ IF erstes fuell token <> erstes token der zeile
+ THEN t. xpos INCR rest DIV 2;
+ t. modifikationen fuer x move := t. modifikationen;
+ FI;
+ PER;
+ FI;
+
+ . fuell text : par1
+
+ . loesche letzte token :
+ FOR token index FROM letztes fuell token DOWNTO erstes fuell token
+ REP loesche letztes token PER;
+
+ . tabulation :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilenlaenge + 1;
+ LEAVE analysiere tabellenzeile;
+ FI;
+ anzahl zeichen INCR zeilenpos - alte zeilenpos;
+
+ . linksbuendige spalte :
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ bestimme token bis terminator oder zeilenende;
+
+ . rechtsbuendige spalte :
+ bestimme token bis terminator oder zeilenende;
+ schreibe zeile rechtsbuendig (tab position);
+
+ . zentrierte spalte :
+ bestimme token bis terminator oder zeilenende;
+ zentriere zeile (tab position);
+
+ . dezimale spalte :
+ d string := name (d strings, tab param);
+ d code 1 := code (d string SUB 1) + 1;
+ d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ bestimme token bis terminator oder zeilenende;
+ zeichenbreiten (d code 1) := d pitch;
+ d code 1 := leer;
+ schreibe zeile rechtsbuendig (tab position);
+ IF zeichen ist dezimal zeichen
+ THEN IF tab position <> zeilen breite
+ THEN a xpos := left margin + tab position;
+ tab anfang := tab position;
+ FI;
+ bestimme token bis terminator oder zeilenende
+ FI;
+
+ . zeichen ist dezimal zeichen :
+ pos (zeile, d string, zeilen pos) = zeilen pos
+
+ . geblockte spalte :
+ blankmodus := einfach blank;
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende OR naechstes zeichen ist blank
+ THEN blocke spalte wenn noetig;
+ LEAVE geblockte spalte;
+ ELSE dehnbares blank gefunden;
+ FI;
+ PER;
+
+ . blocke spalte wenn noetig :
+ IF letztes zeichen ist kein geschuetztes blank
+ THEN blocke zeile (tab param) FI;
+ blank modus := doppel blank;
+
+ . letztes zeichen ist kein geschuetztes blank :
+ pos (zeile, geschuetztes blank, zeilen pos - 1, zeilen pos - 1) = 0
+ AND NOT within kanji (zeile, zeilen pos - 2)
+
+ . analysiere rest der zeile :
+ blankmodus := keine blankanalyse;
+ zeilen pos := alte zeilenpos;
+ bestimme token bis terminator oder zeilenende;
+
+.
+ test auf aufzaehlung :
+ anfangs blankmodus := einfach blank;
+ bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN LEAVE analysiere zeile nach absatzzeile
+ ELSE aufzaehlung moeglich
+ FI;
+
+ . aufzaehlung moeglich :
+ bestimme letztes zeichen;
+ IF (anzahl zeichen bei aufzaehlung < 2 AND letztes zeichen = "-")
+ OR (anzahl zeichen bei aufzaehlung < 20 AND letztes zeichen = ":")
+ OR (anzahl zeichen bei aufzaehlung < 7
+ AND pos (".)", letztes zeichen) <> 0)
+ OR naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELIF zeile muss geblockt werden
+ THEN dehnbares blank gefunden;
+ FI;
+
+ . bestimme letztes zeichen :
+ token index := token index f;
+ WHILE token index >= erstes token der zeile
+ REP IF token ist text token
+ THEN letztes zeichen := t. text SUB LENGTH t. text;
+ LEAVE bestimme letztes zeichen;
+ FI;
+ token index DECR 1;
+ PER;
+ letztes zeichen := "";
+
+ . letztes zeichen : par1
+
+ . anzahl zeichen bei aufzaehlung :
+ anzahl zeichen - anzahl einrueck blanks
+
+ . token ist text token :
+ t. offset index >= text token
+.
+ analysiere blockzeile nach absatzzeile :
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach absatzzeile
+ ELSE analysiere blank in blockzeile nach absatzzeile
+ FI;
+ PER;
+
+ . analysiere blank in blockzeile nach absatzzeile :
+ IF naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELSE dehnbares blank gefunden;
+ FI;
+
+.
+ analysiere absatzzeile nach absatzzeile :
+ blankmodus := doppel blank;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN LEAVE analysiere absatzzeile nach absatzzeile
+ ELSE tabulator position gefunden
+ FI;
+ PER;
+
+.
+ analysiere blockzeile nach blockzeile :
+ anfangs blankmodus := einfach blank;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach blockzeile
+ ELSE dehnbares blank gefunden
+ FI;
+ PER;
+
+.
+ analysiere absatzzeile nach blockzeile :
+ anfangs blankmodus := keine blankanalyse;
+ bestimme token bis terminator oder zeilenende;
+
+.
+ dehnbares blank gefunden :
+ anzahl zeichen INCR 1;
+ zeilenpos INCR 1;
+ a xpos INCR blankbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF NOT a block token
+ THEN anzahl blanks INCR 1;
+ a block token := TRUE;
+ FI;
+.
+ tabulator position gefunden :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilen laenge + 1;
+ ELSE IF erstes token der zeile > token index f
+ THEN token zeiger := zeilen pos;
+ lege text token an;
+ FI;
+ anzahl zeichen INCR (zeilenpos - alte zeilenpos);
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+ FI;
+
+.
+ pruefe center und right modus :
+ IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ IF right modus THEN schreibe zeile rechtsbuendig (limit) FI;
+.
+ pruefe ob tabulation vorliegt:
+ IF analyse speicher ist nicht leer CAND a xpos > tf. xpos + tf. breite
+ THEN a modifikationen fuer x move := a modifikationen;
+ token zeiger := zeilen pos;
+ lege text token an;
+ FI;
+.
+ werte indexspeicher aus :
+ INT VAR index;
+ IF index zaehler > 0
+ THEN FOR index FROM index zaehler DOWNTO 1
+ REP a ypos DECR (verschiebungen ISUB index) PER;
+ stelle neuen font ein (grosse fonts ISUB 1);
+ loesche index speicher;
+ FI;
+.
+ berechne zeilenhoehe :
+ verschiebung := aktuelle zeilenhoehe + durchschuss;
+ a ypos INCR verschiebung;
+ verschiebe token ypos (verschiebung);
+
+.
+ pruefe ob markierung rechts :
+ IF markierung rechts
+ THEN mark token (mark index r). xpos := left margin + limit;
+ lege markierungs token an (mark index r);
+ FI;
+
+END PROC analysiere zeile;
+
+
+PROC blocke zeile (INT CONST rechter rand) :
+
+rest := rechter rand - zeilen breite;
+IF rest > 0 AND anzahl blanks > 0
+ THEN INT CONST schmaler schritt := rest DIV anzahl blanks,
+ breiter schritt := schmaler schritt + 1,
+ anzahl breite schritte := rest MOD anzahl blanks;
+ IF rechts
+ THEN blocke token xpos (breiter schritt, schmaler schritt,
+ anzahl breite schritte);
+ rechts := FALSE;
+ ELSE blocke token xpos (schmaler schritt, breiter schritt,
+ anzahl blanks - anzahl breite schritte);
+ rechts := TRUE;
+ FI;
+ a xpos INCR ( breiter schritt * anzahl breite schritte +
+ schmaler schritt * (anzahl blanks - anzahl breite schritte) );
+FI;
+
+END PROC blocke zeile;
+
+
+PROC zentriere zeile (INT CONST zentrier pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := zentrier pos - tab anfang -
+ (zeilen breite - tab anfang) DIV 2;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+center modus := FALSE;
+
+END PROC zentriere zeile;
+
+
+PROC schreibe zeile rechtsbuendig (INT CONST rechte pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := rechte pos - zeilen breite;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+right modus := FALSE;
+
+
+END PROC schreibe zeile rechtsbuendig;
+
+
+PROC bestimme token bis terminator oder zeilenende :
+
+token zeiger := zeilen pos;
+REP stranalyze (zeichenbreiten, a breite, max breite,
+ zeile, zeilen pos, zeilen laenge,
+ ausgang);
+ zeilen pos INCR 1;
+ IF ausgang = blank ausgang
+ THEN analysiere blank
+ ELIF ausgang = anweisungs ausgang
+ THEN anweisung gefunden
+ ELIF ausgang = d code ausgang
+ THEN analysiere d string
+ ELIF ausgang = erweiterungs ausgang
+ THEN erweiterung gefunden
+ ELSE terminator oder zeilenende gefunden
+ FI;
+PER;
+
+. analysiere blank :
+ IF blankmodus = einfach blank OR
+ (blankmodus = doppel blank AND naechstes zeichen ist blank)
+ THEN terminator oder zeilenende gefunden
+ ELSE a breite INCR blankbreite;
+ zeilenpos INCR 1;
+ FI;
+
+. analysiere d string :
+ IF pos (zeile, d string, zeilen pos) = zeilen pos
+ THEN terminator oder zeilenende gefunden
+ ELSE IF d pitch = maxint
+ THEN erweiterung gefunden
+ ELIF d pitch < 0
+ THEN a breite INCR (d pitch XOR - maxint - 1);
+ zeilen pos INCR 2;
+ ELSE a breite INCR d pitch;
+ zeilenpos INCR 1;
+ FI;
+ FI;
+
+. erweiterung gefunden :
+ a breite INCR extended char pitch (a font, zeile SUB zeilen pos,
+ zeile SUB zeilen pos + 1);
+ zeilen pos INCR 2;
+
+. anweisung gefunden :
+ gegebenfalls neues token gefunden;
+ analysiere anweisung;
+ IF zeile ist zu ende
+ THEN LEAVE bestimme token bis terminator oder zeilenende FI;
+ token zeiger := zeilenpos;
+
+. terminator oder zeilenende gefunden :
+ IF ausgang = null ausgang THEN zeilen laenge DECR 1 FI;
+ gegebenfalls neues token gefunden;
+ LEAVE bestimme token bis terminator oder zeilenende;
+
+ . gegebenfalls neues token gefunden :
+ IF token zeiger < zeilenpos THEN lege text token an FI;
+
+END PROC bestimme token bis terminator oder zeilen ende;
+
+
+PROC analysiere anweisung :
+
+ bestimme anweisung;
+ IF anweisung ist kommando
+ THEN lege kommando token an;
+ ELSE werte anweisung aus;
+ FI;
+
+ . anweisungsanfang : token zeiger
+
+ . anweisungsende : zeilen pos - 2
+
+ . erstes zeichen : par1
+
+. bestimme anweisung :
+ anweisungsanfang := zeilenpos + 1;
+ zeilen pos := pos (zeile, anweisungszeichen, anweisungsanfang, zeilenlaenge);
+ IF zeilenpos = 0
+ THEN zeilenpos := anweisungsanfang - 1;
+ replace (zeile, zeilenpos, geschuetztes anweisungszeichen);
+ LEAVE analysiere anweisung;
+ FI;
+ zeilen pos INCR 1;
+ anweisung := subtext (zeile, anweisungsanfang, anweisungsende);
+ erstes zeichen := anweisung SUB 1;
+
+. anweisung ist kommando :
+ IF erstes zeichen = quote
+ THEN scan (anweisung);
+ next symbol (anweisung, symbol type);
+ next symbol (par2, naechster symbol type);
+ IF symbol type <> text type OR naechster symbol type <> eof type
+ THEN LEAVE analysiere anweisung FI;
+ TRUE
+ ELIF erstes zeichen = druckerkommando zeichen
+ THEN delete char (anweisung, 1);
+ TRUE
+ ELSE FALSE
+ FI
+
+.
+ werte anweisung aus :
+ analyze command (anweisungs liste, anweisung, number type,
+ anweisungs index, anzahl params, par1, par2);
+ SELECT anweisungs index OF
+ CASE a type : type anweisung
+ CASE a on : on anweisung
+ CASE a off : off anweisung
+ CASE a ub, a fb : ub fb anweisung
+ CASE a ue, a fe : ue fe anweisung
+ CASE a center : center anweisung
+ CASE a right : right anweisung
+ CASE a up, a down : index anweisung
+ CASE a end up or down : end index anweisung
+ CASE a bsp : bsp anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a mark : mark anweisung
+ CASE a markend : markend anweisung
+ OTHERWISE : IF anweisungs index > 0 THEN speichere anweisung FI;
+ END SELECT;
+
+ . type anweisung :
+ change all (par1, " ", "");
+ stelle neuen font ein (font (par1));
+ groesste fonthoehe := max (groesste fonthoehe, fonthoehe);
+ a modifikationen := 0;
+ IF nicht innerhalb eines indexes THEN berechne aktuelle zeilenhoehe FI;
+
+ . nicht innerhalb eines indexes :
+ index zaehler = 0
+
+ . berechne aktuelle zeilenhoehe :
+ IF linefeed faktor >= 1.0
+ THEN aktuelle zeilenhoehe := max (groesste fonthoehe,
+ letzte zeilenhoehe);
+ ELSE aktuelle zeilenhoehe := max (aktuelle zeilenhoehe,
+ letzte zeilenhoehe);
+ FI;
+
+ . on anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN set bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . off anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN reset bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . ub fb anweisung :
+ IF anweisungs index = a ub
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ on anweisung;
+
+ . ue fe anweisung :
+ IF anweisungs index = a ue
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ off anweisung;
+
+ . center anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ AND NOT right modus
+ THEN center modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . right anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ THEN IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ right modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . index anweisung :
+ INT CONST grosser font := a font, grosse fonthoehe := fonthoehe;
+ INT VAR kleiner font;
+ IF next smaller font exists (grosser font, kleiner font)
+ THEN stelle neuen font ein (kleiner font) FI;
+ IF font hoehe < grosse fonthoehe
+ THEN berechne verschiebung fuer kleinen font
+ ELSE berechne verschiebung fuer grossen font
+ FI;
+ a ypos INCR verschiebung;
+ merke grossen font und verschiebung;
+
+ . berechne verschiebung fuer kleinen font :
+ IF anweisungs index = a down
+ THEN verschiebung := 15 PROZENT grosse fonthoehe;
+ ELSE verschiebung := - ( 9 PROZENT grosse fonthoehe )
+ - (grosse fonthoehe - fonthoehe);
+ FI;
+
+ . berechne verschiebung fuer grossen font :
+ IF anweisungs index = a down
+ THEN verschiebung := 25 PROZENT fonthoehe;
+ ELSE verschiebung := - (50 PROZENT fonthoehe);
+ FI;
+
+ . merke grossen font und verschiebung :
+ index zaehler INCR 1;
+ grosse fonts CAT grosser font;
+ verschiebungen CAT verschiebung;
+ IF index zaehler = 1
+ THEN alter blankmodus := blankmodus;
+ blankmodus := keine blankanalyse;
+ FI;
+
+ . end index anweisung :
+ IF index zaehler > 0
+ THEN schalte auf groesseren font zurueck;
+ FI;
+
+ . schalte auf groesseren font zurueck :
+ a ypos DECR (verschiebungen ISUB index zaehler);
+ stelle neuen font ein (grosse fonts ISUB index zaehler);
+ IF index zaehler = 1
+ THEN blankmodus := alter blankmodus;
+ FI;
+ index zaehler DECR 1;
+ verschiebungen := subtext (verschiebungen, 1, 2 * index zaehler);
+ grosse fonts := subtext (grosse fonts, 1, 2 * index zaehler);
+
+ . bsp anweisung :
+ INT VAR breite davor, breite dahinter;
+ IF anweisungs anfang - 2 >= 1 AND anweisungs ende + 2 <= zeilen laenge
+ THEN IF is kanji esc (zeile SUB anweisungs anfang - 3)
+ THEN zeichen davor := subtext (zeile, anweisungs anfang - 3,
+ anweisungs anfang - 2);
+ ELSE zeichen davor := zeile SUB anweisungs anfang - 2;
+ FI;
+ IF is kanji esc (zeile SUB anweisungs ende + 2)
+ THEN zeichen dahinter := subtext (zeile, anweisungs ende + 2,
+ anweisungs ende + 3 );
+ ELSE zeichen dahinter := zeile SUB anweisungs ende + 2;
+ FI;
+ IF pos (" #", zeichen davor) = 0 AND pos (" #", zeichen dahinter) = 0
+ THEN breite davor := char pitch (a font, zeichen davor);
+ breite dahinter := char pitch (a font, zeichen dahinter);
+ IF breite davor < breite dahinter THEN vertausche zeichen FI;
+ lege token fuer zeichen dahinter an;
+ a xpos INCR (breite davor - breite dahinter) DIV 2;
+ FI;
+ FI;
+
+ . zeichen davor : par1
+ . zeichen dahinter : par2
+
+ . vertausche zeichen :
+ change (zeile, anweisungs anfang - 2 - LENGTH zeichen davor + 1,
+ anweisungs anfang - 2, zeichen dahinter);
+ change (zeile, anweisungs ende + 2,
+ anweisungs ende + 2 + LENGTH zeichen dahinter - 1, zeichen davor);
+ change (tf. text, LENGTH tf. text - LENGTH zeichen davor + 1,
+ LENGTH tf. text, zeichen dahinter);
+ tf. breite INCR (breite dahinter - breite davor);
+ a xpos INCR (breite dahinter - breite davor);
+ int param := breite davor;
+ breite davor := breite dahinter;
+ breite dahinter := int param;
+
+ . lege token fuer zeichen dahinter an :
+ token zeiger := zeilen pos;
+ a breite := breite dahinter;
+ zeilen pos INCR LENGTH zeichen dahinter;
+ a xpos DECR (breite davor + breite dahinter) DIV 2;
+ lege text token an;
+ anzahl zeichen DECR 1;
+
+ . fillchar anweisung :
+ IF par1 = "" THEN par1 := " " FI;
+ fill char := par1;
+ speichere anweisung;
+
+ . mark anweisung :
+ IF par1 <> ""
+ THEN mark index l := (alter mark index l MOD 2) + 1;
+ neue markierung (par1, mark index l);
+ ELSE mark index l := 0;
+ FI;
+ IF par2 <> ""
+ THEN mark index r := (alter mark index r MOD 2) + 3;
+ neue markierung (par2, mark index r);
+ ELSE mark index r := 0;
+ FI;
+
+ . markend anweisung :
+ loesche markierung;
+
+ . speichere anweisung :
+ anweisungs zaehler INCR 1;
+ anweisungs indizes CAT anweisungs index;
+ IF par1 <> ""
+ THEN insert (params1, par1);
+ params1 zeiger CAT highest entry (params1);
+ ELSE params1 zeiger CAT 0;
+ FI;
+ IF par2 <> ""
+ THEN insert (params2, par2);
+ params2 zeiger CAT highest entry (params2);
+ ELSE params2 zeiger CAT 0;
+ FI;
+
+END PROC analysiere anweisung;
+
+
+PROC stelle neuen font ein (INT CONST font nr ) :
+
+ IF font nr <> a font THEN neuer font FI;
+
+ . neuer font :
+ a font := max (1, font nr);
+ get font (a font, einrueckbreite, font durchschuss, font hoehe, font tiefe,
+ zeichenbreiten);
+ font hoehe INCR (font durchschuss + font tiefe);
+ letzte zeilenhoehe := neue zeilenhoehe;
+ blankbreite := zeichenbreiten (blank code 1);
+ zeichenbreiten (blank code 1) := blank ausgang;
+ zeichenbreiten (anweisungs zeichen code 1) := anweisungs ausgang;
+ font offsets := y offsets (a font);
+ offsets := LENGTH font offsets > 2;
+ IF d code 1 <> leer
+ THEN d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ FI;
+
+END PROC stelle neuen font ein;
+
+
+INT OP PROZENT (INT CONST prozent, wert) :
+
+ (wert * prozent + 99) DIV 100
+
+END OP PROZENT;
+
+
+PROC neue markierung (TEXT CONST text, INT CONST mark index) :
+
+ mark token (mark index). text := text;
+ mark token (mark index). breite := string breite (text);
+ mark token (mark index). font := a font;
+ mark token (mark index). modifikationen := a modifikationen;
+
+END PROC neue markierung;
+
+
+INT PROC string breite (TEXT CONST string) :
+
+ INT VAR summe := 0, pos := 1;
+ REP stranalyze (zeichenbreiten, summe, max breite, string, pos, maxint, ausgang);
+ IF ausgang = erweiterungs ausgang
+ THEN summe INCR extended char pitch (a font,
+ string SUB pos+1, string SUB pos+2);
+ pos INCR 3;
+ ELIF ausgang = blank ausgang
+ THEN summe INCR blankbreite;
+ pos INCR 2;
+ ELIF ausgang = anweisungs ausgang
+ THEN summe INCR char pitch (a font, anweisungszeichen);
+ pos INCR 2;
+ ELSE LEAVE string breite WITH summe
+ FI;
+ PER;
+ 0
+
+END PROC string breite;
+
+(*******************************************************************)
+
+PROC lege text token an :
+
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage text token (tf);
+ IF offsets THEN lege offsets an (font offsets) FI;
+ stranalyze (zeichen zaehler, anzahl zeichen, max int,
+ zeile, token zeiger, zeilen pos - 1, ausgang);
+ a xpos INCR a breite;
+ a breite := 0;
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege text token an;
+
+
+PROC uebertrage text token (TOKEN VAR tf) :
+
+ tf. text := subtext (zeile, token zeiger, zeilenpos - 1);
+ tf. xpos := a xpos;
+ tf. breite := a breite;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := text token;
+ tf. block token := a block token;
+
+END PROC uebertrage text token;
+
+
+PROC lege kommando token an :
+
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage kommando token (tf);
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege kommando token an;
+
+
+PROC uebertrage kommando token (TOKEN VAR tf) :
+
+ tf. text := anweisung;
+ tf. breite := 0;
+ tf. xpos := a xpos;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := kommando token;
+ tf. block token := a block token;
+
+END PROC uebertrage kommando token;
+
+
+PROC lege markierungs token an (INT CONST mark index) :
+
+ aktuelle ypos := a ypos + (mark font offsets ISUB 1);
+ neuer token index;
+ tf := mark token (mark index);
+ IF mark offsets THEN lege offsets an (mark font offsets) FI;
+
+ . mark font offsets : y offsets (mark token (mark index). font)
+
+ . mark offsets : LENGTH mark font offsets > 2
+
+END PROC lege markierungs token an;
+
+
+PROC lege offsets an (TEXT CONST offsets) :
+
+ INT CONST anzahl offsets := LENGTH offsets DIV 2;
+ offset token := tf;
+ offset token. block token := FALSE;
+ reset bit (offset token. modifikationen, underline bit);
+ FOR index FROM 2 UPTO anzahl offsets
+ REP aktuelle ypos := a ypos + (offsets ISUB index);
+ neuer token index;
+ tf := offset token;
+ tf. offset index := index;
+ PER;
+
+END PROC lege offsets an;
+
+
+PROC neuer token index :
+
+IF erster ypos index a = 0
+ THEN erste ypos
+ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei gleicher ypos
+ ELSE fuege neue ypos ein
+FI;
+
+ . erste ypos :
+ ypos index f INCR 1;
+ erster ypos index a := ypos index f;
+ letzter ypos index a := ypos index f;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := 0;
+ erstes token bei neuer ypos;
+
+ . fuege neue ypos ein :
+ letztes token bei gleicher ypos;
+ IF ya. ypos > aktuelle ypos
+ THEN richtige ypos ist oberhalb
+ ELSE richtige ypos ist unterhalb
+ FI;
+
+ . richtige ypos ist oberhalb :
+ REP ypos index a := ya. vorheriger ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos vor erstem ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos < aktuelle ypos
+ THEN fuege ypos nach ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ FI;
+ PER;
+
+ . richtige ypos ist unterhalb :
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos nach letztem ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos > aktuelle ypos
+ THEN fuege ypos vor ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ FI;
+ PER;
+
+ . fuege ypos vor erstem ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := erster ypos index a;
+ erster ypos index a := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := ypos index a;
+ yf. naechster ypos index := ya. naechster ypos index;
+ ya. naechster ypos index := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos vor ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := ypos index a;
+ yf. vorheriger ypos index := ya. vorheriger ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach letztem ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := 0;
+ yf. vorheriger ypos index := letzter ypos index a;
+ letzter ypos index a := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+END PROC neuer token index;
+
+
+PROC erstes token bei neuer ypos :
+ token index f INCR 1;
+ ypos index a := ypos index f;
+ ya. erster token index := token index f;
+ ya. ypos := aktuelle ypos;
+END PROC erstes token bei neuer ypos;
+
+
+PROC neues token bei neuer ypos :
+ token index f INCR 1;
+ ya. ypos := aktuelle ypos;
+ token index := ya. letzter token index;
+ t. naechster token index := token index f;
+END PROC neues token bei neuer ypos;
+
+
+PROC neues token bei gleicher ypos :
+ tf. naechster token index := token index f + 1;
+ token index f INCR 1;
+END PROC neues token bei gleicher ypos;
+
+
+PROC letztes token bei gleicher ypos :
+ tf. naechster token index := 0;
+ ya. letzter token index := token index f;
+END PROC letztes token bei gleicher ypos;
+
+
+PROC loesche letztes token :
+
+ IF token index f = ya. erster token index
+ THEN loesche ypos
+ ELSE token index f DECR 1;
+ FI;
+
+ . loesche ypos :
+ kette vorgaenger um;
+ kette nachfolger um;
+ bestimme letzten ypos index;
+
+ . kette vorgaenger um :
+ ypos index := ya. vorheriger ypos index;
+ IF ypos index = 0
+ THEN erster ypos index a := ya. naechster ypos index;
+ ELSE y. naechster ypos index := ya. naechster ypos index;
+ FI;
+
+ . kette nachfolger um :
+ ypos index := ya. naechster ypos index;
+ IF ypos index = 0
+ THEN letzter ypos index a := ya. vorheriger ypos index;
+ ELSE y. vorheriger ypos index := ya. vorheriger ypos index;
+ FI;
+
+ . bestimme letzten ypos index :
+ IF ypos index a = ypos index f THEN ypos index f DECR 1 FI;
+ token index f DECR 1;
+ ypos index a := letzter ypos index a;
+ WHILE ypos index a <> 0
+ CAND ya. letzter token index <> token index f
+ REP ypos index a := ya. vorheriger ypos index PER;
+
+END PROC loesche letztes token;
+
+
+PROC blocke token xpos (INT CONST dehnung 1, dehnung 2,
+ anzahl dehnungen fuer dehnung 1 ) :
+
+ INT VAR dehnung := 0, anzahl dehnungen := 0;
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP erhoehe token xpos bei block token;
+ t. xpos INCR dehnung;
+ token index INCR 1;
+ PER;
+
+ . erhoehe token xpos bei block token :
+ IF t. block token
+ THEN IF anzahl dehnungen < anzahl dehnungen fuer dehnung 1
+ THEN anzahl dehnungen INCR 1;
+ dehnung INCR dehnung 1;
+ ELSE dehnung INCR dehnung 2;
+ FI;
+ FI;
+
+END PROC blocke token xpos;
+
+
+PROC verschiebe token xpos (INT CONST verschiebung) :
+
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP t. xpos INCR verschiebung;
+ token index INCR 1;
+ PER;
+
+END PROC verschiebe token xpos;
+
+
+PROC verschiebe token ypos (INT CONST verschiebung) :
+
+ ypos index := erster ypos index a;
+ WHILE ypos index <> 0
+ REP y. ypos INCR verschiebung;
+ ypos index := y. naechster ypos index;
+ PER;
+
+END PROC verschiebe token ypos;
+
+
+PROC sortiere neue token ein :
+
+IF analysespeicher ist nicht leer
+ THEN IF druckspeicher ist nicht leer
+ THEN sortiere neue token in sortierte liste ein
+ ELSE sortierte liste ist leer
+ FI;
+FI;
+
+. sortierte liste ist leer :
+ IF erster ypos index a <> 0
+ THEN erster ypos index d := erster ypos index a;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ FI;
+
+. sortiere neue token in sortierte liste ein :
+ gehe zum ersten neuen token;
+ bestimme erste einsortierposition;
+ WHILE es gibt noch neue token
+ REP IF ypos index d = 0
+ THEN haenge neue token ans ende der sortierten liste
+ ELIF ya. ypos > yd. ypos
+ THEN naechste ypos der sortierten liste
+ ELIF ya. ypos = yd. ypos
+ THEN neues token auf gleicher ypos
+ ELSE neue token vor ypos
+ FI;
+ PER;
+
+ . gehe zum ersten neuen token :
+ ypos index a := erster ypos index a;
+
+ . bestimme erste einsortierposition :
+ WHILE ypos index d <> 0 CAND ya. ypos < yd. ypos
+ REP ypos index d := yd. vorheriger ypos index PER;
+ IF ypos index d = 0 THEN erste neue token vor listen anfang FI;
+
+ . erste neue token vor listen anfang :
+ ypos index d := erster ypos index d;
+ erster ypos index d := erster ypos index a;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE erste neue token vor listen anfang
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE erste neue token vor listen anfang
+ FI;
+ PER;
+
+ . es gibt noch neue token :
+ ypos index a <> 0
+
+ . haenge neue token ans ende der sortierten liste :
+ ypos index d := letzter ypos index d;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ ypos index a := 0;
+
+ . naechste ypos der sortierten liste :
+ ypos index d := yd. naechster ypos index;
+
+ . neues token auf gleicher ypos :
+ token index := yd. letzter token index;
+ t . naechster token index := ya. erster token index;
+ yd. letzter token index := ya. letzter token index;
+ ypos index a := ya. naechster ypos index;
+ ypos index d := yd. naechster ypos index;
+ IF ypos index d = 0 THEN ypos index d := letzter ypos index d FI;
+
+ . neue token vor ypos :
+ verkette ya mit vorherigem yd;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE neue token vor ypos
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE neue token vor ypos
+ FI;
+ PER;
+
+
+. verkette ya mit vorherigem yd :
+ index := ypos index d;
+ ypos index d := yd. vorheriger ypos index;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ ypos index d := index;
+
+. verkette letztes ya mit yd :
+ ypos index a := letzter ypos index a;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := 0;
+
+. verkette vorheriges ya mit yd :
+ index := ypos index a;
+ ypos index a := ya. vorheriger ypos index;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := index;
+
+. verkette ya mit yd :
+ verkette vorheriges ya mit yd;
+ neues token auf gleicher ypos;
+
+END PROC sortiere neue token ein;
+
+(***************************************************************)
+
+PROC drucke tokenspeicher
+ (INT CONST max ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF druckspeicher ist nicht leer
+ THEN gehe zur ersten ypos;
+ WHILE yd. ypos <= max ypos
+ REP drucke token bei ypos;
+ gehe zur naechsten ypos;
+ PER;
+ loesche gedruckte token;
+FI;
+
+. gehe zur ersten ypos :
+ ypos index d := erster ypos index d;
+
+. drucke token bei ypos :
+ IF yd. ypos >= - y start
+ THEN druck durchgang;
+ IF bold pass THEN fett durchgang FI;
+ IF underline pass THEN unterstreich durchgang FI;
+ FI;
+
+ . bold pass : bit (pass, bold bit)
+
+ . underline pass : bit (pass, underline bit)
+
+. gehe zur naechsten ypos :
+ IF ypos index d = letzter ypos index d
+ THEN loesche druckspeicher;
+ LEAVE drucke tokenspeicher;
+ FI;
+ ypos index d := yd. naechster ypos index;
+
+. loesche gedruckte token :
+ erster ypos index d := ypos index d;
+ yd. vorheriger ypos index := 0;
+
+.
+ druck durchgang :
+ verschiebung := yd. ypos - d ypos;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ gehe zum ersten token dieser ypos;
+ REP drucke token UNTIL kein token mehr vorhanden PER;
+ gib cr aus;
+
+ . drucke token :
+ IF NOT token passt in zeile THEN berechne token teil FI;
+ font wechsel wenn noetig;
+ x move mit modifikations ueberpruefung;
+ IF token ist text token
+ THEN gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ ELSE gib kommando token aus
+ FI;
+
+ . gib kommando token aus :
+ execute (write cmd, d token. text, 1, LENGTH d token. text)
+
+ . berechne token teil :
+ INT CONST fuenf punkte := 5 * char pitch (d token. font, punkt);
+ INT VAR token pos, token breite, anzahl punkte, zeichen laenge, zeichen breite;
+ IF d token. xpos < - x start
+ AND d token. xpos + d token. breite > - x start
+ THEN berechne token teil von links
+ ELIF d token. xpos < papierbreite
+ AND d token. xpos + d token. breite > papierbreite
+ THEN berechne token teil nach rechts
+ ELSE LEAVE drucke token
+ FI;
+
+ . berechne token teil von links :
+ rest := min (x size, d token. xpos + d token. breite + x start);
+ d token. xpos := - x start;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := LENGTH d token. text + 1;
+ token breite := fuenf punkte;
+ berechne token teil breite von hinten;
+ change (d token. text, 1, token pos - 1, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von hinten :
+ WHILE naechstes zeichen passt noch davor
+ REP token breite INCR zeichen breite;
+ token pos DECR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch davor :
+ IF within kanji (d token. text, token pos - 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos - zeichen laenge, token pos - 1));
+ token breite + zeichen breite < rest
+
+ . berechne token teil nach rechts :
+ rest := papier breite - d token. xpos;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := 0;
+ token breite := fuenf punkte;
+ berechne token teil breite von vorne;
+ change (d token. text, token pos + 1, LENGTH d token. text, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von vorne :
+ WHILE naechstes zeichen passt noch dahinter
+ REP token breite INCR zeichen breite;
+ token pos INCR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch dahinter :
+ IF is kanji esc (d token. text SUB token pos + 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos + 1, token pos + zeichen laenge));
+ token breite + zeichen breite < rest
+
+.
+ fett durchgang :
+ reset bit (pass, bold bit);
+ gehe zum ersten token dieser ypos;
+ REP gib token nochmal aus UNTIL kein token mehr vorhanden PER;
+ schalte modifikationen aus wenn noetig;
+ gib cr aus;
+
+ . gib token nochmal aus :
+ INT CONST min verschiebung := bold offset (d token. font);
+ d token. xpos INCR min verschiebung;
+ IF bit (d token. modifikationen, bold bit) AND
+ token passt in zeile AND token ist text token
+ THEN verschiebung := d token. xpos - d xpos;
+ font wechsel wenn noetig;
+ schalte italics ein wenn noetig;
+ x move wenn noetig;
+ gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d token. xpos DECR min verschiebung;
+
+ . schalte italics ein wenn noetig :
+ IF bit (d token. modifikationen, italics bit)
+ THEN neue modifikationen := modifikations werte (italics bit + 1);
+ schalte modifikationen ein wenn noetig;
+ ELSE schalte modifikationen aus wenn noetig;
+ FI;
+
+.
+ unterstreich durchgang :
+ INT VAR l xpos := 0;
+ reset bit (pass, underline bit);
+ schalte modifikationen aus wenn noetig;
+ gehe zum ersten token dieser ypos;
+ REP unterstreiche token UNTIL kein token mehr vorhanden PER;
+ gib cr aus;
+
+ . unterstreiche token :
+ IF token muss unterstrichen werden AND
+ token passt in zeile AND token ist text token
+ THEN font wechsel wenn noetig;
+ berechne x move laenge;
+ x move wenn noetig;
+ berechne unterstreich laenge;
+ unterstreiche;
+ FI;
+ l xpos := d token. xpos + d token. breite;
+
+ . token muss unterstrichen werden :
+ bit (d token. modifikationen, underline bit) OR
+ bit (d token. modifikationen fuer x move, underline bit)
+
+ . berechne x move laenge :
+ IF bit (d token. modifikationen fuer x move, underline bit)
+ THEN verschiebung := l xpos - d xpos
+ ELSE verschiebung := d token. xpos - d xpos
+ FI;
+
+ . berechne unterstreich laenge :
+ INT VAR unterstreich verschiebung;
+ IF bit (d token. modifikationen, underline bit)
+ THEN unterstreich verschiebung := d token. xpos +
+ d token. breite - d xpos
+ ELSE unterstreich verschiebung := d token. xpos - d xpos
+ FI;
+
+
+. gehe zum ersten token dieser ypos :
+ token index := yd. erster token index;
+ d token := t;
+
+. kein token mehr vorhanden :
+ token index := d token. naechster token index;
+ IF token index = 0
+ THEN TRUE
+ ELSE d token := t;
+ FALSE
+ FI
+
+. token ist text token :
+ d token. offset index >= text token
+
+. token passt in zeile :
+ d token. xpos >= - x start AND
+ d token. xpos + d token. breite <= papier breite
+
+. font wechsel wenn noetig :
+ IF d token. font <> d font
+ THEN font wechsel (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen aus wenn noetig :
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. x move wenn noetig :
+ IF verschiebung <> 0
+ THEN x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+.
+ x move mit modifikations ueberpruefung :
+ verschiebung := d token. xpos - d xpos;
+ IF verschiebung <> 0
+ THEN neue modifikationen := d token. modifikationen fuer x move;
+ schalte modifikationen ein wenn noetig;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ neue modifikationen := d token. modifikationen;
+ schalte modifikationen ein wenn noetig;
+
+.
+ unterstreiche :
+ IF unterstreich verschiebung > 0
+ THEN disable stop;
+ d xpos INCR unterstreich verschiebung;
+ execute (draw, "", unterstreich verschiebung, 0);
+ IF is error
+ THEN unterstreiche nach cr;
+ FI;
+ enable stop;
+ FI;
+
+ . unterstreiche nach cr :
+ clear error;
+ d xpos DECR unterstreich verschiebung;
+ verschiebung := d xpos;
+ gib cr aus;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ d xpos INCR unterstreich verschiebung;
+ execute (draw, "", unterstreich verschiebung, 0);
+ IF is error
+ THEN clear error;
+ d xpos DECR unterstreich verschiebung;
+ gib cr aus;
+ LEAVE unterstreich durchgang;
+ FI;
+
+END PROC drucke tokenspeicher;
+
+PROC y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ IF verschiebung <> 0
+ THEN disable stop;
+ d ypos INCR verschiebung;
+ execute (move, "", 0, verschiebung);
+ IF is error
+ THEN clear error;
+ d ypos DECR verschiebung;
+ verschiebung := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC y move;
+
+
+PROC x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d xpos INCR verschiebung;
+ execute (move, "", verschiebung, 0);
+ IF is error
+ THEN fuehre x move nach cr aus
+ FI;
+
+ . fuehre x move nach cr aus :
+ clear error;
+ schalte modifikationen aus wenn noetig;
+ gib cr aus;
+ IF d xpos <> 0
+ THEN execute (move, "", d xpos, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI
+ FI;
+ schalte modifikationen ein wenn noetig;
+
+ . gib cr aus :
+ execute (carriage return, "", d xpos - verschiebung, 0);
+
+ . schalte modifikationen aus wenn noetig :
+ neue modifikationen := d modifikationen;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+END PROC x move;
+
+
+PROC schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d modifikationen := neue modifikationen;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss eingeschaltet werden
+ FI;
+ PER;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss eingeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (on, "", modifikations werte (index), 0);
+ IF is error
+ THEN clear error;
+ reset bit (modifikations modus, modifikations bit);
+ set bit (pass, modifikations bit);
+ FI;
+ ELSE set bit (pass, modifikations bit);
+ FI;
+
+END PROC schalte modifikationen ein;
+
+
+PROC schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss ausgeschaltet werden
+ FI;
+ PER;
+ d modifikationen := 0;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss ausgeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (off, "", modifikations werte (index), 0);
+ IF is error THEN clear error FI;
+ FI;
+
+END PROC schalte modifikationen aus;
+
+
+PROC font wechsel
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d font := d token. font;
+ get replacements (d font, replacements, replacement tabelle);
+ execute (type, "", d font, 0);
+ IF is error THEN font wechsel nach cr FI;
+ enable stop;
+
+ . font wechsel nach cr :
+ clear error;
+ verschiebung := d xpos;
+ gib cr aus;
+ execute (type, "", d font, 0);
+ IF NOT is error
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ x move
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+END PROC font wechsel;
+
+
+PROC gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ INT CONST token laenge := LENGTH d token. text;
+ INT VAR token pos := 1, alte token pos, summe := 0;
+ IF token laenge > 0
+ THEN REP alte token pos := token pos;
+ stranalyze (replacement tabelle, summe, 0,
+ d token. text, token pos, token laenge,
+ ausgang);
+ IF ausgang = 0
+ THEN gib token rest aus;
+ ELSE gib token teil aus;
+ gib ersatzdarstellung aus;
+ FI;
+ PER;
+ FI;
+
+ . gib token rest aus :
+ IF token laenge >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token laenge) FI;
+ d xpos INCR d token. breite;
+ LEAVE gib text token aus;
+
+ . gib token teil aus :
+ IF token pos >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token pos) FI;
+
+ . gib ersatzdarstellung aus :
+ IF ausgang = maxint
+ THEN ersatzdarstellung := extended replacement (d token. font,
+ d token. text SUB token pos + 1, d token. text SUB token pos + 2);
+ execute (write text, ersatzdarstellung, 1, LENGTH ersatzdarstellung);
+ tokenpos INCR 3;
+ ELSE IF ausgang < 0
+ THEN ausgang := ausgang XOR (-32767-1);
+ token pos INCR 1;
+ FI;
+ execute (write text, replacements, ausgang + 1, ausgang + code (replacements SUB ausgang));
+ token pos INCR 2;
+ FI;
+
+ . ersatzdarstellung : par1
+
+END PROC gib text token aus;
+
+
+PROC schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+enable stop;
+gebe restliche token aus;
+seiten ende kommando;
+
+. gebe restliche token aus :
+ IF erster ypos index d <> 0
+ THEN drucke tokenspeicher (maxint,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ rest := papier laenge - d ypos;
+
+. seiten ende kommando :
+ seite ist offen := FALSE;
+ a ypos := top margin;
+ aktuelle spalte := 1;
+ close (page, rest);
+
+END PROC schliesse seite ab;
+
+
+PROC eroeffne seite (INT CONST x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open ) :
+
+IF vor erster seite THEN eroeffne druck FI;
+seiten anfang kommando;
+initialisiere neue seite;
+
+. eroeffne druck :
+ open (document, x size, y size);
+ vor erster seite := FALSE;
+ d font := -1;
+ d modifikationen := 0;
+
+. seiten anfang kommando :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+
+. initialisiere neue seite :
+ INT CONST dif left margin := x wanted - x start - left margin + indentation,
+ dif top margin := y wanted - y start - top margin;
+ IF dif left margin <> 0
+ THEN erstes tab token := 1;
+ verschiebe token xpos (dif left margin);
+ a xpos INCR dif left margin;
+ left margin INCR dif left margin;
+ FI;
+ IF dif top margin <> 0
+ THEN verschiebe token ypos (dif top margin);
+ a ypos INCR dif top margin;
+ top margin INCR dif top margin;
+ FI;
+ d xpos := 0;
+ d ypos := 0;
+ IF seitenlaenge <= papierlaenge
+ THEN seitenlaenge := top margin + pagelength;
+ ELSE seitenlaenge DECR papierlaenge;
+ FI;
+ papierlaenge := y size - y start;
+ papierbreite := x size - x start;
+
+END PROC eroeffne seite;
+
+(****************************************************************)
+
+PROC elan fuss und kopf (INT CONST fuss oder kopf,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF fuss oder kopf <= 0 THEN elan fuss FI;
+IF fuss oder kopf >= 0 THEN elan kopf FI;
+
+.
+ elan fuss :
+ y move zur fusszeile;
+ drucke elan fuss;
+ close page cmd;
+
+. y move zur fusszeile :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ verschiebung := rest auf seite - font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. drucke elan fuss :
+ IF bottom label = ""
+ THEN seiten nr := ""
+ ELSE seiten nr := bottom label;
+ seiten nr CAT "/";
+ FI;
+ seiten nr CAT text (gedruckte seiten);
+ elan text := seiten nr;
+ elan text CAT " ";
+ elan text cat blanks ((max zeichen fuss - LENGTH dateiname) DIV 2 - LENGTH elan text);
+ elan text CAT dateiname;
+ elan text cat blanks (max zeichen fuss - LENGTH seiten nr - LENGTH elan text - 3);
+ elan text CAT " ";
+ elan text CAT seiten nr;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . seiten nr : par1
+
+. close page cmd :
+ close (page, papierlaenge - d ypos);
+ seite ist offen := FALSE;
+
+.
+ elan kopf :
+ open page cmd ;
+ y move zur kopfzeile;
+ drucke elan kopf;
+
+. open page cmd :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ IF fuss oder kopf = 1 THEN execute (type, "", d font, 0) FI;
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+ top margin := y wanted - y start;
+ left margin := x wanted - x start;
+ rest auf seite := pagelength;
+ papierlaenge := y size - y start;
+ d ypos := 0;
+ d xpos := 0;
+
+. y move zur kopf zeile :
+ verschiebung := top margin;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ IF verschiebung = 0 THEN rest auf seite INCR top margin FI;
+
+. drucke elan kopf :
+ elan text := headline pre;
+ elan text CAT date;
+ elan text CAT headline post;
+ elan text CAT datei name;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC elan fuss und kopf;
+
+
+PROC gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+cr plus lf (1, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+linker rand wenn noetig;
+d token. breite := LENGTH elan text * einrueckbreite;
+gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. linker rand wenn noetig :
+ IF left margin > 0
+ THEN disable stop;
+ d xpos := left margin;
+ execute (move, "", left margin, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC gib elan text aus;
+
+
+PROC cr plus lf (INT CONST anzahl,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+gib cr aus;
+gib lf aus;
+rest auf seite DECR verschiebung;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+. gib lf aus :
+ verschiebung := anzahl * font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+END PROC cr plus lf ;
+
+
+END PACKET eumel printer;
+
diff --git a/system/multiuser/1.7.5/src/font store b/system/multiuser/1.7.5/src/font store
new file mode 100644
index 0000000..ebb6a62
--- /dev/null
+++ b/system/multiuser/1.7.5/src/font store
@@ -0,0 +1,695 @@
+PACKET font store (* Autor : Rudolf Ruland *)
+ (* Stand : 18.02.86 *)
+ DEFINES font table,
+ list font tables,
+ list fonts,
+
+ x step conversion,
+ y step conversion,
+ on string,
+ off string,
+
+ font,
+ font exists,
+ next larger font exists,
+ next smaller font exists,
+ font lead,
+ font height,
+ font depth,
+ indentation pitch,
+ char pitch,
+ extended char pitch,
+ replacement,
+ extended replacement,
+ font string,
+ y offsets,
+ bold offset,
+ get font,
+ get replacements :
+
+
+LET font task = "configurator";
+
+LET ack = 0,
+ fetch code = 11,
+ all code = 17,
+
+ underline = 1,
+ bold = 2,
+ italics = 4,
+ reverse = 8,
+
+ first font = 1,
+ max fonts = 50,
+ max extensions = 120,
+ font table type = 3009,
+
+ FONTTABLE = STRUCT (
+
+ THESAURUS font names,
+
+ TEXT replacements, font name links,
+ extension chars, extension indexes,
+
+ ROW 4 TEXT on strings, off strings,
+
+ REAL x unit, y unit,
+
+ ROW 256 INT replacements table,
+
+ INT last font, last extension
+
+ ROW max fonts STRUCT (
+ TEXT font string, font name indexes, replacements,
+ extension chars, extension indexes, y offsets,
+ ROW 256 INT pitch table, replacements table,
+ INT indentation pitch, font lead, font height, font depth,
+ next larger font, next smaller font, bold offset ) fonts ,
+
+ ROW max extensions STRUCT (
+ TEXT replacements,
+ ROW 256 INT pitch table, replacements table,
+ INT std pitch ) extensions ,
+
+ );
+
+INT VAR font nr, help, reply, list index, last font,
+ index, char code 1, link nr, font store replacements length;
+
+TEXT VAR fo table := "", old font table, font name links, buffer;
+
+THESAURUS VAR font tables, font names;
+
+INITFLAG VAR in this task := FALSE,
+ init font ds := FALSE,
+ init ds := FALSE;
+
+BOUND FONTTABLE VAR font store;
+
+BOUND STRUCT (TEXT name, write pass, read pass) VAR msg;
+
+BOUND THESAURUS VAR all msg;
+
+BOUND TEXT VAR error msg;
+
+DATASPACE VAR font ds, ds;
+
+(*****************************************************************)
+
+PROC font table (TEXT CONST new font table) :
+
+ disable stop;
+ get font table (new font table);
+ in this task := NOT (font table = "" OR type (font ds) <> font table type);
+
+END PROC font table;
+
+
+PROC get font table (TEXT CONST new font table) :
+
+ enable stop;
+ buffer := new font table;
+ change all (buffer, " ", "");
+ IF exists (buffer) CAND type (old (buffer)) = font table type
+ THEN get font table from own task
+ ELIF exists task (font task)
+ THEN get font table from font task
+ ELSE errorstop ("Fonttabelle """ + buffer + """ gibt es nicht")
+ FI;
+
+ . get font table from own task :
+ IF NOT initialized (init ds) THEN ds := nilspace FI;
+ forget (ds); ds := old (buffer);
+ new font store;
+
+ . get font table from font task :
+ fetch font table (buffer);
+ IF type (ds) <> font table type
+ THEN forget (ds);
+ errorstop ("Fonttabelle """ + buffer + """ gibt es nicht")
+ FI;
+ new font store;
+
+ . new font store :
+ disable stop;
+ IF NOT initialized (init font ds) THEN font ds := nilspace FI;
+ forget (font ds);
+ font ds := ds;
+ forget (ds);
+ font store := font ds;
+ fo table := buffer;
+ font names := font store. font names;
+ font name links := font store. font name links;
+ last font := font store. last font;
+ font store replacements length := LENGTH font store. replacements;
+
+END PROC get font table;
+
+
+TEXT PROC font table :
+
+ fo table
+
+END PROC font table;
+
+
+PROC list font tables :
+
+ enable stop;
+ font tables := empty thesaurus;
+ font tables in own task;
+ font tables in font task;
+ note font tables;
+ note edit;
+
+ . font tables in own task :
+ list index := 0;
+ REP get (all, buffer, list index);
+ IF buffer = "" THEN LEAVE font tables in own task FI;
+ IF type (old (buffer)) = font table type
+ AND NOT (font tables CONTAINS buffer)
+ THEN insert (font tables, buffer) FI;
+ PER;
+
+ . font tables in font task :
+ all file names from font task;
+ THESAURUS CONST names := all msg;
+ list index := 0;
+ REP get (names, buffer, list index);
+ IF buffer = ""
+ THEN forget (ds);
+ LEAVE font tables in font task
+ FI;
+ fetch font table (buffer);
+ IF type (ds) = font table type
+ AND NOT (font tables CONTAINS buffer)
+ THEN insert (font tables, buffer) FI;
+ PER;
+
+ . note font tables :
+ list index := 0;
+ REP get (font tables, buffer, list index);
+ IF buffer = ""
+ THEN LEAVE note font tables;
+ ELSE note (buffer); note line;
+ FI;
+ PER;
+
+END PROC list font tables;
+
+
+PROC list fonts (TEXT CONST name):
+
+ initialize if necessary;
+ disable stop;
+ old font table := font table;
+ font table (name);
+ list fonts;
+ font table (old font table);
+
+END PROC list fonts;
+
+
+PROC list fonts :
+
+ enable stop;
+ initialize if necessary;
+ note font table;
+ FOR font nr FROM first font UPTO last font REP note font PER;
+ note edit;
+
+. note font table :
+ note ("FONTTABELLE : """); note (font table); note (""";"); noteline;
+ note (" x einheit = "); note (text (font store. x unit)); note (";"); noteline;
+ note (" y einheit = "); note (text (font store. y unit)); note (";"); noteline;
+
+. note font :
+ cout (font nr);
+ noteline;
+ note (" FONT : "); note font names; note (";"); noteline;
+ note (" einrueckbreite = "); note (text(font. indentation pitch)); note (";"); noteline;
+ note (" durchschuss = "); note (text(font. font lead)); note (";"); noteline;
+ note (" fonthoehe = "); note (text(font. font height)); note (";"); noteline;
+ note (" fonttiefe = "); note (text(font. font depth)); note (";"); noteline;
+ note (" groesserer font = """); note (next larger); note (""";"); noteline;
+ note (" kleinerer font = """); note (next smaller); note (""";"); noteline;
+
+ . font : font store. fonts (font nr)
+ . next larger : name (font store. font names, font. next larger font)
+ . next smaller : name (font store. font names, font. next smaller font)
+
+ . note font names :
+ INT VAR index;
+ note ("""");
+ note (name (font names, font. font name indexes ISUB 1));
+ note ("""");
+ FOR index FROM 2 UPTO LENGTH font. font name indexes DIV 2
+ REP note (", """);
+ note (name (font names, font. font name indexes ISUB index));
+ note ("""");
+ PER;
+
+END PROC list fonts;
+
+
+INT PROC x step conversion (REAL CONST cm) :
+
+ initialize if necessary;
+ IF cm >= 0.0
+ THEN int (cm * font store. x unit + 0.5 )
+ ELSE int (cm * font store. x unit - 0.5 )
+ FI
+
+END PROC x step conversion;
+
+
+REAL PROC x step conversion (INT CONST steps) :
+
+ initialize if necessary;
+ real (steps) / font store. x unit
+
+END PROC x step conversion;
+
+
+INT PROC y step conversion (REAL CONST cm) :
+
+ initialize if necessary;
+ IF cm >= 0.0
+ THEN int (cm * font store. y unit + 0.5 )
+ ELSE int (cm * font store. y unit - 0.5 )
+ FI
+
+END PROC y step conversion;
+
+
+REAL PROC y step conversion (INT CONST steps) :
+
+ initialize if necessary;
+ real (steps) / font store. y unit
+
+END PROC y step conversion;
+
+
+TEXT PROC on string (INT CONST modification) :
+
+ initialize if necessary;
+ SELECT modification OF
+ CASE underline : font store. on strings (1)
+ CASE bold : font store. on strings (2)
+ CASE italics : font store. on strings (3)
+ CASE reverse : font store. on strings (4)
+ OTHERWISE : errorstop ("unzulaessige Modifikation"); ""
+ END SELECT
+
+END PROC on string;
+
+
+TEXT PROC off string (INT CONST modification) :
+
+ initialize if necessary;
+ SELECT modification OF
+ CASE underline : font store. off strings (1)
+ CASE bold : font store. off strings (2)
+ CASE italics : font store. off strings (3)
+ CASE reverse : font store. off strings (4)
+ OTHERWISE : errorstop ("unzulaessige Modifikation"); ""
+ END SELECT
+
+END PROC off string;
+
+
+INT PROC font (TEXT CONST font name) :
+
+ initialize if necessary;
+ buffer := font name;
+ change all (buffer, " ", "");
+ INT CONST link nr := link (font names, buffer)
+ IF link nr <> 0
+ THEN font name links ISUB link nr
+ ELSE 0
+ FI
+
+END PROC font;
+
+
+TEXT PROC font (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN name (font names, fonts. font name indexes ISUB 1)
+ ELSE ""
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC font;
+
+
+BOOL PROC font exists (TEXT CONST font name) :
+
+ font (font name) <> 0
+
+END PROC font exists;
+
+
+BOOL PROC next larger font exists(INT CONST font number,
+ INT VAR next larger font) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN next larger font := fonts. next larger font;
+ IF next larger font <> 0
+ THEN next larger font := font name links ISUB next larger font;
+ next larger font <> 0
+ ELSE FALSE
+ FI
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht");
+ FALSE
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC next larger font exists;
+
+
+BOOL PROC next smaller font exists (INT CONST font number,
+ INT VAR next smaller font) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN next smaller font := fonts. next smaller font;
+ IF next smaller font <> 0
+ THEN next smaller font := font name links ISUB next smaller font;
+ next smaller font <> 0
+ ELSE FALSE
+ FI
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht");
+ FALSE
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC next smaller font exists;
+
+
+INT PROC font lead (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN fonts. font lead
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC font lead;
+
+
+INT PROC font height (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN fonts. font height
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC font height;
+
+
+INT PROC font depth (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN fonts. font depth
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC font depth;
+
+
+INT PROC indentation pitch (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN fonts. indentation pitch
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC indentation pitch;
+
+
+INT PROC char pitch (INT CONST font number,
+ TEXT CONST char ) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN INT CONST pitch := font. pitch table (code (char SUB 1) + 1);
+ IF pitch = maxint
+ THEN extended char pitch (font number, char SUB 1, char SUB 2)
+ ELIF pitch < 0
+ THEN pitch XOR (-maxint-1)
+ ELSE pitch
+ FI
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0
+ FI
+
+ . font : font store. fonts (font number)
+
+END PROC char pitch;
+
+
+INT PROC extended char pitch (INT CONST font number,
+ TEXT CONST esc char, char) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN extension. pitch table (code (char) + 1)
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0
+ FI
+
+ . font : font store. fonts (font number)
+
+ . extension : font store. extensions (extension number)
+
+ . extension number :
+ INT CONST index := pos (font. extension chars, esc char);
+ IF index = 0
+ THEN errorstop ("""" + esc char + char + """ hat keine Erweiterung") FI;
+ font. extension indexes ISUB index
+
+END PROC extended char pitch;
+
+
+TEXT PROC replacement (INT CONST font number,
+ TEXT CONST char ) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN link nr := font. replacements table (code (char SUB 1) + 1);
+ IF link nr = maxint
+ THEN extended replacement (font number, char SUB 1, char SUB 2)
+ ELSE process font replacement
+ FI
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); ""
+ FI
+
+ . font : font store. fonts (font number)
+
+ . process font replacement :
+ IF link nr < 0 THEN link nr := link nr XOR (-maxint-1) FI;
+ IF link nr = 0
+ THEN char
+ ELIF link nr > font store replacements length
+ THEN link nr DECR font store replacements length;
+ replacement text (font. replacements)
+ ELSE replacement text (font store. replacements)
+ FI
+
+END PROC replacement;
+
+
+TEXT PROC extended replacement (INT CONST font number,
+ TEXT CONST esc char, char ) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN process extension replacement
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); ""
+ FI
+
+ . process extension replacement :
+ determine extension link nr;
+ IF link nr = 0
+ THEN char
+ ELIF link nr > font store extension replacements length
+ THEN link nr DECR font store extension replacements length;
+ replacement text (font extension. replacements)
+ ELSE replacement text (font store extension. replacements)
+ FI
+
+ . determine extension link nr :
+ INT CONST index 1 := pos (font. extension chars, esc char);
+ INT CONST index 2 := pos (font store. extension chars, esc char);
+ IF index 1 <> 0
+ THEN link nr := font extension. replacements table (code (char) + 1);
+ ELIF index 2 <> 0
+ THEN link nr := font store extension. replacements table (code (char) + 1);
+ ELSE errorstop ("""" + esc char + char + """ hat keine Erweiterung")
+ FI;
+
+ . font extension : font store. extensions (font extension number)
+
+ . font extension number : font. extension indexes ISUB index 1
+
+ . font : font store. fonts (font number)
+
+ . font store extension : font store. extensions (font store extension number)
+
+ . font store extension number : font store. extension indexes ISUB index 2
+
+ . font store extension replacements length :
+ IF index 2 = 0
+ THEN 0
+ ELSE LENGTH font store extension. replacements
+ FI
+
+END PROC extended replacement;
+
+
+TEXT PROC replacement text (TEXT CONST replacements) :
+
+ buffer := subtext (replacements, link nr + 1,
+ link nr + code (replacements SUB link nr));
+ buffer
+
+END PROC replacement text;
+
+
+TEXT PROC font string (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN fonts. font string
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); ""
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC font string;
+
+
+TEXT PROC y offsets (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN fonts. y offsets
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); ""
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC y offsets;
+
+
+INT PROC bold offset (INT CONST font number) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN fonts. bold offset
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0
+ FI
+
+ . fonts : font store. fonts (font number)
+
+END PROC bold offset;
+
+
+PROC get font (INT CONST font number,
+ INT VAR indentation pitch, font lead, font height, font depth,
+ ROW 256 INT VAR pitch table ) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN indentation pitch := fonts. indentation pitch;
+ pitch table := fonts. pitch table;
+ font lead := fonts. font lead;
+ font height := fonts. font height;
+ font depth := fonts. font depth;
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht");
+ FI;
+
+ . fonts : font store. fonts (font number)
+
+END PROC get font;
+
+
+PROC get replacements (INT CONST font number,
+ TEXT VAR replacements,
+ ROW 256 INT VAR replacements table) :
+
+ initialize if necessary;
+ IF font number >= first font AND font number <= last font
+ THEN replacements := font store. replacements;
+ replacements CAT fonts. replacements;
+ replacements table := fonts. replacements table;
+ ELSE errorstop ("Font " + text (font number) + " gibt es nicht");
+ FI;
+
+ . fonts : font store. fonts (font number)
+
+END PROC get replacements;
+
+
+PROC initialize if necessary :
+
+ IF NOT initialized (in this task)
+ THEN IF font table = ""
+ THEN in this task := FALSE;
+ errorstop ("Fonttabelle noch nicht eingestellt");
+ ELSE font table (font table);
+ FI;
+ FI;
+
+END PROC initialize if necessary;
+
+
+PROC fetch font table (TEXT CONST font table name) :
+
+ enable stop;
+ IF NOT initialized (init ds) THEN ds := nilspace FI;
+ forget (ds); ds := nilspace;
+ msg := ds;
+ msg. name := font table name;
+ msg. write pass := "";
+ msg. read pass := "";
+ call (task (font task), fetch code, ds, reply);
+ IF reply <> ack
+ THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht")
+ FI;
+
+END PROC fetch font table;
+
+
+PROC all file names from font task :
+
+ enable stop;
+ IF NOT initialized (init ds) THEN ds := nilspace FI;
+ forget (ds); ds := nilspace;
+ call (task (font task), all code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds;
+ errorstop (error msg);
+ ELSE all msg := ds
+ FI;
+
+END PROC all file names from font task;
+
+
+END PACKET font store;
+
diff --git a/system/multiuser/1.7.5/src/global manager b/system/multiuser/1.7.5/src/global manager
new file mode 100644
index 0000000..b3d64cc
--- /dev/null
+++ b/system/multiuser/1.7.5/src/global manager
@@ -0,0 +1,683 @@
+(* ------------------- VERSION 19 16.05.86 ------------------- *)
+PACKET global manager DEFINES (* Autor: J.Liedtke *)
+
+ ALL ,
+ begin password ,
+ call ,
+ continue channel ,
+ erase ,
+ exists ,
+ fetch ,
+ free global manager ,
+ free manager ,
+ global manager ,
+ list ,
+ manager message ,
+ manager question ,
+ save ,
+ std 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 ,
+ free code = 20 ,
+ continue code = 100,
+
+
+ error pre = ""7""13""10""5"FEHLER : " ,
+ cr lf = ""13""10"" ;
+
+INT VAR reply , order , last order, phase number ;
+
+DATASPACE VAR ds := nilspace ;
+
+BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ;
+BOUND TEXT VAR reply msg ;
+BOUND THESAURUS VAR thesaurus msg ;
+
+TASK VAR order task, last order task ;
+
+FILE VAR list file ;
+
+TEXT VAR error message buffer := ""
+ ,record
+ ,received name
+ ,create son password := ""
+ ,save file name
+ ,save write password
+ ,save read password
+ ;
+
+
+PROC fetch (TEXT CONST file name) :
+
+ fetch (file name, father)
+
+ENDPROC fetch ;
+
+PROC fetch (TEXT CONST file name, TASK CONST manager) :
+
+ enable stop ;
+ last param (file name) ;
+ IF NOT exists (file name)
+ THEN call (fetch code, file name, manager)
+ ELIF overwrite permitted
+ THEN call (fetch code, file name, manager) ;
+ forget (file name, quiet)
+ ELSE LEAVE fetch
+ FI ;
+ IF reply = ack
+ THEN disable stop ;
+ copy (ds, file name) ;
+ forget (ds)
+ ELSE forget (ds) ;
+ errorstop ("Task """ + name (manager) + """antwortet nicht mit ack")
+ FI .
+
+overwrite permitted :
+ say ("eigene Datei """) ;
+ say (file name) ;
+ yes (""" ueberschreiben") .
+
+ENDPROC fetch ;
+
+PROC fetch (DATASPACE VAR dest, TEXT CONST file name, TASK CONST manager) :
+
+ disable stop ;
+ call (fetch code, file name, manager) ;
+ dest := ds ;
+ forget (ds)
+
+ENDPROC fetch ;
+
+
+PROC save :
+
+ save (last param)
+
+ENDPROC save ;
+
+PROC save (TEXT CONST file name) :
+
+ save (file name, father)
+
+ENDPROC save ;
+
+PROC save (TEXT CONST file name, TASK CONST manager) :
+
+ last param (file name) ;
+ call (save code, file name, old (file name), manager) ;
+ forget (ds)
+
+ENDPROC save ;
+
+PROC save (DATASPACE CONST source, TEXT CONST file name, TASK CONST manager):
+
+ call (save code, file name, source, manager) ;
+ forget (ds)
+
+ENDPROC save ;
+
+
+BOOL PROC exists (TEXT CONST file name, TASK CONST manager) :
+
+ call (exists code, file name, manager) ;
+ forget (ds) ;
+ reply = ack .
+
+ENDPROC exists ;
+
+
+PROC erase :
+
+ erase (last param)
+
+ENDPROC erase ;
+
+PROC erase (TEXT CONST file name) :
+
+ erase (file name, father)
+
+ENDPROC erase ;
+
+PROC erase (TEXT CONST file name, TASK CONST manager) :
+
+ call (erase code, file name, manager) ;
+ forget (ds)
+
+ENDPROC erase ;
+
+
+PROC list (TASK CONST manager) :
+
+ IF manager = myself
+ THEN list
+ ELSE list from manager
+ FI .
+
+list from manager :
+ call (list code, "", manager) ;
+ IF reply = ack
+ THEN DATASPACE VAR save ds := ds ;
+ forget (ds) ;
+ list file := sequential file (modify, save ds) ;
+ insert station and name of task in headline if possible ;
+ show (list file) ;
+ forget (save ds)
+ ELSE forget (ds)
+ FI .
+
+insert station and name of task in headline if possible :
+ IF headline (list file) = ""
+ THEN headline (list file, station number if there is one
+ + " Task : " + name (manager))
+ FI .
+
+station number if there is one :
+ IF station (manager) > 0
+ THEN "Station : " + text (station (manager))
+ ELSE ""
+ FI .
+
+ENDPROC list ;
+
+PROC list (FILE VAR f, TASK CONST manager) :
+
+ IF manager = myself
+ THEN list (f)
+ ELSE list from manager
+ FI .
+
+list from manager :
+ call (list code, "", manager) ;
+ IF reply = ack
+ THEN DATASPACE VAR save ds := ds ;
+ forget (ds) ;
+ list file := sequential file (input, save ds) ;
+ copy attributes (list file, f) ;
+ insert station and name of task in headline if possible ;
+ REP
+ getline (list file, record) ;
+ putline (f, record)
+ UNTIL eof (list file) PER ;
+ forget (save ds)
+ ELSE forget (ds)
+ FI .
+
+insert station and name of task in headline if possible :
+ IF headline (list file) = ""
+ THEN headline (list file, station number if there is one
+ + " Task : " + name (manager))
+ FI .
+
+station number if there is one :
+ IF station (manager) > 0
+ THEN "Station : " + text (station (manager))
+ ELSE ""
+ FI .
+
+ENDPROC list ;
+
+THESAURUS OP ALL (TASK CONST manager) :
+
+ THESAURUS VAR result ;
+ IF manager = myself
+ THEN result := all
+ ELSE get all from manager
+ FI ;
+ result .
+
+get all from manager :
+ call (all code, "", manager) ;
+ IF reply = ack
+ THEN get result thesaurus
+ ELSE result := empty thesaurus
+ FI .
+
+get result thesaurus :
+ thesaurus msg := ds ;
+ result := CONCR (thesaurus msg) ;
+ forget (ds) .
+
+ENDOP ALL ;
+
+
+PROC call (INT CONST op code, TEXT CONST file name, TASK CONST manager) :
+
+ DATASPACE VAR dummy space ;
+ call (op code, file name, dummy space, manager)
+
+ENDPROC call ;
+
+PROC call (INT CONST op code, TEXT CONST file name,
+ DATASPACE CONST save space, TASK CONST manager) :
+
+ enable stop ;
+ send first order first time ;
+ send second order if required first time ;
+ WHILE order restart required REP
+ pause (10) ;
+ send first order (op code, file name, manager) ;
+ send second order if required
+ PER ;
+ error or message if required .
+
+send first order first time :
+ send first order (op code, file name, manager) ;
+ WHILE order restart required REP
+ pause (10) ;
+ send first order (op code, file name, manager)
+ PER .
+
+send second order if required first time :
+ IF reply = question ack
+ THEN reply msg := ds ;
+ IF NOT yes (reply msg)
+ THEN LEAVE call
+ ELSE send second order (op code, file name, save space, manager)
+ FI
+ ELIF reply = second phase ack
+ THEN send second order (op code, file name, save space, manager)
+ FI .
+
+send second order if required :
+ IF reply = second phase ack OR reply = question ack
+ THEN send second order (op code, file name, save space, manager)
+ FI .
+
+error or message if required :
+ IF reply = message ack
+ THEN reply msg := ds ;
+ say (reply msg) ;
+ say (cr lf)
+ ELIF reply = error nak
+ THEN reply msg := ds ;
+ errorstop (reply msg)
+ FI .
+
+order restart required : reply = nak .
+
+ENDPROC call ;
+
+PROC send first order (INT CONST op code, TEXT CONST file name,
+ TASK CONST manager) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ msg := ds ;
+ msg.name := file name ;
+ msg.write pass := write password ;
+ msg.read pass := read password ;
+ call (manager, op code, ds, reply) ;
+ IF reply < 0
+ THEN errorstop ("Task nicht vorhanden")
+ FI .
+
+ENDPROC send first order ;
+
+PROC send second order (INT CONST op code, TEXT CONST file name,
+ DATASPACE CONST save space, TASK CONST manager) :
+
+ IF op code = save code
+ THEN send save space
+ ELSE send first order (second phase ack, file name, manager)
+ FI .
+
+send save space :
+ forget (ds) ;
+ ds := save space ;
+ call (manager, second phase ack, ds, reply) .
+
+ENDPROC send second order ;
+
+
+PROC global manager :
+
+ global manager
+ (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) std manager)
+
+ENDPROC global manager ;
+
+PROC free global manager :
+
+ global manager
+ (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) free manager)
+
+ENDPROC free global manager ;
+
+
+PROC global manager (PROC (DATASPACE VAR,
+ INT CONST, INT CONST, TASK CONST) manager) :
+
+ DATASPACE VAR local ds := nilspace ;
+ break ;
+ set autonom ;
+ disable stop ;
+ command dialogue (FALSE) ;
+ remember heap size ;
+ last order task := niltask ;
+ REP
+ forget (local ds) ;
+ wait (local ds, order, order task) ;
+ IF order <> second phase ack
+ THEN prepare first phase ;
+ manager (local ds, order, phase number, order task)
+ ELIF order task = last order task
+ THEN prepare second phase ;
+ manager (local ds, order, phase number, order task)
+ ELSE send nak
+ FI ;
+ send error if necessary ;
+ collect heap garbage if necessary
+ PER .
+
+prepare first phase :
+ phase number := 1 ;
+ last order := order ;
+ last order task := order task .
+
+prepare second phase :
+ phase number INCR 1 ;
+ order := last order .
+
+send nak :
+ forget (local ds) ;
+ local ds := nilspace ;
+ send (order task, nak, local ds) .
+
+send error if necessary :
+ IF is error
+ THEN forget (local ds) ;
+ local ds := nilspace ;
+ reply msg := local ds ;
+ CONCR (reply msg) := error message ;
+ clear error ;
+ send (order task, error nak, local ds)
+ FI .
+
+remember heap size :
+ INT VAR old heap size := heap size .
+
+collect heap garbage if necessary :
+ IF heap size > old heap size + 8
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI .
+
+ENDPROC global manager ;
+
+PROC std manager (DATASPACE VAR ds,
+ INT CONST order, phase, TASK CONST order task) :
+
+ IF order task < myself OR order = begin code OR order task = supervisor
+ THEN free manager (ds, order, phase, order task)
+ ELSE errorstop ("kein Zugriffsrecht auf Task """ + name (myself) + """")
+ FI .
+
+ENDPROC 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 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
+ 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
+ THEN msg := ds ;
+ received name := msg.name
+ 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 (received name, msg.read pass)
+ THEN forget (ds) ;
+ ds := old (received name) ;
+ send (order task, ack, ds)
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y erase :
+ msg := ds ;
+ received name := msg.name ;
+ IF NOT exists (received name)
+ THEN manager message ("""" + received name + """ existiert nicht", order task)
+ ELIF phase = 1
+ THEN manager question ("""" + received name + """ loeschen", order task)
+ ELIF write permission (received name, msg.write pass)
+ THEN forget (received name, quiet) ;
+ send (order task, ack, ds)
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y save :
+ IF phase = 1
+ THEN y save pre
+ ELSE y save post
+ FI .
+
+y save pre :
+ IF write permission (received name, msg.write pass)
+ THEN save file name := received name ;
+ save write password := msg.write pass ;
+ save read password := msg.read pass ;
+ IF exists (received name)
+ THEN manager question
+ ("""" + received name + """ ueberschreiben", order task)
+ ELSE send (order task, second phase ack, ds)
+ FI
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y save post :
+ forget (save file name, quiet) ;
+ copy (ds, save file name) ;
+ enter password (save file name, 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 (received name)
+ 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 names := ds ;
+ all names := all ;
+ send (order task, ack, ds) .
+
+y maintenance :
+ disable stop ;
+ call (supervisor, order, ds, reply) ;
+ forget (ds) ;
+ IF reply = ack
+ THEN put error message if there is one ;
+ REP
+ command dialogue (TRUE) ;
+ get command ("maintenance :") ;
+ reset editor ;
+ do command
+ UNTIL NOT on line PER ;
+ command dialogue (FALSE) ;
+ 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 .
+
+reset editor :
+ WHILE aktueller editor > 0 REP
+ quit
+ PER ;
+ clear error .
+
+save error message if there is one :
+ IF is error
+ THEN error message buffer := error message ;
+ clear error
+ FI .
+
+ENDPROC free manager ;
+
+PROC manager message (TEXT CONST message) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ reply msg := ds ;
+ reply msg := message ;
+ send (order task, message ack, ds)
+
+ENDPROC manager message ;
+
+PROC manager question (TEXT CONST question) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ reply msg := ds ;
+ reply msg := question ;
+ send (order task, question ack, ds)
+
+ENDPROC manager question ;
+
+PROC manager message (TEXT CONST message, TASK CONST receiver) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ reply msg := ds ;
+ reply msg := message ;
+ send (receiver, message ack, ds)
+
+ENDPROC manager message ;
+
+PROC manager question (TEXT CONST question, TASK CONST receiver) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ reply msg := ds ;
+ reply msg := question ;
+ send (receiver, question ack, ds)
+
+ENDPROC manager question ;
+
+PROC std begin :
+
+ do ("monitor")
+
+ENDPROC std begin ;
+
+PROC begin password (TEXT CONST password) :
+
+ cover tracks of old create son password ;
+ create son password := password ;
+ say (""3""13""5"") ;
+ cover tracks .
+
+cover tracks of old create son password :
+ replace (create son password, 1, LENGTH create son password * " ") .
+
+ENDPROC begin password ;
+
+
+PROC continue channel (INT CONST channel number) :
+
+ TASK CONST channel owner := task (channel number) ;
+ IF i am not channel owner
+ THEN IF NOT is niltask (channel owner)
+ THEN ask channel owner to release the channel ;
+ IF channel owner does not release channel
+ THEN errorstop ("Task """ + name (channel owner)
+ + """ gibt Kanal "
+ + text (channel number)
+ + " nicht frei")
+ FI
+ FI ;
+ continue (channel number)
+ FI .
+
+i am not channel owner :
+ channel <> channel number .
+
+ask channel owner to release the channel :
+ forget (ds) ;
+ ds := nilspace ;
+ pingpong (channel owner, free code, ds, reply) .
+
+channel owner does not release channel :
+ (reply <> ack) AND task exists .
+
+task exists :
+ reply <> -1 .
+
+ENDPROC continue channel ;
+
+
+END PACKET global manager ;
+
diff --git a/system/multiuser/1.7.5/src/indexer b/system/multiuser/1.7.5/src/indexer
new file mode 100644
index 0000000..e60110a
--- /dev/null
+++ b/system/multiuser/1.7.5/src/indexer
@@ -0,0 +1,1142 @@
+(* ------------------- VERSION 59 vom 21.02.86 -------------------- *)
+PACKET index program DEFINES outline,
+ index,
+ index merge:
+
+(* Programm zur Behandlung von Indizes aus Druckdateien
+ Autor: Rainer Hahn
+ Stand: 1.7.1 (Febr. 1984)
+ 1.7.4 (Maerz 1985) 'outline'
+*)
+
+LET escape = ""27"",
+ blank = " ",
+ trenn k = ""220"",
+ trennzeichen = ""221"",
+ minuszeichen = ""45"",
+ kommando zeichen = "#",
+ trenner = " ...",
+ ziffernanfang = "... ",
+ ziffern = "1234567890",
+ ib0 = 1,
+ ib1 = 2,
+ ib2 = 3,
+ ie0 = 4,
+ ie1 = 5,
+ ie2 = 6,
+ max indizes = 10, (* !!Anzahl möglichetr Indizes *)
+ punkt grenze = 50,
+ leer = 0,
+ fuellend = 1,
+ nicht angekoppelt = 2;
+
+INT VAR seiten nr,
+ zeilen nr,
+ erste fehler zeilennr,
+ zeilen seit index begin,
+ von,
+ komm anf,
+ komm ende,
+ kommando index,
+ index nr,
+ inhalt nr,
+ anz params,
+ anz zwischenspeicher,
+ y richtung;
+
+BOOL VAR outline modus,
+ inhaltsverzeichnis offen;
+
+TEXT VAR dummy,
+ dummy2,
+ fehlerdummy,
+ einrueckung,
+ akt zeile,
+ zweite zeile,
+ akt index,
+ zweiter index,
+ zeile,
+ kommando,
+ datei name,
+ kommando liste :: "ib:1.012ie:4.012",
+ par1,
+ par2;
+
+FILE VAR eingabe file,
+ ausgabe file;
+
+ROW max indizes FILE VAR f;
+
+ROW max indizes TEXT VAR zwischenspeicher;
+
+LET SAMMLER = STRUCT (TEXT index text,
+ TEXT seitennummer zusatz,
+ INT zustand);
+
+ROW max indizes SAMMLER VAR sammler;
+
+(******************************* outline-Routine **********************)
+
+PROC outline:
+ outline (last param)
+END PROC outline;
+
+PROC outline (TEXT CONST eingabe datei):
+ outline modus := TRUE;
+ disable stop;
+ do outline (eingabe datei);
+ IF is error
+ THEN put error;
+ clear error
+ FI;
+ enable stop;
+ IF anything noted
+ THEN to line (eingabe file, erste fehler zeilennr);
+ note edit (eingabe file)
+ ELSE to line (eingabe file, 1);
+ last param (eingabe datei + ".outline")
+ FI;
+ line
+END PROC outline;
+
+PROC do outline (TEXT CONST eingabe datei):
+ enable stop;
+ IF exists (eingabe datei)
+ THEN initialisiere bildschirm;
+ deaktiviere sammler;
+ anfrage auf inhaltsverzeichnis;
+ einrichten fuer zeilennummer ausgabe;
+ richte dateien ein;
+ verarbeite datei;
+ ELSE errorstop ("Datei nicht vorhanden")
+ FI;
+ cursor (1, y richtung + 1).
+
+initialisiere bildschirm:
+ eingabe file := sequential file (modify, eingabe datei);
+ page;
+ put ("OUTLINE"); put ("( für"); put (lines (eingabe file)); put ("Zeilen):");
+ put (eingabe datei);
+ put ("->"); out (eingabe datei); out (".outline");
+ cursor (1, 3).
+
+anfrage auf inhaltsverzeichnis:
+ put ("Bitte Index-Nr. für Inhaltsverzeichnis:");
+ dummy := "9";
+ REP
+ editget (dummy);
+ inhalt nr := int (dummy);
+ IF last conversion ok AND inhalt nr > 0 AND inhalt nr < 10
+ THEN LEAVE anfrage auf inhaltsverzeichnis
+ ELSE line; put ("Nr. zwischen 0 und 9, bitte nochmal:")
+ FI
+ END REP.
+
+einrichten fuer zeilennummer ausgabe:
+ line (2);
+ INT VAR x;
+ get cursor (x, y richtung).
+
+richte dateien ein:
+ inhaltsverzeichnis offen := FALSE;
+ anz zwischenspeicher := 0;
+ einrueckung := "";
+ erste fehler zeilennr := 0;
+ ggf ueberschreibe anfrage (eingabe datei + ".outline");
+ ausgabe file := sequential file (output, eingabe datei + ".outline");
+ to line (eingabe file, 1);
+ col (eingabe file, 1).
+
+verarbeite datei:
+ REP
+ suche naechste zeile mit kommandozeichen;
+ IF pattern found
+ THEN verarbeite ggf index kommandos
+ FI;
+ IF line no (eingabe file) = lines (eingabe file)
+ THEN LEAVE verarbeite datei
+ ELSE down (eingabe file);
+ col (eingabe file, 1)
+ FI
+ END REP.
+
+verarbeite ggf index kommandos:
+ komm anf := col (eingabe file);
+ von := komm anf;
+ REP
+ WHILE komm anf <> 0 REP
+ komplettiere alle fuellenden sammler (von, komm anf - 1);
+ entschluessele kommando;
+ von := komm ende + 1;
+ setze kommando um
+ END REP;
+ IF alle sammler leer
+ THEN LEAVE verarbeite ggf index kommandos
+ ELSE fuelle sammler mit restzeile und lese naechste zeile
+ FI
+ UNTIL line no (eingabe file) = lines (eingabe file) END REP.
+
+setze kommando um:
+ SELECT kommando index OF
+ CASE ib0, ib1, ib2:
+ zeilen seit index begin := 0;
+ IF anz params = 0
+ THEN index nr := 1
+ ELSE index nr := int (par1)
+ FI;
+ index anfang;
+ CASE ie0, ie1, ie2:
+ IF anz params = 0
+ THEN index nr := 1
+ ELSE index nr := int (par1)
+ FI;
+ index ende;
+ OTHERWISE
+ END SELECT.
+
+index anfang:
+ IF gueltiger index
+ THEN fange neuen index an
+ ELSE fehler (18, par1)
+ FI.
+
+fange neuen index an:
+ IF sammler fuellend (index nr)
+ THEN fehler (20, text (index nr))
+ ELIF index ist inhaltsverzeichnis
+ THEN stelle einrueckung fest;
+ sammler [index nr] . index text := einrueckung;
+ einrueckung CAT " ";
+ inhaltsverzeichnis offen := TRUE
+ ELIF index ist hauptindex
+ THEN sammler [index nr] . index text := einrueckung;
+ ELSE sammler [index nr] . index text := einrueckung;
+ sammler [index nr] . index text CAT text (index nr);
+ sammler [index nr] . index text CAT " --> "
+ FI;
+ sammler [index nr] . zustand := fuellend.
+
+stelle einrueckung fest:
+ einrueckung := "";
+ INT VAR punkt pos :: pos (zeile, ".");
+ WHILE punkt pos <> 0 REP
+ einrueckung CAT " ";
+ punkt pos := pos (zeile, ".", punkt pos + 1)
+ END REP.
+
+index ende:
+ IF gueltiger index
+ THEN IF sammler fuellend (index nr)
+ THEN IF kommando index = ie2
+ THEN sammler [index nr] . index text CAT par2;
+ FI;
+ leere sammler in outline datei (index nr)
+ ELSE fehler (21, text (index nr))
+ FI
+ ELSE fehler (18, text (index nr))
+ FI;
+ sammler [index nr] . zustand := leer.
+
+index ist inhaltsverzeichnis:
+ index nr = inhalt nr.
+
+index ist hauptindex:
+ index nr = 1.
+END PROC do outline;
+
+PROC leere sammler in outline datei (INT CONST nr):
+ IF index ist inhaltsverzeichnis
+ THEN line (ausgabe file);
+ putline (ausgabe file, sammler [nr] . index text);
+ inhaltsverzeichnis offen := FALSE;
+ leere zwischenspeicher
+ ELIF inhaltsverzeichnis offen
+ THEN fuelle zwischenspeicher
+ ELSE putline (ausgabe file, sammler [nr] . index text)
+ FI;
+ sammler [nr] . zustand := leer.
+
+index ist inhaltsverzeichnis:
+ nr = inhalt nr.
+
+leere zwischenspeicher:
+ INT VAR i;
+ FOR i FROM 1 UPTO anz zwischenspeicher REP
+ putline (ausgabe file, zwischenspeicher [i])
+ END REP;
+ anz zwischenspeicher := 0.
+
+fuelle zwischenspeicher:
+ anz zwischenspeicher INCR 1;
+ IF anz zwischenspeicher <= max indizes
+ THEN zwischenspeicher [anz zwischenspeicher] := sammler [nr] . index text
+ FI.
+END PROC leere sammler in outline datei;
+
+(********************* Utility Routinen *****************************)
+
+PROC ggf ueberschreibe anfrage (TEXT CONST d):
+ yrichtung INCR 1;
+ cursor (1, yrichtung);
+ IF exists (d)
+ THEN IF yes (d + " überschreiben")
+ THEN forget (d, quiet)
+ ELSE put ("wird angefügt")
+ FI
+ FI;
+ IF outline modus
+ THEN line
+ ELSE cursor (7, 3)
+ FI
+END PROC ggf ueberschreibe anfrage;
+
+BOOL PROC gueltiger index:
+ last conversion ok AND index nr > 0 AND index nr <= max indizes
+END PROC gueltiger index;
+
+PROC suche naechste zeile mit kommandozeichen:
+ TEXT VAR steuerzeichen :: incharety;
+ IF steuerzeichen = escape
+ THEN errorstop ("Abbruch durch ESC")
+ FI;
+ downety (eingabe file, "#", lines (eingabe file));
+ read record (eingabe file, zeile);
+ zeilen nr := line no (eingabe file);
+ cout (zeilen nr);
+END PROC suche naechste zeile mit kommandozeichen;
+
+PROC entschluessele kommando:
+ komm ende := pos (zeile, kommando zeichen, komm anf + 1);
+ IF komm ende <> 0
+ THEN hole kommando text;
+ TEXT CONST kommando anfangs zeichen :: kommando SUB 1;
+ IF pos ("-/"":*", kommando anfangs zeichen) = 0
+ THEN analysiere kommando
+ FI;
+ komm anf := pos (zeile, kommando zeichen, komm ende + 1);
+ ELSE fehler (2, "");
+ komm anf := 0;
+ LEAVE entschluessele kommando
+ END IF.
+
+hole kommando text:
+ kommando := subtext (zeile, komm anf + 1, komm ende - 1).
+
+analysiere kommando:
+ kommando index := 0;
+ analyze command (kommando liste, kommando, 3,
+ kommando index, anz params, par1, par2);
+ disable stop;
+ command error;
+ IF is error
+ THEN dummy := error message;
+ clear error;
+ dummy CAT " -> ";
+ dummy CAT kommando;
+ fehler (22, dummy);
+ enable stop;
+ komm anf := 0;
+ kommando index := 0;
+ LEAVE entschluessele kommando
+ END IF;
+ enable stop
+END PROC entschluessele kommando;
+
+PROC fuelle sammler mit restzeile und lese naechste zeile:
+ restzeile auffuellen;
+ naechste zeile und zaehlen;
+ zeilen seit index begin INCR 1;
+ von := pos (zeile, ""33"", ""255"", 1);
+ komm anf := pos (zeile, kommando zeichen, von);
+ IF zeilen seit index begin > 10 (* !!Anzahl Zeilen!! *)
+ THEN index aufnahme stoppen;
+ fehler (17, "");
+ LEAVE fuelle sammler mit restzeile und lese naechste zeile
+ ELIF seitenbegrenzung
+ THEN index aufnahme stoppen;
+ fehler (7, "");
+ END IF.
+
+restzeile auffuellen:
+ IF silbentrennung
+ THEN IF durch silbentrennung gewandeltes k
+ THEN replace (zeile, length (zeile) - 1, "c")
+ FI;
+ komplettiere alle fuellenden sammler (von, length (zeile) - 1)
+ ELIF bindestrich
+ THEN komplettiere alle fuellenden sammler (von, length (zeile));
+ ELSE komplettiere alle fuellenden sammler (von, length (zeile));
+ zeile := " ";
+ komplettiere alle fuellenden sammler (1, 1)
+ END IF.
+
+silbentrennung:
+ (zeile SUB length (zeile)) = trennzeichen.
+
+durch silbentrennung gewandeltes k:
+ (zeile SUB length (zeile) - 1) = trenn k.
+
+bindestrich:
+ (zeile SUB length (zeile)) = minuszeichen AND
+ (zeile SUB length (zeile) - 1) <> blank.
+END PROC fuelle sammler mit restzeile und lese naechste zeile;
+
+(**************************** index routine *************************)
+
+PROC index:
+ index (last param)
+END PROC index;
+
+PROC index (TEXT CONST eingabe datei):
+ outline modus := FALSE;
+ last param (eingabe datei);
+ disable stop;
+ suche indizes (eingabe datei);
+ IF is error
+ THEN put error;
+ clear error;
+ FI;
+ enable stop;
+ nachbehandlung.
+
+nachbehandlung:
+ IF anything noted
+ THEN to line (eingabe file, erste fehler zeilennr);
+ note edit (eingabe file)
+ ELSE to line (eingabe file, 1)
+ FI;
+ line.
+END PROC index;
+
+(************************** eigentliche index routine *****************)
+
+PROC suche indizes (TEXT CONST eingabe datei):
+ enable stop;
+ IF exists (eingabe datei)
+ THEN IF pos (eingabe datei, ".p") = 0
+ THEN errorstop ("Datei ist keine Druckdatei")
+ FI;
+ eingabe file := sequential file (modify, eingabe datei);
+ datei name := eingabe datei;
+ erste fehler zeilennr := 0;
+ initialisiere bildschirm;
+ deaktiviere sammler;
+ verarbeite datei;
+ sortiere die index dateien;
+ ELSE errorstop ("Datei existiert nicht")
+ END IF.
+
+initialisiere bildschirm:
+ page;
+ put ("INDEX"); put ("(für"); put (lines (eingabe file)); put ("Zeilen):");
+ put (eingabe datei);
+ cursor (1, 3);
+ out ("Zeile: ");
+ out ("Seite:");
+ y richtung := 4;
+ cursor (7, 3).
+
+verarbeite datei:
+ lese bis erste seitenbegrenzung;
+ WHILE NOT eof (eingabe file) REP
+ lese bis naechste seitenbegrenzung;
+ setze seiten nr;
+ gehe auf erste textzeile zurueck;
+ verarbeite indizes dieser seite
+ END REP.
+
+lese bis erste seitenbegrenzung:
+ to line (eingabe file, 1);
+ col (eingabe file, 1);
+ read record (eingabe file, zeile);
+ zeilen nr := 1;
+ cout (1);
+ REP
+ IF eof (eingabe file)
+ THEN errorstop ("Datei ist keine Druckdatei")
+ ELIF seitenbegrenzung
+ THEN LEAVE lese bis erste seitenbegrenzung
+ ELSE naechste zeile und zaehlen
+ END IF
+ END REP.
+
+lese bis naechste seitenbegrenzung:
+ IF line no (eingabe file) >= lines (eingabe file)
+ THEN LEAVE verarbeite datei
+ ELSE down (eingabe file)
+ FI;
+ INT VAR erste textzeile := line no (eingabe file);
+ down (eingabe file, "#page##----", lines (eingabe file));
+ IF pattern found
+ THEN read record (eingabe file, zeile)
+ ELSE LEAVE verarbeite datei
+ FI.
+
+gehe auf erste textzeile zurueck:
+ to line (eingabe file, erste textzeile);
+ read record (eingabe file, zeile);
+ zeilennr := lineno (eingabe file);
+ cout (zeilennr).
+
+verarbeite indizes dieser seite:
+ REP
+ suche naechste zeile mit kommandozeichen;
+ IF seitenbegrenzung
+ THEN LEAVE verarbeite indizes dieser seite
+ FI;
+ verarbeite index kommandos der naechsten zeilen;
+ IF seitenbegrenzung
+ THEN LEAVE verarbeite indizes dieser seite
+ FI;
+ down (eingabe file);
+ col (eingabe file, 1)
+ END REP.
+
+verarbeite index kommandos der naechsten zeilen:
+ komm anf := col (eingabe file);
+ von := komm anf;
+ REP
+ WHILE komm anf <> 0 REP
+ komplettiere alle fuellenden sammler (von, komm anf - 1);
+ entschluessele kommando;
+ von := komm ende + 1;
+ setze kommando um
+ END REP;
+ IF alle sammler leer
+ THEN LEAVE verarbeite index kommandos der naechsten zeilen
+ ELSE fuelle sammler mit restzeile und lese naechste zeile
+ END IF
+ UNTIL seitenbegrenzung ENDREP;
+ fehler (7, "").
+
+setze kommando um:
+SELECT kommando index OF
+CASE ib0, ib1, ib2:
+ zeilen seit index begin := 0;
+ IF anz params = 0
+ THEN index nr := 1
+ ELSE index nr := int (par1)
+ FI;
+ index anfang;
+CASE ie0, ie1, ie2:
+ IF anz params = 0
+ THEN index nr := 1
+ ELSE index nr := int (par1)
+ FI;
+ index ende;
+OTHERWISE
+ENDSELECT.
+
+index anfang:
+ IF gueltiger index
+ THEN fange neuen index an
+ ELSE fehler (18, par1)
+ END IF.
+
+fange neuen index an:
+ IF sammler fuellend (index nr)
+ THEN fehler (20, text (index nr))
+ ELSE fuelle sammler mit (index nr, "");
+ IF anz params = 2
+ THEN zusatz an seitennummer (index nr, par2)
+ ELSE zusatz an seitennummer (index nr, "")
+ END IF
+ END IF.
+
+index ende:
+ IF gueltiger index
+ THEN schreibe fuellenden sammler
+ ELSE fehler (18, text (index nr))
+ END IF.
+
+schreibe fuellenden sammler:
+ IF sammler fuellend (index nr)
+ THEN IF anz params = 2
+ THEN fuelle sammler mit (index nr, par2)
+ ENDIF;
+ schreibe sammler (index nr);
+ ELSE fehler (21, text (index nr))
+ END IF.
+END PROC suche indizes;
+
+(********************* Service Routinen ************************)
+
+BOOL PROC seitenbegrenzung:
+ subtext (zeile, 2, 5) = "page" AND subtext (zeile, 8, 12) = "-----"
+END PROC seitenbegrenzung;
+
+PROC setze seiten nr:
+ seiten nr := int (subtext (zeile, ziffern anfang, ziffernende));
+ cursor (20, 3);
+ put (seiten nr);
+ cursor (7, 3).
+
+ziffern anfang:
+ pos (zeile, "0", "9", 10).
+
+ziffern ende:
+ pos (zeile, " ", ziffern anfang) - 1
+END PROC setze seiten nr;
+
+PROC naechste zeile und zaehlen:
+ zeilen nr INCR 1;
+ cout (zeilen nr);
+ naechste zeile
+END PROC naechste zeile und zaehlen;
+
+PROC naechste zeile:
+ down (eingabe file);
+ read record (eingabe file, zeile);
+ col (eingabe file, 1)
+END PROC naechste zeile;
+
+(**************************** Fehler - Routine *********************)
+
+PROC fehler (INT CONST nr, TEXT CONST addition):
+ IF erste fehler zeilennr = 0
+ THEN erste fehler zeilennr := zeilen nr
+ FI;
+ yrichtung INCR 1;
+ IF yrichtung > 23
+ THEN yrichtung := 23;
+ FI;
+ cursor (1, yrichtung);
+ fehler melden;
+ fehlermeldung auf terminal ausgeben;
+ IF outline modus
+ THEN line
+ ELSE cursor (7, 3)
+ FI.
+
+fehler melden:
+ report text processing error (nr, zeilen nr, fehlerdummy, addition).
+
+fehlermeldung auf terminal ausgeben:
+ out (fehlerdummy);
+END PROC fehler;
+
+PROC warnung (INT CONST nr, TEXT CONST addition):
+ IF erste fehler zeilennr = 0
+ THEN erste fehler zeilennr := zeilen nr
+ FI;
+ yrichtung INCR 1;
+ IF yrichtung > 23
+ THEN yrichtung := 23;
+ FI;
+ cursor (1, yrichtung);
+ fehler melden;
+ meldung auf terminal ausgeben;
+ IF outline modus
+ THEN line
+ ELSE cursor (7, 3)
+ FI.
+
+fehler melden:
+ report text processing warning (nr, zeilen nr, fehlerdummy, addition).
+
+meldung auf terminal ausgeben:
+ out (fehlerdummy);
+END PROC warnung;
+
+(************************** Sammler-Dienste **************************)
+
+PROC index aufnahme stoppen:
+ zeile := "INDEX FEHLER";
+ komplettiere alle fuellenden sammler (1, length (zeile));
+ schreibe alle sammler;
+ read record (eingabe file, zeile)
+END PROC index aufnahme stoppen;
+
+PROC deaktiviere sammler:
+ INT VAR i;
+ FOR i FROM 1 UPTO max indizes REP
+ sammler [i] . zustand := nicht angekoppelt
+ END REP
+END PROC deaktiviere sammler;
+
+BOOL PROC sammler fuellend (INT CONST nr):
+ sammler [nr] . zustand = fuellend
+END PROC sammler fuellend;
+
+BOOL PROC sammler angekoppelt (INT CONST nr):
+ NOT (sammler [nr] . zustand = nicht angekoppelt)
+END PROC sammler angekoppelt;
+
+BOOL PROC alle sammler leer:
+ INT VAR i;
+ FOR i FROM 1 UPTO max indizes REP
+ IF sammler [i] . zustand = fuellend
+ THEN LEAVE alle sammler leer WITH FALSE
+ END IF
+ END REP;
+ TRUE
+END PROC alle sammler leer;
+
+PROC komplettiere alle fuellenden sammler (INT CONST von pos, bis pos):
+ INT VAR i;
+ IF von pos > bis pos
+ THEN LEAVE komplettiere alle fuellenden sammler
+ FI;
+ dummy := subtext (zeile, von pos, bis pos);
+ FOR i FROM 1 UPTO max indizes REP
+ IF sammler [i] . zustand = fuellend
+ THEN sammler [i] . index text CAT dummy;
+ FI
+ END REP;
+END PROC komplettiere alle fuellenden sammler;
+
+PROC fuelle sammler mit (INT CONST nr, TEXT CONST dazu):
+ IF sammler [nr] . zustand = nicht angekoppelt
+ THEN ankoppeln;
+ sammler [nr] . index text := dazu
+ ELIF sammler [nr] . zustand = leer
+ THEN sammler [nr] . index text := dazu
+ ELIF sammler fuellend (nr)
+ THEN sammler [nr] . index text CAT dazu
+ END IF;
+ sammler [nr] . zustand := fuellend.
+
+ankoppeln:
+ yrichtung INCR 1;
+ cursor (1, yrichtung);
+ put ("Indizes");
+ put (nr);
+ put ("gehen in Datei:");
+ dummy := datei name;
+ IF subtext (dummy, length (dummy) - 1) = ".p"
+ THEN replace (dummy, length (dummy) - 1, ".i")
+ ELSE dummy CAT ".i";
+ END IF;
+ dummy CAT text (nr);
+ out (dummy);
+ ggf ueberschreibe anfrage (dummy);
+ f [nr] := sequential file (output, dummy);
+ copy attributes (eingabe file, f[nr]);
+ cursor (7, 3)
+END PROC fuelle sammler mit;
+
+PROC zusatz an seitennummer (INT CONST nr, TEXT CONST zus text):
+ sammler [nr] . seitennummer zusatz := zus text
+END PROC zusatz an seitennummer;
+
+PROC schreibe sammler (INT CONST nr):
+ entferne leading blanks;
+ IF outline modus
+ THEN leere sammler in outline datei (nr)
+ ELSE fuege punkte an;
+ fuege seiten nr an;
+ fuege zusatz an seitennummer an;
+ fuege absatzzeichen an;
+ leere sammler
+ FI.
+
+entferne leading blanks:
+ WHILE (aufgesammelter text SUB 1) = blank REP
+ delete char (aufgesammelter text, 1)
+ END REP.
+
+fuege punkte an:
+ aufgesammelter text CAT trenner;
+ IF length (aufgesammelter text) < punkt grenze
+ THEN dummy := (punkt grenze - length (aufgesammelter text)) * ".";
+ aufgesammelter text CAT dummy
+ END IF;
+ aufgesammelter text CAT " ".
+
+fuege seiten nr an:
+ aufgesammelter text CAT text (seiten nr).
+
+fuege zusatz an seitennummer an:
+ aufgesammelter text CAT sammler [nr]. seitennummer zusatz.
+
+fuege absatzzeichen an:
+ aufgesammelter text CAT blank.
+
+leere sammler:
+ putline (f [nr], aufgesammelter text);
+ sammler [nr] . zustand := leer.
+
+aufgesammelter text:
+ sammler [nr] . index text
+END PROC schreibe sammler;
+
+PROC schreibe alle sammler:
+ INT VAR i;
+ FOR i FROM 1 UPTO max indizes REP
+ IF sammler fuellend (i)
+ THEN schreibe sammler (i)
+ END IF
+ END REP
+END PROC schreibe alle sammler;
+
+(**************** Sortieren und Indizes zusammenfuehren ***************)
+
+PROC sortiere die index dateien:
+INT VAR i;
+ FOR i FROM 1 UPTO max indizes REP
+ IF index datei erstellt
+ THEN sortiere diese datei
+ END IF
+ END REP.
+
+index datei erstellt:
+ sammler angekoppelt (i).
+
+sortiere diese datei:
+ y richtung INCR 1;
+ cursor (1, yrichtung);
+ dummy := datei name;
+ IF subtext (dummy, length (dummy) - 1) = ".p"
+ THEN replace (dummy, length (dummy) - 1, ".i")
+ ELSE dummy CAT ".i";
+ END IF;
+ dummy CAT text (i);
+ put (dummy);
+ IF yes ("sortieren")
+ THEN lex sort (dummy);
+ eintraege zusammenziehen (dummy)
+ END IF;
+END PROC sortiere die index dateien;
+
+PROC eintraege zusammenziehen (TEXT CONST fname):
+ FILE VAR sorted file :: sequential file (modify, fname);
+ INT VAR i :: 1;
+ to line (sorted file, 1);
+ read record (sorted file, akt zeile);
+ akt index := subtext (akt zeile, 1, pos (akt zeile, trenner) - 1);
+ down (sorted file);
+ WHILE NOT eof (sorted file) REP
+ read record (sorted file, zweite zeile);
+ zweiter index := subtext (zweitezeile, 1, pos (zweitezeile, trenner)-1);
+ i INCR 1;
+ cout (i);
+ IF akt index LEXEQUAL zweiter index
+ THEN fuege seitennummern von zweite in akt zeile ein
+ ELSE akt zeile := zweite zeile;
+ akt index := zweiter index
+ FI;
+ down (sorted file)
+ END REP;
+ to line (sorted file, 1).
+
+fuege seitennummern von zweite in akt zeile ein:
+ hole seitennummer der zweiten zeile;
+ fuege in akt zeile ein;
+ delete record (sorted file);
+ up (sorted file);
+ write record (sorted file, akt zeile).
+
+hole seitennummer der zweiten zeile:
+ INT VAR von := pos (zweite zeile, ziffernanfang) + length (ziffernanfang),
+ bis := von;
+ WHILE pos (ziffern, zweite zeile SUB bis) <> 0 REP
+ bis INCR 1
+ END REP;
+ bis DECR 1;
+ INT VAR zweite nummer := int( subtext (zweite zeile, von, bis));
+ TEXT VAR zweiter nummern text :=
+ subtext (zweite zeile, von, length (zweite zeile) - 1).
+
+fuege in akt zeile ein:
+ suche einfuege position in akt zeile;
+ fuege ein.
+
+suche einfuege position in akt zeile:
+ INT VAR einfuege pos :=
+ pos (akt zeile, ziffernanfang) + length (ziffernanfang);
+ von := einfuege pos;
+ REP
+ hole neue nummer;
+ UNTIL am ende der zeile END REP.
+
+am ende der zeile:
+ von >= length (akt zeile).
+
+hole neue nummer:
+ bis := von;
+ WHILE pos (ziffern, akt zeile SUB bis) <> 0 REP
+ bis INCR 1
+ END REP;
+ bis DECR 1;
+ IF bis < von
+ THEN bis := von
+ FI;
+ INT VAR neue nummer := int (subtext (akt zeile, von, bis));
+ IF zweite nummer = neue nummer
+ THEN fuege ggf zweiten nummern text mit textanhang ein
+ ELIF zweite nummer > neue nummer
+ THEN einfuege pos := von;
+ von := pos (akt zeile, ", ", bis) + 2;
+ IF von <= 2
+ THEN von := length (akt zeile)
+ FI
+ ELSE einfuege pos := von;
+ LEAVE suche einfuege position in akt zeile
+ FI.
+
+fuege ggf zweiten nummern text mit textanhang ein:
+ bis := pos (akt zeile, ", ", von);
+ IF bis <= 0
+ THEN bis := length (akt zeile);
+ FI;
+ IF die beiden nummern sind mit textanhang gleich
+ THEN LEAVE fuege in akt zeile ein
+ ELSE einfuege pos := von;
+ LEAVE suche einfuege position in akt zeile
+ FI.
+
+die beiden nummern sind mit textanhang gleich:
+ zweiter nummern text = subtext (akt zeile, von, bis - 1).
+
+fuege ein:
+ IF am ende der zeile
+ THEN change (akt zeile, length (akt zeile), length (akt zeile), ", ");
+ akt zeile CAT (zweiter nummern text + " ")
+ ELSE zweiter nummern text CAT ", ";
+ change
+ (akt zeile, einfuege pos, einfuege pos -1, zweiter nummern text);
+ FI.
+END PROC eintraege zusammenziehen;
+
+(*********************** merge routine *********************)
+
+PROC index merge (TEXT CONST i1, i2):
+ disable stop;
+ indizes zusammenziehen (i1, i2);
+ IF is error
+ THEN put error;
+ clear error;
+ ELSE last param (i2)
+ FI;
+ enable stop;
+ line.
+END PROC index merge;
+
+PROC indizes zusammenziehen (TEXT CONST i1, i2):
+ enable stop;
+ ueberschrift schreiben;
+ dateien assoziieren;
+ i1 vor i2 einfuegen;
+ sortieren;
+ forget (i1).
+
+dateien assoziieren:
+ IF exists (i1)
+ THEN eingabe file := sequential file (modify, i1)
+ ELSE errorstop (i1 + "existiert nicht")
+ END IF;
+ IF exists (i2)
+ THEN f[2] := sequential file (modify, i2)
+ ELSE errorstop (i2 + "existiert nicht")
+ END IF.
+
+ueberschrift schreiben:
+ page;
+ put ("INDEX MERGE:"); put (i1); put ("-->"); put (i2);
+ cursor (1, 3);
+ yrichtung := 3.
+
+i1 vor i2 einfuegen:
+ to first record (eingabe file);
+ to first record (f [2]);
+ zeilen nr := 0;
+ WHILE NOT eof (eingabe file) REP
+ zeilennr INCR 1;
+ cout (zeilennr);
+ read record (eingabe file, zeile);
+ insert record (f [2]);
+ write record (f[2], zeile);
+ down (f[2]);
+ down (eingabe file);
+ END REP.
+
+sortieren:
+ y richtung INCR 1;
+ cursor (1, yrichtung);
+ put (i2);
+ IF yes ("sortieren")
+ THEN lex sort (i2);
+ eintraege zusammenziehen (i2)
+ END IF
+END PROC indizes zusammenziehen;
+END PACKET index program;
+
+PACKET columns DEFINES col put, col get, col lineform, col autoform:
+
+INT VAR ende pos,
+ anfangs pos;
+
+FILE VAR file, spaltenfile;
+
+TEXT VAR dummy,
+ spalte,
+ zeile;
+
+LET geschuetztes blank = ""223"",
+ blank = " ";
+
+BOOL VAR spalte loeschen;
+
+DATASPACE VAR local space := nilspace;
+
+PROC col lineform:
+ spalte loeschen := TRUE;
+ columns put;
+ file := sequential file (modify, local space);
+ lineform (spaltenfile);
+ col get
+END PROC col lineform;
+
+PROC col autoform:
+ spalte loeschen := TRUE;
+ columns put;
+ file := sequential file (modify, local space);
+ autoform (spaltenfile);
+ col get
+END PROC col autoform;
+
+PROC col put:
+ spalte loeschen := yes ("Spalte löschen");
+ columns put
+END PROC col put;
+
+PROC columns put:
+ IF aktueller editor > 0 AND mark
+ THEN editor bereich bearbeiten
+ ELSE errorstop ("col put arbeitet nur auf markierten Bereich im Editor")
+ FI.
+
+editor bereich bearbeiten:
+ file := editfile;
+ anfangs pos einholen;
+ ende pos einholen;
+ INT VAR letzte zeile := line no (file),
+ erste zeile := mark line no (file);
+ to line (file, erste zeile);
+ col (file, 1);
+ spalten put;
+ to line (file, erste zeile);
+ col (file, anfangs pos);
+ mark (false);
+ ueberschrift neu.
+
+anfangs pos einholen:
+ anfangs pos := mark col (file).
+
+ende pos einholen:
+ ende pos := col (file) - 1;
+ IF ende pos < anfangs pos
+ THEN errorstop ("Markierungsende muß rechts vom -anfang sein")
+ FI.
+
+spalten put:
+ spaltendatei einrichten;
+ satznr neu;
+ WHILE line no (file) <= letzte zeile REP
+ satznr zeigen;
+ read record (file, zeile);
+ spalte herausholen;
+ spalte schreiben;
+ down (file)
+ END REP.
+
+spaltendatei einrichten:
+ forget (local space);
+ local space := nilspace;
+ spaltenfile := sequential file (output, local space).
+
+spalte herausholen:
+ spalte := subtext (zeile, anfangs pos, ende pos);
+ IF spalte loeschen
+ THEN change (zeile, anfangs pos, ende pos, "");
+ write record (file, zeile)
+ FI;
+ WHILE length (spalte) > 1 AND (spalte SUB length (spalte)) = blank REP
+ delete char (spalte, length (spalte))
+ END REP;
+ IF spaltenende ist geschuetztes blank
+ THEN delete char (spalte, length (spalte));
+ spalte CAT " "
+ FI.
+
+spalte schreiben:
+ putline (spaltenfile, spalte).
+
+spaltenende ist geschuetztes blank:
+ (spalte SUB length (spalte)) = geschuetztes blank.
+END PROC columns put;
+
+PROC col get:
+ IF aktueller editor > 0
+ THEN editor bereich bearbeiten
+ ELSE errorstop ("col put kann nur im Editor aufgerufen werden")
+ FI;
+ columns get;
+ alles neu.
+
+editor bereich bearbeiten:
+ file := editfile;
+ spaltenfile := sequential file (input, local space).
+
+columns get:
+ anfangs pos := col (file) - 1;
+ spaltenbreite feststellen;
+ col (file, 1);
+ satznr neu;
+ WHILE NOT eof (spaltenfile) REP
+ satznr zeigen;
+ getline (spaltenfile, spalte);
+ read record (file, zeile);
+ spalte ggf verbreitern;
+ zeile ggf verbreitern;
+ spalte in zeile einfuegen;
+ zeile schreiben;
+ down (file);
+ IF eof (file)
+ THEN errorstop ("Spalte hat zu viele Zeilen für die Datei")
+ FI
+ END REP.
+
+zeile ggf verbreitern:
+ WHILE length (zeile) < anfangs pos REP
+ zeile CAT blank
+ END REP.
+
+spaltenbreite feststellen:
+ INT VAR anz spaltenzeichen :: 0;
+ WHILE NOT eof (spaltenfile) REP
+ getline (spaltenfile, spalte);
+ IF length (spalte) > anz spaltenzeichen
+ THEN anz spaltenzeichen := length (spalte)
+ FI
+ END REP;
+ spaltenfile := sequential file (input, local space).
+
+spalte ggf verbreitern:
+ IF (spalte SUB length (spalte)) = blank
+ THEN delete char (spalte, length (spalte));
+ spalte CAT geschuetztes blank
+ FI;
+ IF anzufuegende spalte soll nicht ans zeilenende
+ THEN spalte verbreitern
+ FI.
+
+anzufuegende spalte soll nicht ans zeilenende:
+ anfangs pos <= length (zeile).
+
+spalte verbreitern:
+ WHILE length (spalte) < anz spaltenzeichen REP
+ spalte CAT blank
+ END REP.
+
+spalte in zeile einfuegen:
+ dummy := subtext (zeile, 1, anfangs pos);
+ dummy CAT spalte;
+ dummy CAT subtext (zeile, anfangs pos + 1);
+ zeile := dummy.
+
+zeile schreiben:
+ write record (file, zeile).
+END PROC col get;
+END PACKET columns;
+
diff --git a/system/multiuser/1.7.5/src/konfigurieren b/system/multiuser/1.7.5/src/konfigurieren
new file mode 100644
index 0000000..016fef2
--- /dev/null
+++ b/system/multiuser/1.7.5/src/konfigurieren
@@ -0,0 +1,254 @@
+(* ------------------- VERSION 4 22.04.86 ------------------- *)
+PACKET konfigurieren DEFINES (* Autor: D.Heinrichs *)
+
+
+
+ ansi cursor,
+ baudrate ,
+ bits ,
+ cursor logic ,
+ elbit cursor ,
+ enter incode ,
+ enter outcode ,
+ flow ,
+ input buffer size ,
+ link ,
+ new configuration ,
+ new type ,
+ ysize :
+
+LET max dtype nr = 5, (* maximum number of active device tables *)
+ device table = 32000,
+ ack = 0 ;
+
+
+INT VAR next outstring,
+ next instring;
+
+BOUND STRUCT (ALIGN space, (* umsetzcodetabelle *)
+ ROW 128 INT outcodes,
+ ROW 64 INT outstrings,
+ ROW 64 INT instrings) VAR x;
+
+
+ROW max dtype nr DATASPACE VAR device code table;
+
+THESAURUS VAR dtypes ;
+
+
+PROC new configuration :
+
+ dtypes := empty thesaurus ;
+ INT VAR i ;
+ insert (dtypes, "psi", i) ;
+ insert (dtypes, "transparent", i) ;
+ FOR i FROM 1 UPTO max dtype nr REP
+ forget (device code table (i))
+ PER .
+
+ENDPROC new configuration ;
+
+
+PROC block out (DATASPACE CONST ds, INT CONST page, code):
+ INT VAR err;
+ block out (ds,page,0,code,err);
+ announce error (err)
+END PROC block out;
+
+PROC announce error (INT CONST err):
+ SELECT err OF
+ CASE 0:
+ CASE 1: errorstop ("unbekanntes Terminalkommando")
+ CASE 2: errorstop ("Nummer der Terminal-Typ-Tabelle falsch")
+ CASE 3: errorstop ("falsche Terminalnummer")
+ OTHERWISE errorstop ("blockout: unzulaessiger Kanal")
+ ENDSELECT
+END PROC announce error;
+
+PROC flow (INT CONST nr, INT CONST dtype):
+ control (6, dtype, nr)
+END PROC flow;
+
+PROC ysize (INT CONST channel ,new size, INT VAR old size) :
+ control (11, channel, new size, old size)
+ENDPROC ysize ;
+
+PROC input buffer size (INT CONST nr,size):
+ INT VAR err;
+ control (2,nr,size,err)
+END PROC input buffer size;
+
+PROC baudrate (INT CONST nr, rate) :
+ control (8, rate, nr)
+ENDPROC baudrate ;
+
+PROC bits (INT CONST channel, number, parity) :
+ bits (channel, number-1 + 8*parity)
+ENDPROC bits ;
+
+PROC bits (INT CONST channel, key) :
+ control (9, key, channel)
+ENDPROC bits ;
+
+PROC control (INT CONST function, key, channel) :
+
+ INT VAR err ;
+ IF key > -128 AND key < 127
+ THEN control (function, channel, key, err)
+ ELIF key = -128
+ THEN control (function, channel, -maxint-1, err)
+ FI
+
+ENDPROC control ;
+
+
+PROC new type (TEXT CONST dtype):
+ x := new (dtype);
+ type (old (dtype), device table);
+ next outstring := 4;
+ next instring := 0;
+ INT VAR i;
+ (* Defaults, damit trmpret den cursor mitfuehrt: *)
+ FOR i FROM 1 UPTO 6 REP
+ enter outcode (i,i)
+ PER;
+ enter outcode (8,8);
+ enter outcode (10,10);
+ enter outcode (13,13);
+ enter outcode (14,126);
+ enter outcode (15,126);
+END PROC new type;
+
+INT PROC activate dtype (TEXT CONST dtype):
+
+ INT VAR i := link (dtypes, dtype);
+ IF (exists (dtype) CAND type (old (dtype)) = device table)
+ THEN IF i <= 0
+ THEN insert (dtypes, dtype, i);
+ FI;
+ forget(device code table (i-2));
+ device code table (i-2) := old (dtype)
+ FI;
+ IF i > max dtype nr +2 (* 5 neue Typen erlaubt *)
+ THEN delete (dtypes,i);
+ error stop ("Anzahl Terminaltypen > "+text (i));0
+ ELIF i <= 0
+ THEN error stop ("Unbekannter Terminaltyp" + dtype); 0
+ ELSE i
+ FI.
+
+END PROC activate dtype;
+
+PROC link (INT CONST nr, TEXT CONST dtype):
+
+ INT VAR lst nr := activate dtype (dtype)-3;
+ IF lst nr < 0
+ THEN lst nr INCR 256 (* fuer std terminal und std device *)
+ ELSE blockout (device code table(lst nr+1), 2, lst nr);
+ FI;
+ INT VAR err := 0;
+ control (1,nr,lst nr,err) ;
+ announce error(err)
+
+END PROC link;
+
+
+PROC enter outcode (INT CONST eumel code, ziel code):
+
+ IF ziel code < 128
+ THEN simple entry (eumel code, ziel code)
+ ELSE enter outcode (eumel code, 0, code (ziel code))
+ FI .
+
+ENDPROC enter outcode ;
+
+PROC simple entry (INT CONST eumel code, ziel code) :
+
+ INT CONST position := eumel code DIV 2 +1,
+ teil := eumel code - 2*position + 2;
+ TEXT VAR h :=" ";
+ replace (h,1,out word);
+ replace (h,1+teil,code (ziel code));
+ out word := (h ISUB 1).
+
+ out word: x.outcodes (position).
+
+END PROC simple entry ;
+
+PROC enter outcode (INT CONST eumel code, wartezeit,
+ TEXT CONST sequenz):
+
+ INT VAR i;
+ simple entry (eumel code, next outstring + 128);
+ enter part (x.outstrings, next outstring, wartezeit);
+ FOR i FROM 1 UPTO length (sequenz) REP
+ enter part (x.outstrings, next outstring + i, code (sequenzSUBi))
+ PER;
+ next outstring INCR length (sequenz)+2;
+ abschluss.
+
+ abschluss:
+ enter part (x.outstrings, next outstring-1, 0)
+END PROC enter outcode;
+
+PROC enter outcode (INT CONST eumelcode, TEXT CONST wert):
+ enter outcode (eumelcode,code(wert))
+END PROC enter outcode;
+
+PROC enter part (ROW 64 INT VAR a,INT CONST index, wert):
+ INT CONST position := index DIV 2 +1,
+ teil := index - 2*position + 2;
+ IF position > 64 THEN errorstop ("Ueberlauf der Terminaltyptabelle") FI;
+ TEXT VAR h :=" ";
+ replace (h,1,out word);
+ replace (h,1+teil,code (wert));
+ out word := (h ISUB 1).
+
+ out word: a (position).
+END PROC enter part;
+
+
+PROC enter incode (INT CONST elan code, TEXT CONST sequenz):
+ IF elan code > 254 OR elan code < 0 THEN errorstop ("kein Eingabecode")
+ ELSE
+ INT VAR i;
+ enter part (x.instrings, next instring, elan code);
+ FOR i FROM 1 UPTO length (sequenz) REP
+ enter part (x.instrings, next instring + i, code (sequenzSUBi))
+ PER;
+ next instring INCR length (sequenz)+2;
+
+ FI
+
+END PROC enter incode;
+
+PROC cursor logic (INT CONST dist, TEXT CONST pre, mid, post):
+
+ cursor logic (dist,255,pre,mid,post)
+
+END PROC cursor logic;
+
+PROC ansi cursor (TEXT CONST pre, mid, post):
+
+ cursor logic (0, 1, pre, mid, post)
+
+END PROC ansi cursor;
+
+PROC cursor logic (INT CONST dist, modus, TEXT CONST pre, mid, post):
+
+ enter part (x.outstrings,2,dist);
+ enter part (x.outstrings,3,dist);
+ enter part (x.outstrings,0,modus);
+ enter part (x.outstrings,1,modus);
+ enter outcode (6,0,pre+""0"y"+mid+""0"x"+post+""0"")
+
+END PROC cursor logic;
+
+PROC elbit cursor:
+ cursor logic (0,""27"","","");
+ enter part (x.outstrings,0,2);
+ enter part (x.outstrings,1,255);
+END PROC elbit cursor;
+
+ENDPACKET konfigurieren;
+
diff --git a/system/multiuser/1.7.5/src/liner b/system/multiuser/1.7.5/src/liner
new file mode 100644
index 0000000..bc1f41d
--- /dev/null
+++ b/system/multiuser/1.7.5/src/liner
@@ -0,0 +1,3079 @@
+(* ------------------- VERSION 406 vom 28.05.86 ----(1.7.5)------------- *)
+PACKET liner DEFINES line form,
+ autoform,
+ hyphenation width,
+ additional commands:
+
+(* Programm zur Zeilenformatierung mit unterschiedlichen Schriftypen
+ Autor: Rainer Hahn
+ Stand: 1.7.1 Febr. 1984
+ 1.7.3 Juli 1984
+ 1.7.4 Juni 1985
+ 1.7.5 ab Okt. 1985
+ *)
+
+(********************* form deklarationen ********************)
+
+TEXT VAR zeichen,
+ aufzaehlungszeichen,
+ par 1,
+ par 2,
+ kommando,
+ command store,
+ zielreferenzen,
+ herkunftsreferenzen,
+ aktuelle referenz,
+ alter schriftname,
+ dummy,
+ fehlerdummy,
+ footdummy,
+ scan symbol,
+ font table name :: "",
+ trennwort,
+ trennwort ohne komm,
+ wort1,
+ wort1 ohne komm,
+ wort2,
+ font nr speicher,
+ modifikations speicher,
+ mod zeilennr speicher,
+ index speicher,
+ ind zeilennr speicher,
+ counter numbering store,
+ counter reference store,
+ trennsymbol,
+ puffer,
+ neue zeile,
+ zeile,
+ einrueckung zweite zeile,
+ aktuelle blanks,
+ alte blanks,
+ zusaetzliche commands :: "",
+ kommando liste;
+
+INT CONST rueckwaerts :: -1,
+ esc char ohne zweites byte ausgang :: - maxint - 1;
+
+INT VAR anz tabs,
+ mitzuzaehlende zeichen,
+ anz blanks freihalten,
+ kommando index,
+ scan type,
+ font nr :: 1,
+ blankbreite fuer diesen schrifttyp,
+ aktuelle pitch zeilenlaenge,
+ eingestellte indentation pitch,
+ einrueckbreite,
+ zeilenbreite,
+ trennbreite in prozent :: 7,
+ trennbreite,
+ max trennlaenge,
+ max trenn laenge ohne komm,
+ zeichenwert ausgang,
+ formelbreite,
+ formelanfang,
+ zeilennr,
+ wortanfang,
+ wortende,
+ erste fehler zeilennr,
+ macro kommando ende,
+ von,
+ pufferlaenge,
+ zeichenpos,
+ zeichenpos bereits verarbeitet;
+
+BOOL VAR ask type and limit,
+ format file in situ,
+ lineform mode,
+ macro works,
+ kommandos speichern,
+ letzter puffer war absatz,
+ in d und e verarbeitung,
+ in tabelle,
+ in foot uebertrag,
+ in foot;
+
+LET hop = ""1"",
+ rechts = ""2"",
+ cl eol = ""5"",
+ links = ""8"",
+ return = ""13"",
+ begin mark = ""15"",
+ end mark = ""14"",
+ escape = ""27"",
+ trennzeichen = ""221"",
+ trenn k = ""220"",
+ blank = " ",
+ bindestrich = "-",
+ buchstaben =
+ "abcdefghijklmnopqrstuvwxyzüäößABCDEFGHIJKLMNOPQRSTUVWXYZÄÜö",
+ kommando zeichen = "#",
+ max tabs = 30,
+ extended char ausgang = 32767,
+ blank ausgang = 32766,
+ kommando ausgang = 32765,
+ such ausgang = 32764,
+ zeilenende ausgang = 0,
+ vorwaerts = 1,
+ type1 = 1,
+ linefeed = 3,
+ limit = 4,
+ free = 5,
+ page command0= 6,
+ page command1= 7,
+ on = 8,
+ off = 9,
+ page nr = 10,
+ pagelength = 11,
+ start = 12,
+ foot = 13,
+ end = 14,
+ head = 15,
+ headeven = 16,
+ headodd = 17,
+ bottom = 18,
+ bottomeven = 19,
+ bottomodd = 20,
+ block = 21,
+ material = 22,
+ columns = 23,
+ columnsend = 24,
+ ib0 = 25,
+ ib1 = 26,
+ ib2 = 27,
+ ie0 = 28,
+ ie1 = 29,
+ ie2 = 30,
+ topage = 31,
+ goalpage = 32,
+ count0 = 33,
+ count1 = 34,
+ setcount = 35,
+ value0 = 36,
+ value1 = 37,
+ table = 38,
+ table end = 39,
+ r pos = 40,
+ l pos = 41,
+ c pos = 42,
+ d pos = 43,
+ b pos = 44,
+ clear pos0 = 45,
+ clear pos1 = 46,
+ right = 47,
+ center = 48,
+ skip = 49,
+ skip end = 50,
+ u command = 51,
+ d command = 52,
+ e command = 53,
+ head on = 54,
+ head off = 55,
+ bottom on = 56,
+ bottom off = 57,
+ count per page=58,
+ fillchar = 59,
+ mark command = 60,
+ mark end = 61,
+ pageblock = 62,
+ bsp = 63,
+ counter1 = 64,
+ counter2 = 65,
+ setcounter = 66,
+ putcounter0 = 67,
+ putcounter1 = 68,
+ storecounter = 69,
+ ub = 70,
+ ue = 71,
+ fb = 72,
+ fe = 73;
+
+REAL VAR limit in cm :: 16.0,
+ fehler wert :: -1.0;
+
+FILE VAR eingabe,
+ ausgabe,
+ file;
+
+FRANGE VAR alter bereich;
+
+DATASPACE VAR ds;
+
+ROW 256 INT VAR pitch table;
+ROW max tabs TEXT VAR tab zeichen;
+ROW max tabs ROW 3 INT VAR tabs;
+(* 1. Eintrag: Position
+ 2. Eintrag: Art
+ 3. Eintrag: Bis-Position
+*)
+
+(************************** liner state-Routinen **********************)
+
+TYPE LINERSTATE =
+ STRUCT (INT position, from,
+ BOOL in macro,
+ TEXT buffer line, next line,
+ old blanks, actual blanks,
+ new line);
+
+LINERSTATE VAR before macro state,
+ before foot state;
+
+PROC get liner state (LINERSTATE VAR l):
+ l . position := zeichenpos;
+ l . from := von;
+ l . in macro := macro works;
+ l . buffer line := puffer;
+ l . next line := zeile;
+ l . old blanks := alte blanks;
+ l . actualblanks:= aktuelle blanks;
+ l . new line := neue zeile;
+END PROC get liner state;
+
+PROC put liner state (LINERSTATE CONST l):
+ zeichenpos := l . position;
+ von := l . from;
+ macro works := l . in macro;
+ puffer := l . buffer line ;
+ zeile := l . next line ;
+ alte blanks := l . old blanks;
+ aktuelle blanks := l . actual blanks;
+ neue zeile := l . new line ;
+ pufferlaenge := length (puffer);
+END PROC put liner state;
+
+(*********************** Utility Routinen **************************)
+
+PROC delete int (TEXT VAR resultat, INT CONST delete pos) :
+ change (resultat, delete pos * 2 - 1, delete pos * 2, "")
+END PROC delete int;
+
+OP CAT (TEXT VAR resultat, INT CONST zahl) :
+ resultat CAT " ";
+ replace (resultat, LENGTH resultat DIV 2, zahl);
+END OP CAT;
+
+PROC conversion (REAL VAR cm, INT VAR pitches):
+ disable stop;
+ INT VAR i :: x step conversion (cm);
+ IF is error
+ THEN dummy := error message;
+ clear error;
+ dummy CAT " -> ";
+ dummy CAT text (cm);
+ fehler (38, dummy);
+ cm := fehler wert
+ ELIF i < 0
+ THEN fehler (38, "negativ");
+ cm := fehler wert
+ ELSE pitches := i
+ FI;
+ enable stop
+END PROC conversion;
+
+(************************** Fehlermeldungen **********************)
+
+PROC fehler (INT CONST nr, TEXT CONST addition):
+ fehler melden;
+ meldung auf terminal ausgeben und ggf zeilennummer merken.
+
+fehler melden:
+ report text processing error (nr, zeilen nr, fehlerdummy, addition).
+END PROC fehler;
+
+PROC warnung (INT CONST nr, TEXT CONST addition):
+ warnung melden;
+ meldung auf terminal ausgeben und ggf zeilennummer merken.
+
+warnung melden:
+ report text processing warning (nr, zeilennr, fehlerdummy, addition).
+END PROC warnung;
+
+PROC meldung auf terminal ausgeben und ggf zeilennummer merken:
+ IF online
+ THEN line ;
+ out (fehlerdummy);
+ line ;
+ FI;
+ IF erste fehler zeilennr = 0
+ THEN erste fehler zeilennr := zeilennr
+ FI
+END PROC meldung auf terminal ausgeben und ggf zeilennummer merken;
+
+(*********************** Macro-Bearbeitung ***********************)
+
+PROC fuehre initialisierung fuer macro aus:
+ get liner state (before macro state);
+ get macro line (puffer);
+ pufferlaenge := length (puffer);
+ get macro line (zeile);
+ zeichenpos := 1;
+ von := 1;
+ macro works := TRUE.
+END PROC fuehre initialisierung fuer macro aus;
+
+PROC macro end command:
+ kommando := subtext (kommando, 2);
+ scan (kommando);
+ next symbol (scan symbol, scan type);
+ IF NOT macro works
+ THEN fehler (40, kommando);
+ LEAVE macro end command
+ ELIF scan symbol <> "macroend"
+ THEN fehler (33, kommando)
+ ELSE put liner state (before macro state);
+ FI
+END PROC macro end command;
+
+(************************** Schrifttyp einstellen *********************)
+
+PROC stelle font ein:
+ IF alter schriftname = par1
+ THEN IF zeilen nr > 2
+ THEN warnung (8, par1)
+ ELSE LEAVE stelle font ein
+ FI
+ ELIF font exists (par1)
+ THEN font nr := font (par1);
+ ELSE fehler (1, par1);
+ par1 := font (1);
+ font nr := 1
+ FI;
+ alter schriftname := par1;
+ hole font und stelle trennbreite ein
+END PROC stelle font ein;
+
+PROC hole font:
+ INT VAR x; (* height Werte *)
+ get font (font nr, eingestellte indentation pitch, x, x, x, pitch table);
+ pitch table [code (kommandozeichen) + 1] := kommando ausgang;
+ blankbreite fuer diesen schrifttyp := pitch table [code (blank) + 1]
+END PROC hole font;
+
+PROC hole font und stelle trennbreite ein:
+ hole font;
+ trennbreite setzen
+END PROC hole font und stelle trennbreite ein;
+
+PROC trennbreite setzen:
+ trennbreite := berechnete trennbreite.
+
+berechnete trennbreite:
+ INT VAR eingestellte trennbreite;
+ conversion (limit in cm, eingestellte trennbreite);
+ eingestellte trennbreite := eingestellte trennbreite
+ DIV 100 * trennbreite in prozent;
+ IF eingestellte trennbreite <= zweimal blankbreite
+ THEN zweimal blankbreite
+ ELSE eingestellte trennbreite
+ FI.
+
+zweimal blankbreite:
+ 2 * eingestellte indentation pitch.
+END PROC trennbreite setzen;
+
+PROC hyphenation width (INT CONST prozente):
+ IF prozente < 4 OR prozente > 20
+ THEN putline ("Fehler: Einstellbare Trennbreite zwischen 4 und 20%")
+ ELSE trennbreite in prozent := prozente
+ FI
+END PROC hyphenation width;
+
+(************************** kommando verarbeitung ****************)
+
+PROC additional commands (TEXT CONST k):
+ zusaetzliche commands := k
+END PROC additional commands;
+
+TEXT PROC additional commands:
+ zusaetzliche commands
+END PROC additional commands;
+
+BOOL PROC hinter dem kommando steht nix (INT CONST komm ende):
+ komm ende = pufferlaenge OR absatz hinter dem kommando.
+
+absatz hinter dem kommando:
+ komm ende + 1 = pufferlaenge AND puffer hat absatz.
+END PROC hinter dem kommando steht nix;
+
+PROC verarbeite kommando und neue zeile auffuellen:
+ neue zeile auffuellen (von, zeichenpos - 1);
+ von := zeichenpos;
+ verarbeite kommando;
+ neue zeile auffuellen (von, zeichenpos - 1);
+ von := zeichenpos
+END PROC verarbeite kommando und neue zeile auffuellen;
+
+PROC speichere kommando:
+ command store CAT "#";
+ command store CAT kommando;
+ command store CAT "#"
+END PROC speichere kommando;
+
+PROC execute stored commands:
+ IF length (command store) <> 0
+ THEN kommandos speichern := FALSE;
+ dummy := puffer;
+ INT VAR zpos := zeichenpos;
+ zeichenpos := 1;
+ puffer := command store;
+ pufferlaenge := length (puffer);
+ execute commands;
+ puffer := dummy;
+ pufferlaenge := length (puffer);
+ zeichenpos := zpos;
+ command store := "";
+ FI;
+ kommandos speichern := TRUE.
+
+execute commands:
+ WHILE zeichenpos < pufferlaenge REP
+ verarbeite kommando
+ END REP.
+END PROC execute stored commands;
+
+PROC verarbeite kommando:
+INT VAR anz params,
+ intparam,
+ kommando ende;
+REAL VAR realparam;
+ zeichenpos INCR 1;
+ kommando ende := pos (puffer, kommando zeichen, zeichenpos);
+ IF kommando ende <> 0
+ THEN kommando oder kommentar kommando verarbeiten;
+ zeichenpos := kommando ende + 1
+ ELSE fehler (2, "")
+ FI.
+
+kommando oder kommentar kommando verarbeiten:
+ kommando := subtext (puffer, zeichenpos, kommando ende - 1);
+ TEXT CONST erstes kommandozeichen :: (kommando SUB 1);
+ IF pos ("-/"":*", erstes kommandozeichen) = 0
+ THEN scanne kommando und fuehre es aus
+ ELSE restliche kommandos
+ FI.
+
+restliche kommandos:
+ IF erstes kommandozeichen = "-" OR erstes kommandozeichen = "/"
+ THEN
+ ELIF erstes kommandozeichen = """"
+ THEN scan (kommando);
+ next symbol (scan symbol, scan type);
+ INT VAR scan type2;
+ next symbol (scan symbol, scan type2);
+ IF scan type <> 4 OR scan type2 <> 7
+ THEN fehler (58, kommando)
+ FI
+ ELIF erstes kommandozeichen = "*"
+ THEN zeichenpos := kommando ende + 1;
+ macroend command;
+ LEAVE verarbeite kommando
+ ELIF erstes kommandozeichen = ":"
+ THEN disable stop;
+ delete char (kommando, 1);
+ INT CONST line no before do := line no (eingabe);
+ do (kommando);
+ to line (eingabe, line no before do);
+ IF is error
+ THEN dummy := error message;
+ clear error;
+ dummy CAT " -> ";
+ dummy CAT kommando;
+ fehler (9, dummy)
+ FI;
+ enable stop
+ FI.
+
+scanne kommando und fuehre es aus:
+ analyze command (kommando liste, kommando, 3,
+ kommando index, anz params, par1, par2);
+ disable stop ;
+ command error ;
+ IF is error
+ THEN dummy := error message;
+ clear error;
+ dummy CAT " -> ";
+ dummy CAT kommando;
+ fehler (22, dummy);
+ enable stop;
+ LEAVE scanne kommando und fuehre es aus
+ FI;
+ enable stop;
+ setze kommando um.
+
+setze kommando um:
+ SELECT kommando index OF
+
+CASE type1:
+ stelle font ein;
+ modifikations speicher := "";
+ mod zeilennr speicher := ""
+
+CASE limit:
+ realparam := real (par1);
+ IF kommandos speichern
+ THEN speichere kommando
+ ELIF last conversion ok AND pos (par1, ".") <> 0
+ THEN IF realparam = 0.0
+ THEN fehler (37, "")
+ ELSE conversion (realparam, aktuelle pitch zeilenlaenge);
+ IF realparam <> fehlerwert
+ THEN limit in cm := realparam;
+ trennbreite setzen
+ FI
+ FI
+ ELSE fehler (4, par1);
+ FI
+
+CASE on, ub, fb:
+ TEXT VAR mod zeichen;
+ IF kommando index = ub
+ THEN mod zeichen := "u"
+ ELIF kommando index = fb
+ THEN mod zeichen := "b"
+ ELSE mod zeichen := (par1 SUB 1);
+ FI;
+ INT VAR position :: pos (modifikations speicher, mod zeichen);
+ IF position <> 0
+ THEN dummy := mod zeichen + " in Zeile ";
+ dummy CAT text (mod zeilennr speicher ISUB position);
+ fehler (54, dummy);
+ replace (mod zeilennr speicher, position, zeilennr);
+ ELSE modifikations speicher CAT mod zeichen;
+ mod zeilennr speicher CAT zeilennr
+ FI
+
+CASE off, fe, ue:
+ IF kommando index = ue
+ THEN mod zeichen := "u"
+ ELIF kommando index = fe
+ THEN mod zeichen := "b"
+ ELSE mod zeichen := (par1 SUB 1);
+ FI;
+ position := pos (modifikations speicher, mod zeichen);
+ IF position = 0
+ THEN fehler (55, mod zeichen)
+ ELSE delete char (modifikations speicher, position);
+ delete int (mod zeilennr speicher, position)
+ FI
+
+CASE pagenr, pagelength, start, block, material, setcount, right, center,
+ linefeed:
+
+CASE head, headodd, headeven, bottom, bottomodd, bottomeven, end, free,
+ page command0, page command1, columns, columnsend:
+ IF NOT hinter dem kommando steht nix (kommando ende)
+ THEN fehler (19, kommando)
+ ELIF kommando ende = pufferlaenge
+ THEN IF (neue zeile SUB length (neue zeile)) = blank
+ THEN delete char (neue zeile, length (neue zeile))
+ FI;
+ puffer CAT blank;
+ pufferlaenge := length (puffer)
+ FI;
+ in foot := FALSE
+
+CASE foot:
+ IF in foot uebertrag
+ THEN zeilenbreite := aktuelle pitch zeilenlaenge + 1
+ ELIF in foot
+ THEN fehler (3, "")
+ ELSE fuelle ggf zeile vor foot auf (kommando ende)
+ FI
+
+CASE ib0, ib1, ib2:
+ TEXT VAR ind zeichen;
+ IF kommando index = ib0
+ THEN ind zeichen:= "1"
+ ELSE ind zeichen := par1
+ FI;
+ position := pos (index speicher, ind zeichen);
+ IF position <> 0
+ THEN dummy := ind zeichen + " in Zeile ";
+ dummy CAT text (ind zeilennr speicher ISUB position);
+ fehler (56, dummy);
+ replace (ind zeilennr speicher, position, zeilennr)
+ ELSE index speicher CAT ind zeichen;
+ ind zeilennr speicher CAT zeilennr
+ FI
+
+CASE ie0, ie1, ie2:
+ IF kommando index = ie0
+ THEN ind zeichen := "1"
+ ELSE ind zeichen := par1
+ FI;
+ position := pos (index speicher, ind zeichen);
+ IF position = 0
+ THEN fehler (57, ind zeichen)
+ ELSE delete char (index speicher, position);
+ delete int (ind zeilennr speicher, position)
+ FI
+
+CASE topage, count1:
+ herkunftsreferenzen speichern;
+ zeilenbreite um blankbreite erhoehen (3)
+
+CASE count0:
+ zeilenbreite um blankbreite erhoehen (3)
+
+CASE value0, value1:
+ IF anz params <> 0
+ THEN zielreferenzen speichern ohne warnung
+ FI;
+ zeilenbreite um blankbreite erhoehen (3)
+
+CASE goalpage:
+ zielreferenzen speichern
+
+CASE table:
+ IF in tabelle
+ THEN fehler (41, "")
+ ELSE IF hinter dem kommando steht nix (kommando ende)
+ THEN zeichenpos := pufferlaenge;
+ neue zeile auffuellen und ausgabe bei zeilenende
+ ELSE neue zeile auffuellen (von, kommando ende);
+ puffer := subtext (puffer, kommandoende + 1);
+ schreibe und initialisiere neue zeile
+ FI;
+ verarbeite tabelle;
+ LEAVE verarbeite kommando
+ FI
+
+CASE table end:
+ IF NOT in tabelle
+ THEN fehler (59, "")
+ FI
+
+CASE r pos:
+ IF kommandos speichern
+ THEN speichere kommando
+ ELSE tabulatorposition eintragen (r pos)
+ FI
+
+CASE l pos:
+ IF kommandos speichern
+ THEN speichere kommando
+ ELSE tabulatorposition eintragen (l pos)
+ FI
+
+CASE c pos:
+ IF kommandos speichern
+ THEN speichere kommando
+ ELSE tabulatorposition eintragen (c pos)
+ FI
+
+CASE d pos:
+ IF kommandos speichern
+ THEN speichere kommando
+ ELSE tabulatorposition eintragen (d pos)
+ FI
+
+CASE b pos:
+ IF kommandos speichern
+ THEN speichere kommando
+ ELSE tabulatorposition eintragen (b pos)
+ FI
+
+CASE clear pos0:
+ IF kommandos speichern
+ THEN speichere kommando
+ ELSE anz tabs := 0;
+ FI
+
+CASE clear pos1:
+ IF kommandos speichern
+ THEN speichere kommando
+ ELSE tabulatorposition loeschen
+ FI
+
+CASE skip:
+ IF hinter dem kommando steht nix (kommando ende)
+ THEN neue zeile auffuellen und ausgabe bei zeilenende
+ ELSE neue zeile auffuellen (von, kommandoende);
+ puffer := subtext (puffer, kommandoende + 1);
+ schreibe und initialisiere neue zeile
+ FI;
+ skip zeilen verarbeiten;
+ kommando ende := zeichenpos;
+
+CASE skip end:
+
+CASE u command, d command:
+ INT VAR next smaller font;
+ speichere font nr;
+ IF next smaller font exists (font nr, next smaller font)
+ THEN font nr := next smaller font
+ FI;
+ hole font und stelle trennbreite ein;
+ IF NOT in d und e verarbeitung
+ THEN verarbeite index und exponenten;
+ LEAVE verarbeite kommando
+ FI
+
+CASE e command:
+ entspeichere font nr
+
+CASE head on, head off, bottom on, bottom off, count per page, fillchar,
+ mark command, markend, pageblock:
+
+CASE bsp:
+ zeichenpos DECR 2;
+ IF kommandoende = length (puffer) OR
+ (puffer SUB kommandoende + 1) = kommandozeichen OR
+ zeichenpos < 1 OR
+ (puffer SUB zeichenpos) = kommandozeichen
+ THEN fehler (28, "");
+ LEAVE setze kommando um
+ FI;
+ begin of this char (puffer, zeichenpos);
+ kommandoende INCR 1;
+ INT VAR diese breite :: breite (puffer, zeichenpos),
+ naechste breite :: breite (puffer, kommandoende);
+ IF in d und e verarbeitung
+ THEN formelbreite DECR diese breite;
+ formelbreite INCR max (diese breite, naechste breite)
+ ELSE zeilenbreite DECR diese breite;
+ zeilenbreite INCR max (diese breite, naechste breite)
+ FI;
+ zeichenpos := kommandoende;
+ char pos move (vorwaerts);
+ LEAVE verarbeite kommando
+
+CASE counter1, counter2:
+ dummy := "#";
+ dummy CAT par1;
+ dummy CAT "#";
+ IF pos (counter numbering store, dummy) = 0
+ THEN fehler (34, par1);
+ FI;
+ IF kommando index = counter1
+ THEN par2 := "0"
+ FI;
+ anz blanks freihalten := 3 + 2 * int (par2);
+ zeilenbreite um blankbreite erhoehen (anz blanks freihalten)
+
+CASE set counter:
+ dummy := "#";
+ dummy CAT par1;
+ dummy CAT "#";
+ IF pos (counter numbering store, dummy) = 0
+ THEN counter numbering store CAT dummy
+ ELSE warnung (15, par1)
+ FI
+
+CASE put counter0:
+ zeilenbreite um blankbreite erhoehen (anz blanks freihalten)
+
+CASE put counter1:
+ dummy := "#";
+ dummy CAT par1;
+ dummy CAT "#";
+ INT VAR begin pos :: pos (counter reference store, dummy);
+ IF begin pos = 0
+ THEN counter reference store CAT "u";
+ counter reference store CAT dummy
+ ELIF (counter reference store SUB begin pos - 1) <> "u"
+ THEN insert char (counter reference store,"u", max (begin pos, 1))
+ FI;
+ zeilenbreite um blankbreite erhoehen (5)
+
+CASE store counter:
+ dummy := "#";
+ dummy CAT par1;
+ dummy CAT "#";
+ begin pos := pos (counter reference store, dummy);
+ IF begin pos <> 0
+ THEN IF (counter reference store SUB begin pos - 1) = "i" OR
+ (counter reference store SUB begin pos - 2) = "i"
+ THEN fehler (35, par1)
+ ELIF (counter reference store SUB begin pos - 1) = "u"
+ THEN insert char (counter reference store, "i",
+ max (begin pos - 1, 1))
+ ELSE insert char (counter reference store, "i",
+ max (begin pos, 1))
+ FI
+ ELSE counter reference store CAT "i";
+ counter reference store CAT dummy
+ FI
+
+OTHERWISE
+ IF macro command and then process parameters (kommando)
+ THEN IF macro works
+ THEN fehler (15, kommando)
+ ELSE zeichenpos := kommando ende + 1;
+ neue zeile auffuellen (von, zeichenpos - 1);
+ von := zeichenpos;
+ fuehre initialisierung fuer macro aus;
+ LEAVE verarbeite kommando
+ FI
+ ELIF zusaetzliche commands <> ""
+ THEN analyze command (zusaetzliche commands, kommando, 3,
+ kommando index, anz params, par1, par2);
+ IF kommando index = 0
+ THEN fehler (8, kommando)
+ FI
+ ELSE fehler (8, kommando)
+ FI;
+END SELECT.
+END PROC verarbeite kommando;
+
+(************************* Indizes und Exponenten **********************)
+
+PROC zeilenbreite um blankbreite erhoehen (INT CONST anz):
+ INT CONST blankbreite mal anz :: anz * eingestellte indentation pitch;
+ IF in d und e verarbeitung
+ THEN formelbreite INCR blankbreite mal anz
+ ELSE zeilenbreite INCR blankbreite mal anz
+ FI;
+ mitzuzaehlende zeichen INCR anz
+END PROC zeilenbreite um blankbreite erhoehen;
+
+PROC speichere font nr:
+ IF index oder exponent anfang
+ THEN suche wortanfang in neuer zeile;
+ zeilenbreite DECR formelbreite
+ FI;
+ font nr speicher CAT " ";
+ font nr speicher CAT text (font nr).
+
+index oder exponent anfang:
+ font nr speicher = "".
+
+suche wortanfang in neuer zeile:
+ auf das letzte zeichen stellen;
+ WHILE NOT wortanfang vor formel REP
+ formelbreite INCR breite (neue zeile, formelanfang);
+ IF formelanfang = 1
+ THEN LEAVE suche wortanfang in neuer zeile
+ FI;
+ char pos move (neue zeile, formelanfang, rueckwaerts);
+ END REP;
+ char pos move (neue zeile, formelanfang, vorwaerts).
+
+wortanfang vor formel:
+ pos (" #", neue zeile SUB formelanfang) <> 0.
+
+auf das letzte zeichen stellen:
+ formelanfang := length (neue zeile);
+ formelbreite := 0;
+ IF formelanfang > 0
+ THEN begin of this char (neue zeile, formelanfang);
+ ELSE formelanfang := 1;
+ LEAVE suche wortanfang in neuer zeile
+ FI
+END PROC speichere font nr;
+
+PROC verarbeite index und exponenten:
+ in d und e verarbeitung := TRUE;
+ zeichenpos := pos (puffer, kommandozeichen, zeichenpos) + 1;
+ INT VAR altes zeichenpos := zeichenpos;
+ verarbeite index oder exponenten zeichen;
+ fehler (52, "");
+ entspeichere font nr.
+
+verarbeite index oder exponenten zeichen:
+ REP
+ stranalyze (pitch table, formelbreite,
+ aktuelle pitch zeilenlaenge - zeilenbreite,
+ puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
+ IF zeichenwert ausgang = kommando ausgang
+ THEN verarbeite zeichen vor kommando;
+ verarbeite kommando und neue zeile auffuellen;
+ IF NOT in d und e verarbeitung
+ THEN zeilenbreite INCR formelbreite;
+ LEAVE verarbeite index und exponenten
+ FI;
+ altes zeichenpos := zeichenpos
+ ELIF zeichenwert ausgang = extended char ausgang
+ THEN char pos move (vorwaerts);
+ zeilenbreite INCR breite (puffer, zeichenpos);
+ char pos move (vorwaerts)
+ ELIF zeichenpos >= pufferlaenge
+ AND formelbreite + zeilenbreite < aktuelle pitch zeilenlaenge
+ THEN LEAVE verarbeite index oder exponenten zeichen
+ ELIF formelanfang <= 1
+ THEN fehler (53, "");
+ formelbreite := 0;
+ ELIF zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN fehler (23, "");
+ LEAVE verarbeite index oder exponenten zeichen
+ ELSE schreibe neue zeile vor formelanfang
+ FI
+ END REP.
+
+verarbeite zeichen vor kommando:
+ mitzuzaehlende zeichen INCR
+ number chars (puffer, altes zeichenpos, zeichenpos);
+ IF (puffer SUB zeichenpos) <> blank
+ THEN aufzaehlungszeichen := (puffer SUB zeichenpos)
+ FI;
+ char pos move (vorwaerts).
+
+schreibe neue zeile vor formelanfang:
+ dummy := subtext (neue zeile, formelanfang);
+ neue zeile := subtext (neue zeile, 1, formelanfang - 1);
+ loesche nachfolgende blanks;
+ schreibe und initialisiere neue zeile;
+ neue zeile CAT dummy;
+ formelanfang := 1;
+ char pos move (vorwaerts)
+END PROC verarbeite index und exponenten;
+
+PROC entspeichere font nr:
+ INT VAR index := length (font nr speicher);
+ IF index <= 1
+ THEN fehler (51, "")
+ ELSE suche nr anfang;
+ entspeichere;
+ FI.
+
+suche nr anfang:
+ WHILE (font nr speicher SUB index) <> " " AND index <> 0 REP
+ index DECR 1
+ END REP.
+
+entspeichere:
+ font nr := int (subtext (font nr speicher, index + 1));
+ IF index <= 1
+ THEN font nr speicher := "";
+ in d und e verarbeitung := FALSE
+ ELSE font nr speicher := subtext (font nr speicher, 1, index - 1)
+ FI;
+ hole font und stelle trennbreite ein
+END PROC entspeichere font nr;
+
+(*************************** skip zeilen ****************************)
+
+PROC skip zeilen verarbeiten:
+ REP
+ IF dateiende
+ THEN errorstop ("Dateiende während skip-Anweisung")
+ ELIF skip ende kommando
+ THEN LEAVE skip zeilen verarbeiten
+ FI;
+ neue zeile auffuellen und ausgabe bei zeilenende
+ END REP.
+
+dateiende:
+ pufferlaenge = 0.
+
+skip ende kommando:
+ TEXT VAR kliste :: "skipend:1.0", k;
+ INT VAR k anf :: pos (puffer, kommandozeichen),
+ kende, anz params, kindex;
+ WHILE noch ein kommando vorhanden REP
+ kindex := 0;
+ analysiere das kommando
+ END REP;
+ FALSE.
+
+noch ein kommando vorhanden:
+ kanf <> 0.
+
+analysiere das kommando:
+ kende := pos (puffer, kommandozeichen, kanf + 1);
+ IF kende = 0
+ THEN fehler (2, "");
+ LEAVE skip ende kommando WITH FALSE
+ FI;
+ k := subtext (puffer, kanf + 1, kende - 1);
+ analyze command (kliste, k, 3, kindex, anz params, par1, par2);
+ IF kindex = 1
+ THEN zeichenpos := kende;
+ LEAVE skip ende kommando WITH TRUE
+ FI;
+ kanf := pos (puffer, kommandozeichen, kende + 1).
+END PROC skip zeilen verarbeiten;
+
+(**************** sonderbehandlung von zeilen vor foot *******************)
+
+PROC fuelle ggf zeile vor foot auf (INT VAR com ende):
+ IF foot am zeilenende ohne absatz AND NOT macro works
+ THEN letzter puffer war absatz := TRUE;
+ IF text vor foot AND NOT zeile hat richtige laenge
+ THEN INT VAR foot zeilennr := line no (eingabe);
+ INT CONST x1 := com ende;
+ in foot uebertrag := TRUE;
+ get liner state (before foot state);
+ formatiere diese zeile;
+ to line (eingabe, foot zeilennr);
+ footdummy := neue zeile;
+ put liner state (before foot state);
+ neue zeile := footdummy;
+ com ende := x1;
+ in foot uebertrag := FALSE
+ FI
+ ELIF NOT hinter dem kommando steht nix (com ende)
+ THEN fehler (19, kommando);
+ LEAVE fuelle ggf zeile vor foot auf
+ FI;
+ in foot := TRUE.
+
+foot am zeilenende ohne absatz:
+ com ende = pufferlaenge.
+
+text vor foot:
+ pos (neue zeile, ""33"", ""255"", 1) <> 0.
+
+formatiere diese zeile:
+ foot anweisung entfernen;
+ lese eingabe datei bis end kommando;
+ zeile nach end in zeile;
+ formatiere;
+ schreibe die veraenderte zeile nach end.
+
+foot anweisung entfernen:
+ zeichenpos := com ende;
+ ueberspringe das kommando (puffer, zeichenpos, rueckwaerts);
+ zeichenpos DECR 1;
+ puffer := subtext (puffer, 1, zeichenpos);
+ WHILE NOT within kanji (puffer, zeichenpos) AND
+ (puffer SUB zeichenpos) = blank AND foot stand nicht am zeilenanfang
+ REP
+ zeilenbreite DECR breite (blank);
+ delete char (puffer, zeichenpos);
+ delete char (neue zeile, length (neue zeile));
+ zeichenpos DECR 1
+ END REP;
+ pufferlaenge := length (puffer).
+
+foot stand nicht am zeilenanfang:
+ zeichenpos > 0.
+
+lese eingabe datei bis end kommando:
+ TEXT VAR kliste :: "end:1.0";
+ dummy := zeile;
+ WHILE NOT foot ende kommando REP
+ IF eof (eingabe)
+ THEN LEAVE formatiere diese zeile
+ FI;
+ read record (eingabe, dummy);
+ down (eingabe);
+ ENDREP;
+ INT CONST zeile nach end := line no (eingabe);
+ IF NOT end kommando steht am zeilenende
+ THEN LEAVE formatiere diese zeile
+ FI.
+
+end kommando steht am zeilenende:
+ k ende = length (dummy) OR k ende + 1 = length (dummy).
+
+foot ende kommando:
+ INT VAR k anf, k ende :: 0, anz params, k index;
+ WHILE noch ein kommando vorhanden REP
+ k ende := pos (dummy, kommandozeichen, k anf + 1);
+ IF k ende = 0
+ THEN LEAVE foot ende kommando WITH FALSE
+ ELSE kommando := subtext (dummy, k anf + 1, k ende - 1);
+ FI;
+ analyze command (kliste, kommando, 3, kindex, anz params, par1, par2);
+ IF k index = 1
+ THEN LEAVE foot ende kommando WITH TRUE
+ FI;
+ END REP;
+ FALSE.
+
+noch ein kommando vorhanden:
+ k anf := pos (dummy, kommandozeichen, k ende + 1);
+ k anf <> 0.
+
+zeile nach end in zeile:
+ read record (eingabe, zeile);
+ INT VAR text anf := pos (zeile, ""33"", ""255"", 1);
+ IF zeile nach end ist leerzeile
+ THEN LEAVE formatiere diese zeile
+ ELSE IF text anf > 1
+ THEN aktuelle blanks := subtext (zeile, 1, text anf - 1);
+ zeile := subtext (zeile, text anf)
+ FI;
+ FI.
+
+zeile nach end ist leerzeile:
+ text anf <= 0.
+
+formatiere:
+ IF foot stand nicht am zeilenanfang
+ THEN verarbeite letztes zeichen von puffer
+ ELSE puffer CAT zeile;
+ pufferlaenge := length (puffer)
+ FI;
+ REP
+ stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
+ puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
+ IF zeichenwert ausgang = kommando ausgang
+ THEN zeichenpos INCR 1;
+ neue zeile auffuellen (von, zeichenpos - 1);
+ von := zeichenpos;
+ INT VAR ende der neuen zeile := length (neue zeile),
+ zpos davor := zeichenpos;
+ verarbeite kommando;
+ neue zeile auffuellen (von, zeichenpos - 1);
+ von := zeichenpos;
+ IF kommando index = foot
+ THEN behandlung der zeile vor foot;
+ LEAVE formatiere
+ ELIF zeichenpos >= pufferlaenge
+ OR zeilenbreite > aktuelle pitch zeilenlaenge
+ THEN ende einer neuen zeile;
+ LEAVE formatiere
+ FI
+ ELIF zeichenwert ausgang = extended char ausgang
+ THEN char pos move (vorwaerts);
+ zeilenbreite INCR breite (puffer, zeichenpos);
+ char pos move (vorwaerts)
+ ELIF zeichenwert ausgang = zeilenende ausgang
+ OR zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN up (eingabe);
+ delete record (eingabe);
+ neue zeile auffuellen;
+ IF zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN fehler (23, "")
+ FI;
+ LEAVE formatiere diese zeile
+ ELSE ende einer neuen zeile;
+ LEAVE formatiere
+ FI
+ END REP.
+
+behandlung der zeile vor foot:
+ neue zeile := subtext (neue zeile, 1, ende der neuen zeile);
+ zeichenpos := zpos davor.
+
+schreibe die veraenderte zeile nach end:
+ to line (eingabe, zeile nach end);
+ dummy := (text anf - 1) * blank;
+ dummy CAT subtext (puffer, zeichenpos);
+ IF format file in situ
+ THEN insert record (eingabe)
+ FI;
+ write record (eingabe, dummy).
+END PROC fuelle ggf zeile vor foot auf;
+
+(*************** Tabulator- und Tabellen verarbeitung ******************)
+
+PROC tabulatorposition eintragen (INT CONST tab type):
+ ROW 3 INT VAR akt tab pos;
+ IF anz tabs >= max tabs
+ THEN fehler (32, "")
+ ELIF tab in cm umwandeln (par1, tab pos in pitches)
+ THEN IF tab type = b pos AND tab in cm umwandeln (par2, bis tab)
+ THEN
+ ELSE bis tab := 0
+ FI;
+ TEXT VAR zentrierzeichen;
+ IF tab type = d pos
+ THEN zentrierzeichen := par2
+ ELSE zentrierzeichen := ""
+ FI;
+ tabs sortiert eintragen
+ FI.
+
+tabs sortiert eintragen:
+ INT VAR i;
+ type tab := tab type;
+ FOR i FROM 1 UPTO anz tabs REP
+ IF tab pos in pitches = tabs [i] [1]
+ THEN fehler (42, par1);
+ LEAVE tabulatorposition eintragen
+ ELIF tabs [i] [1] > tab pos in pitches
+ THEN vertauschen
+ FI;
+ IF ueberschneidende bpos
+ THEN fehler (12, text (xstepconversion (tab pos in pitches)))
+ FI;
+ END REP;
+ anz tabs INCR 1;
+ tabs [anz tabs] := akt tab pos;
+ tab zeichen [anz tabs] := zentrierzeichen.
+
+ueberschneidende bpos:
+ tabs [i] [2] = bpos AND naechste anfang pos liegt in diesem bpos bereich.
+
+naechste anfang pos liegt in diesem bpos bereich:
+ tab pos in pitches <= tabs [i] [3].
+
+vertauschen:
+ ROW 3 INT CONST hilf1 :: tabs [i];
+ TEXT CONST thilf :: tab zeichen [i];
+ tabs [i] := akt tab pos;
+ tab zeichen [i] := zentrierzeichen;
+ akt tab pos := hilf1;
+ zentrierzeichen := thilf.
+
+tab pos in pitches:
+ akt tab pos [1].
+
+type tab:
+ akt tab pos [2].
+
+bis tab:
+ akt tab pos [3].
+END PROC tabulatorposition eintragen;
+
+BOOL PROC tab in cm umwandeln (TEXT CONST text wert, INT VAR f breite):
+ REAL VAR cm := real (text wert);
+ IF last conversion ok AND pos (text wert, ".") <> 0
+ THEN umwandeln
+ ELSE fehler (4, par1);
+ TRUE
+ FI.
+
+umwandeln:
+ conversion (cm, f breite);
+ IF f breite > aktuelle pitch zeilenlaenge
+ THEN fehler (39, par1)
+ ELIF cm = fehlerwert
+ THEN
+ ELSE LEAVE tab in cm umwandeln WITH TRUE
+ FI;
+ FALSE
+END PROC tab in cm umwandeln;
+
+PROC cm angabe der druckposition in dummy (INT CONST nr):
+ dummy := text (x step conversion (tabs [nr] [1]));
+ IF (dummy SUB length (dummy)) = "."
+ THEN dummy CAT "0"
+ FI;
+ dummy CAT " cm"
+END PROC cm angabe der druckposition in dummy;
+
+PROC tabulator position loeschen:
+ INT VAR tab pos in pitches;
+ IF tab in cm umwandeln (par1, tab pos in pitches)
+ THEN versuche zu loeschen
+ FI.
+
+versuche zu loeschen:
+ INT VAR i;
+ FOR i FROM 1 UPTO anz tabs REP
+ IF tab pos in pitches = tabs [i] [1]
+ THEN verschiebe eintraege nach unten;
+ LEAVE tabulator position loeschen
+ FI
+ END REP;
+ fehler (43, par1).
+
+verschiebe eintraege nach unten:
+ INT VAR k;
+ FOR k FROM i UPTO anz tabs - 1 REP
+ tabs [k] := tabs [k + 1];
+ tab zeichen [k] := tab zeichen [k + 1];
+ END REP;
+ anz tabs DECR 1.
+END PROC tabulatorposition loeschen;
+
+PROC verarbeite tabelle:
+ in tabelle := TRUE;
+ pitch table auf blank ausgang setzen;
+ verarbeite tabellenzeilen;
+ pitch table auf blank setzen;
+ IF suchausgang gesetzt
+ THEN pitch table [pos tab zeichen in pitch table] :=
+ breite erstes dezimalzeichen;
+ suchausgang gesetzt := FALSE;
+ FI;
+ in tabelle := FALSE.
+
+verarbeite tabellenzeilen:
+ WHILE pufferlaenge <> 0 REP
+ ueberpruefe tabellenzeile;
+ zeichenpos := pufferlaenge;
+ neue zeile auffuellen und ausgabe bei zeilenende
+ END REP;
+ puffer := " ";
+ pufferlaenge := 1;
+ zeichenpos := 1;
+ fehler (49, "").
+
+ueberpruefe tabellenzeile:
+(* Achtung: Zeilenbreite ist Spaltenbreite;
+ tab zeilen breite ist Summe der Spalten und Positionen *)
+ INT VAR tab zeilen breite :: 0,
+ tab no :: 1;
+ WHILE noch tab positionen OR only command line (puffer) REP
+ positioniere auf naechste spalte;
+ errechne spaltenbreite;
+ IF anz tabs > 0
+ THEN ueberpruefe ob es passt;
+ FI;
+ tab no INCR 1
+ END REP;
+ IF tabellenzeile breiter als limit
+ THEN warnung (10, "")
+ ELIF noch mehr spaltentexte AND anz tabs <> 0
+ THEN warnung (11, subtext (puffer, zeichenpos))
+ FI.
+
+noch tab positionen:
+ tab no <= anz tabs.
+
+positioniere auf naechste spalte:
+ zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos);
+ IF leerzeile oder rest der zeile ist leer
+ THEN IF NOT only command line (puffer) AND pufferlaenge > 1
+ THEN warnung (14, "")
+ FI;
+ LEAVE ueberpruefe tabellenzeile
+ FI.
+
+leerzeile oder rest der zeile ist leer:
+ zeichenpos <= 0.
+
+errechne spaltenbreite:
+ zeilenbreite := 0;
+ BOOL VAR suchausgang gesetzt :: FALSE;
+ IF diese position ist dezimal pos
+ THEN setze dezimalzeichen auf suchausgang
+ FI;
+ REP
+ stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
+ puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
+ zeichenpos INCR 1;
+ IF zeichenwert ausgang = blank ausgang
+ THEN behandele dieses blank
+ ELIF zeichenwert ausgang = kommando ausgang
+ THEN verarbeite das kommando
+ ELIF zeichenwert ausgang = extended char ausgang
+ THEN char pos move (vorwaerts);
+ zeilenbreite INCR breite (puffer, zeichenpos);
+ char pos move (vorwaerts)
+ ELIF zeichenwert ausgang = such ausgang
+ THEN verarbeite ersten teil der dezimal zentrierung
+ ELIF zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN fehler (23, "");
+ LEAVE ueberpruefe tabellenzeile
+ ELIF zeilenbreite + zeichenwert ausgang > aktuelle pitch zeilenlaenge
+ THEN fehler (36, "");
+ LEAVE ueberpruefe tabellenzeile
+ ELSE tabellenzeile ohne absatz
+ FI
+ END REP.
+
+diese position ist dezimal pos:
+ tabs [tab no] [2] = dpos.
+
+setze dezimalzeichen auf suchausgang:
+ INT CONST pos tab zeichen in pitch table ::
+ code (tab zeichen [tab no] SUB 1) + 1;
+ INT VAR breite erstes dezimalzeichen :=breite (tab zeichen [tab no] SUB 1),
+ breite excl dezimalzeichen := 0;
+ suchausgang gesetzt := TRUE;
+ pitch table [pos tab zeichen in pitch table] := such ausgang.
+
+verarbeite ersten teil der dezimal zentrierung:
+ IF pos (puffer, tab zeichen [tab no], zeichenpos) = zeichenpos
+ THEN pitch table [pos tab zeichen in pitch table] :=
+ breite erstes dezimalzeichen;
+ suchausgang gesetzt := FALSE;
+ breite excl dezimalzeichen := zeilenbreite
+ FI;
+ zeilenbreite INCR breite (puffer SUB zeichenpos);
+ zeichenpos INCR 1.
+
+behandele dieses blank:
+ IF doppelblank OR absatz
+ THEN LEAVE errechne spaltenbreite
+ ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp;
+ zeichenpos INCR 1
+ FI.
+
+doppelblank:
+ (puffer SUB zeichenpos + 1) = blank.
+
+verarbeite das kommando:
+ pitch table auf blank setzen;
+ verarbeite kommando und neue zeile auffuellen;
+ pitch table auf blank ausgang setzen;
+ IF kommando index = table end
+ THEN LEAVE verarbeite tabellenzeilen
+ ELIF suchausgang gesetzt AND
+ pitch table [pos tab zeichen in pitch table] <> suchausgang
+ THEN pitch table [pos tab zeichen in pitch table] := suchausgang
+ FI.
+
+tabellenzeile ohne absatz:
+ IF zeilenende eines macros
+ THEN zeile in puffer und zeile lesen;
+ zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos);
+ ELSE LEAVE errechne spaltenbreite
+ FI.
+
+zeilenende eines macros:
+ zeichenwert ausgang = zeilenende ausgang AND macro works.
+
+ueberpruefe ob es passt:
+ INT CONST akt tab pos :: tabs [tab no] [1];
+ IF vorherige spalte ueberschreibt tabulator position
+ THEN cm angabe der druckposition in dummy (tab no - 1);
+ fehler (44, dummy);
+ tab zeilenbreite := akt tab pos
+ ELIF only command line (puffer)
+ THEN
+ ELSE ueberpruefe nach art des tabulators
+ FI.
+
+ueberpruefe nach art des tabulators:
+ IF tabs [tab no] [2] = r pos
+ THEN nach links schreibend
+ ELIF tabs [tab no] [2] = l pos
+ THEN nach rechts schreibend
+ ELIF tabs [tab no] [2] = b pos
+ THEN nach rechts blockend schreibend
+ ELIF tabs [tab no] [2] = c pos
+ THEN zentrierend
+ ELSE zentrierend um zeichen
+ FI.
+
+vorherige spalte ueberschreibt tabulator position:
+ tab zeilenbreite > akt tab pos.
+
+nach links schreibend:
+ IF tab zeilenbreite + zeilenbreite > akt tab pos
+ THEN cm angabe der druckposition in dummy (tab no);
+ fehler (45, dummy);
+ FI;
+ tab zeilenbreite := akt tab pos.
+
+nach rechts schreibend:
+ tab zeilenbreite := akt tab pos + zeilenbreite.
+
+nach rechts blockend schreibend:
+ IF akt tab pos + zeilenbreite > tabs [tab no] [3]
+ THEN cm angabe der druckposition in dummy (tab no);
+ fehler (48, dummy)
+ FI;
+ tab zeilenbreite := tabs [tab no] [3].
+
+zentrierend:
+ IF tab zeilenbreite + (zeilenbreite DIV 2) > akt tab pos
+ THEN cm angabe der druckposition in dummy (tab no);
+ fehler (46, dummy)
+ FI;
+ tab zeilenbreite := akt tab pos + (zeilenbreite DIV 2).
+
+zentrierend um zeichen:
+ IF breite excl dezimalzeichen = 0
+ THEN cm angabe der druckposition in dummy (tab no);
+ fehler (50, dummy)
+ ELIF tab zeilenbreite + breite excl dezimalzeichen > akt tab pos
+ THEN cm angabe der druckposition in dummy (tab no);
+ fehler (47, dummy)
+ FI;
+ IF suchausgang gesetzt
+ THEN pitch table [pos tab zeichen in pitch table] :=
+ breite erstes dezimalzeichen;
+ suchausgang gesetzt := FALSE;
+ FI;
+ tab zeilenbreite := akt tab pos +
+ (zeilenbreite - breite excl dezimalzeichen).
+
+tabellenzeile breiter als limit:
+ tab zeilenbreite > aktuelle pitch zeilenlaenge + einrueckbreite.
+
+noch mehr spaltentexte:
+ pos (puffer, ""33"", ""255"", zeichenpos) <> 0.
+END PROC verarbeite tabelle;
+
+(*********************** referenzen ueberpruefen **********************)
+
+PROC aktuelle referenz erstellen:
+ aktuelle referenz := "#";
+ aktuelle referenz CAT par1;
+ aktuelle referenz CAT "#";
+END PROC aktuelle referenz erstellen;
+
+PROC zielreferenzen speichern ohne warnung:
+ aktuelle referenz erstellen;
+ IF pos (zielreferenzen, aktuelle referenz) = 0
+ THEN delete char (aktuelle referenz, 1);
+ zielreferenzen CAT aktuelle referenz
+ FI
+END PROC zielreferenzen speichern ohne warnung;
+
+PROC zielreferenzen speichern:
+ aktuelle referenz erstellen;
+ IF pos (zielreferenzen, aktuelle referenz) <> 0
+ THEN warnung (9, par1)
+ ELSE delete char (aktuelle referenz, 1);
+ zielreferenzen CAT aktuelle referenz
+ FI
+END PROC zielreferenzen speichern;
+
+PROC herkunftsreferenzen speichern:
+ aktuelle referenz erstellen;
+ IF pos (herkunftsreferenzen, aktuelle referenz) = 0
+ THEN delete char (aktuelle referenz, 1);
+ herkunftsreferenzen CAT aktuelle referenz
+ FI
+END PROC herkunftsreferenzen speichern;
+
+PROC referenzen ueberpruefen:
+ ueberpruefe zielreferenzen;
+ ueberpruefe restliche herkunftsreferenzen.
+
+ueberpruefe zielreferenzen:
+ REP
+ hole naechste zielreferenz;
+ IF pos (herkunfts referenzen, aktuelle referenz) = 0
+ THEN change all (aktuelle referenz,"#", "");
+ warnung (3, aktuelle referenz)
+ ELSE delete char (aktuelle referenz, length (aktuelle referenz));
+ change (herkunftsreferenzen, aktuelle referenz, "");
+ FI
+ END REP.
+
+hole naechste zielreferenz:
+ IF length (zielreferenzen) > 1
+ THEN aktuelle referenz :=
+ subtext (zielreferenzen, 1, pos (zielreferenzen, "#", 2));
+ zielreferenzen :=
+ subtext (zielreferenzen, pos (zielreferenzen, "#", 2))
+ ELSE LEAVE ueberpruefe zielreferenzen
+ FI.
+
+ueberpruefe restliche herkunftsreferenzen:
+ WHILE length (herkunftsreferenzen) > 1 REP
+ aktuelle referenz :=
+ subtext (herkunftsreferenzen, 1, pos (herkunftsreferenzen, "#", 2) - 1);
+ change (herkunftsreferenzen, aktuelle referenz, "");
+ delete char (aktuelle referenz, 1);
+ warnung (4, aktuelle referenz)
+ END REP.
+END PROC referenzen ueberpruefen;
+
+(*************************** Utilities *******************************)
+
+INT PROC breite (TEXT CONST z):
+ INT VAR b;
+ IF z = ""
+ THEN display and pause (1)
+ ELIF z = kommandozeichen
+ THEN display and pause (2); b := 1
+ ELSE b := pitch table [code (z) + 1]
+ FI;
+ IF zeilenbreite > maxint - b
+ THEN display and pause (3); b := 1
+ FI;
+ b.
+END PROC breite;
+
+INT PROC breite (TEXT CONST ein text, INT CONST zpos):
+ TEXT CONST z :: ein text SUB zpos;
+ INT VAR zeichen breite;
+ IF z = ""
+ THEN display and pause (4); zeichen breite := 1
+ ELIF z = kommandozeichen
+ THEN display and pause (6); zeichen breite := 1
+ ELSE zeichen breite := pitch table [code (z) + 1]
+ FI;
+ IF zeichen breite = extended char ausgang
+ THEN zeichen breite := extended char pitch (font nr,
+ ein text SUB zpos, ein text SUB zpos + 1)
+ FI;
+ zeichen breite
+END PROC breite;
+
+PROC char pos move (INT CONST richtung):
+ char pos move (zeichenpos, richtung)
+END PROC char pos move;
+
+PROC char pos move (INT VAR zpos, INT CONST richtung):
+ char pos move (puffer, zpos, richtung)
+END PROC char pos move;
+
+BOOL PROC absatz:
+ zeichenpos = pufferlaenge AND puffer hat absatz
+END PROC absatz;
+
+BOOL PROC puffer hat absatz:
+ NOT within kanji (puffer, pufferlaenge) AND
+ (puffer SUB pufferlaenge) = blank
+END PROC puffer hat absatz;
+
+PROC pitch table auf blank ausgang setzen:
+ IF pitch table [code (blank) + 1] <> blank ausgang
+ THEN blank breite fuer diesen schrifttyp := breite (blank);
+ pitch table [code (blank) + 1] := blank ausgang
+ FI
+END PROC pitch table auf blank ausgang setzen;
+
+PROC pitch table auf blank setzen:
+ pitch table [code (blank) + 1] := blank breite fuer diesen schrifttyp
+END PROC pitch table auf blank setzen;
+
+(*PROC zustands test (TEXT CONST anf):
+line ;put(anf);
+line ;put("zeilenbreite, aktuelle pitch zeilenlaenge:");
+ put(zeilenbreite);put(aktuelle pitch zeilenlaenge);
+line ;put("zeichenpos, pufferlaenge, ausgang, zeichen:");
+put(zeichenpos);put(pufferlaenge);
+IF zeichenwert ausgang = blank ausgang
+ THEN put ("blank")
+ELIF zeichenwert ausgang = kommando ausgang
+ THEN put ("kommando")
+ELIF zeichenwert ausgang = such ausgang
+ THEN put ("such")
+ELIF zeichenwert ausgang = zeilenende ausgang
+ THEN put ("zeilenende")
+ ELSE put(zeichenwert ausgang);
+FI; put ("ausgang");
+out(">");out(puffer SUB zeichenpos);out("<");
+line ;out("puffer >");
+IF length (puffer) > 65
+ THEN outsubtext (puffer, 1, 65);
+ line ; outsubtext (puffer, 66)
+ ELSE out(puffer);
+FI;
+out("<");
+line ;out("zeile >");
+IF length (zeile) > 65
+ THEN outsubtext (zeile, 1, 65);
+ line ; outsubtext (zeile, 66)
+ ELSE out (zeile);
+FI;
+out("<");
+line ;out("neue zeile >");
+IF length (neue zeile) > 65
+ THEN outsubtext (neue zeile, 1, 65);
+ line ; outsubtext (neue zeile, 66)
+ ELSE out(neue zeile);
+FI;
+out("<");
+line ;
+END PROC zustands test;*)
+
+(*************************** eigentliche form routine ********************)
+
+PROC zeilen form (TEXT CONST datei):
+ enable stop;
+ form initialisieren (datei);
+ formiere absatzweise;
+ letzte neue zeile ausgeben.
+
+formiere absatzweise:
+ REP
+ letzter puffer war absatz := FALSE;
+ einrueckbreite := eingestellte indentation pitch;
+ IF einfacher absatz nach absatz
+ THEN gebe einfachen absatz aus
+ ELSE verarbeite abschnitt nach absatz
+ FI
+ UNTIL pufferlaenge = 0 END REP.
+
+einfacher absatz nach absatz:
+ absatz.
+
+gebe einfachen absatz aus:
+ neue zeile := blank;
+ ausgabe bei zeilenende.
+
+verarbeite abschnitt nach absatz:
+ berechne erste zeile nach absatz;
+ IF NOT letzter puffer war absatz
+ THEN formiere
+ FI.
+
+formiere:
+ INT VAR letzte zeilennr;
+ REP
+ stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
+ puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
+ IF zeichenwert ausgang = kommando ausgang
+ THEN zeichenpos INCR 1;
+ verarbeite kommando und neue zeile auffuellen;
+ IF letzter puffer war absatz
+ THEN ausgabe bei zeilenende;
+ LEAVE verarbeite abschnitt nach absatz
+ ELIF zeichenpos > pufferlaenge OR absatz
+ THEN letzte zeilennr := zeilennr;
+ verarbeite letztes zeichen von puffer;
+ IF neue zeile ausgeloest
+ THEN LEAVE verarbeite abschnitt nach absatz
+ ELSE letzter puffer war absatz := FALSE
+ FI
+ FI
+ ELIF zeichenwert ausgang = extended char ausgang
+ THEN char pos move (vorwaerts);
+ zeilenbreite INCR breite (puffer, zeichenpos);
+ char pos move (vorwaerts)
+ ELIF zeichenwert ausgang = zeilenende ausgang
+ OR zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN letzte zeilennr := zeilennr;
+ verarbeite letztes zeichen von puffer;
+ IF zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN fehler (23, "")
+ FI;
+ IF neue zeile ausgeloest
+ THEN LEAVE verarbeite abschnitt nach absatz
+ ELSE letzter puffer war absatz := FALSE
+ FI
+ ELSE ende einer neuen zeile
+ FI;
+ UNTIL pufferlaenge = 0 END REP.
+
+neue zeile ausgeloest:
+ letzte zeilennr < zeilennr.
+END PROC zeilen form;
+
+PROC berechne erste zeile nach absatz:
+ INT CONST anz einrueckungszeichen :: zeilenbreite DIV einrueckbreite;
+ INT VAR anz zeichen fuer einzeilige einrueckung :: 0,
+ anz zeichen :: 0,
+ schlepper zeichenpos :: 1,
+ letzte zeilennr;
+ BOOL CONST puffer hatte anfangs absatz :: puffer hat absatz;
+ BOOL VAR noch kein blank gewesen :: TRUE;
+ pitch table auf blank ausgang setzen;
+ berechne erste zeile;
+ pitch table auf blank setzen.
+
+berechne erste zeile:
+ REP
+ stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
+ puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
+ IF zeichenwert ausgang = blank ausgang
+ THEN verarbeite text
+ ELIF zeichenwert ausgang = extended char ausgang
+ THEN char pos move (vorwaerts);
+ zeilenbreite INCR breite (puffer, zeichenpos);
+ char pos move (vorwaerts)
+ ELIF zeichenwert ausgang = kommando ausgang
+ THEN verarbeite dieses kommando
+ ELIF zeichenwert ausgang = zeilenende ausgang
+ OR zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN behandele zu kurze zeile
+ ELSE behandele zu lange zeile
+ FI
+ END REP.
+
+verarbeite dieses kommando:
+ textzeichen mitzaehlen;
+ IF pos (" #", (puffer SUB zeichenpos)) = 0
+ THEN aufzaehlungszeichen := (puffer SUB zeichenpos)
+ FI;
+ char pos move (vorwaerts);
+ mitzuzaehlende zeichen := 0;
+ pitch table auf blank setzen;
+ verarbeite kommando und neue zeile auffuellen;
+ pitch table auf blank ausgang setzen;
+ IF letzter puffer war absatz
+ THEN neue zeile auffuellen und ausgabe bei zeilenende;
+ LEAVE berechne erste zeile
+ ELIF zeichenpos > pufferlaenge OR absatz
+ THEN letzte zeilennr := zeilennr;
+ verarbeite letztes zeichen von puffer;
+ IF neue zeile ausgeloest
+ THEN LEAVE berechne erste zeile
+ ELSE letzter puffer war absatz := FALSE
+ FI
+ ELIF anweisung erlaubt keine aufzaehlung
+ THEN LEAVE berechne erste zeile
+ FI;
+ anz zeichen INCR mitzuzaehlende zeichen;
+ schlepper zeichenpos := zeichenpos.
+
+neue zeile ausgeloest:
+ letzte zeilennr < zeilennr.
+
+anweisung erlaubt keine aufzaehlung:
+ kommando index = center OR kommando index = right.
+
+verarbeite text:
+ char pos move (vorwaerts);
+ IF absatz
+ THEN verarbeite letztes zeichen von puffer;
+ LEAVE berechne erste zeile
+ ELIF zeilenbreite + blankbreite fuer diesen schrifttyp >
+ aktuelle pitch zeilenlaenge
+ THEN behandele zu lange zeile
+ ELIF mehrfaches blank
+ THEN positionierung mit doppelblank
+ ELIF noch kein blank gewesen AND
+ anz zeichen +
+ number chars (puffer, schlepper zeichenpos, zeichenpos) <= 20
+ THEN ggf aufzaehlung aufnehmen
+ ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp
+ FI;
+ noch kein blank gewesen := FALSE;
+ zeichenpos INCR 1.
+
+mehrfaches blank:
+ (puffer SUB zeichenpos + 1) = blank.
+
+positionierung mit doppelblank:
+ WHILE NOT within kanji (puffer, zeichenpos + 1) AND
+ (puffer SUB zeichenpos + 1) = blank REP
+ zeichenpos INCR 1
+ END REP;
+ textzeichen mitzaehlen;
+ pruefe auf ueberschreibung
+ (zeilenbreite, anz zeichen + anz einrueckungszeichen).
+
+ggf aufzaehlung aufnehmen:
+ IF NOT within kanji (puffer, zeichenpos - 1) AND
+ (puffer SUB zeichenpos - 1) <> kommandozeichen
+ THEN aufzaehlungszeichen := (puffer SUB zeichenpos - 1);
+ FI;
+ textzeichen mitzaehlen;
+ IF aufzaehlungszeichen = ":"
+ OR (aufzaehlungszeichen = "-" AND anz zeichen <= 2)
+ OR (anz zeichen <= 7 AND ( aufzaehlungszeichen = ")"
+ OR aufzaehlungszeichen = "."))
+ THEN anz zeichen fuer einzeilige einrueckung := anz zeichen;
+ pruefe auf ueberschreibung
+ (zeilenbreite, anz zeichen + anz einrueckungszeichen)
+ ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp
+ FI.
+
+textzeichen mitzaehlen:
+ anz zeichen INCR number chars (puffer, schlepper zeichenpos, zeichenpos);
+ IF is kanji esc (puffer SUB zeichenpos)
+ THEN schlepper zeichenpos := zeichenpos + 2
+ ELSE schlepper zeichenpos := zeichenpos + 1
+ FI.
+
+behandele zu kurze zeile:
+ textzeichen mitzaehlen;
+ IF zeichenwert ausgang = esc char ohne zweites byte ausgang
+ THEN fehler (23, "");
+ neue zeile auffuellen;
+ schreibe und initialisiere neue zeile;
+ zeichenpos := 1;
+ LEAVE berechne erste zeile
+ FI;
+ letzte zeilennr := zeilennr;
+ verarbeite letztes zeichen von puffer;
+ IF neue zeile ausgeloest
+ THEN LEAVE berechne erste zeile
+ FI;
+ schlepper zeichenpos := 1.
+
+behandele zu lange zeile:
+ pitch table auf blank setzen;
+ IF zeilenende bei erstem zeichen
+ THEN loesche nachfolgende blanks;
+ schreibe und initialisiere neue zeile;
+ zeichenpos := 1;
+ LEAVE berechne erste zeile
+ ELIF (puffer SUB zeichenpos) = kommandozeichen
+ THEN zeichenpos INCR 1
+ ELSE zeilenbreite DECR breite (puffer, zeichenpos)
+ FI;
+ IF puffer hatte anfangs absatz
+ THEN einrueckung gemaess pufferanfang
+ FI;
+ LEAVE berechne erste zeile.
+
+zeilenende bei erstem zeichen:
+ zeichenpos < 1.
+
+einrueckung gemaess pufferanfang:
+alte blanks :=
+(anz einrueckungszeichen + anz zeichen fuer einzeilige einrueckung) * blank.
+END PROC berechne erste zeile nach absatz;
+
+PROC pruefe auf ueberschreibung (INT CONST aufzaehlungsbreite,
+ anz aufzaehlungszeichen):
+ IF ueberschreibung
+ THEN fehlende blanks errechnen;
+ INT VAR aufzaehlungsende :: zeichenpos - 1;
+ WHILE (puffer SUB aufzaehlungsende) = blank REP
+ aufzaehlungsende DECR 1
+ END REP;
+ dummy := ">";
+ dummy CAT subtext (puffer,
+ aufzaehlungsende - 15, aufzaehlungsende);
+ dummy CAT "< Fehlende Blanks: ";
+ dummy CAT text (anz fehlende blanks);
+ warnung (12, dummy)
+ FI;
+ zeilenbreite := anz aufzaehlungszeichen * einrueckbreite.
+
+ueberschreibung:
+ INT CONST anz zeichen mal einrueckbreite ::
+ anz aufzaehlungszeichen * einrueckbreite,
+ min zwischenraum :: (einrueckbreite DIV 4);
+ aufzaehlungsbreite + min zwischenraum > anz zeichen mal einrueckbreite.
+
+fehlende blanks errechnen:
+ INT VAR anz fehlende blanks ::
+ (aufzaehlungsbreite + min zwischenraum
+ - anz zeichen mal einrueckbreite + einrueckbreite - 1)
+ DIV einrueckbreite.
+END PROC pruefe auf ueberschreibung;
+
+(********************** eingabe routinen **************************)
+
+PROC zeile lesen:
+ alte blanks := aktuelle blanks;
+ hole zeile;
+ behandele einrueckung.
+
+hole zeile:
+ IF macro works
+ THEN get macro line (zeile);
+ ELIF eof (eingabe)
+ THEN zeile := "";
+ LEAVE zeile lesen
+ ELSE lesen
+ FI;
+ IF zeile = ""
+ THEN zeile := blank
+ ELIF (zeile SUB length (zeile) - 1) = blank
+ THEN ggf ueberfluessige leerzeichen am ende entfernen
+ FI.
+
+lesen:
+ IF format file in situ
+ THEN read record (eingabe, zeile);
+ delete record (eingabe)
+ ELSE read record (eingabe, zeile);
+ down (eingabe)
+ FI.
+
+ggf ueberfluessige leerzeichen am ende entfernen:
+ WHILE NOT within kanji (zeile, length (zeile) - 1) AND
+ subtext (zeile, length (zeile) - 1) = " " REP
+ delete char (zeile, length (zeile))
+ END REP.
+
+behandele einrueckung:
+ aktuelle blanks := "";
+ IF zeile <> blank
+ THEN INT VAR einrueckung := pos (zeile, ""33"", ""255"", 1);
+ IF einrueckung > 1
+ THEN aktuelle blanks := subtext (zeile, 1, einrueckung - 1);
+ zeile := subtext (zeile, einrueckung)
+ FI
+ FI
+END PROC zeile lesen;
+
+PROC zeile in puffer und zeile lesen:
+ puffer := zeile;
+ zeichenpos := 1;
+ von := 1;
+ zeile lesen;
+ pufferlaenge := length (puffer);
+ ggf absatz an puffer anfuegen;
+END PROC zeile in puffer und zeile lesen;
+
+PROC ggf absatz an puffer anfuegen:
+ IF (zeile ist nur absatz AND NOT puffer hat absatz)
+ OR (NOT puffer hat absatz AND only command line (puffer)
+ AND only command line (zeile))
+ THEN puffer CAT blank;
+ pufferlaenge := length (puffer)
+ ELIF puffer ist nur absatz AND (zeile SUB length (zeile)) <> " " AND
+ only command line (zeile)
+ THEN zeile CAT " "
+ FI.
+
+puffer ist nur absatz:
+ puffer = blank.
+
+zeile ist nur absatz:
+ zeile = blank.
+END PROC ggf absatz an puffer anfuegen;
+
+(****************** routinen fuer zeilenende behandlung ***********)
+
+PROC verarbeite letztes zeichen von puffer:
+ zeichenpos := length (puffer);
+ begin of this char (puffer, zeichenpos);
+ zeichen := puffer SUB zeichenpos;
+ IF trennung vorhanden
+ THEN IF zeile hat richtige laenge
+ THEN neue zeile auffuellen und ausgabe bei zeilenende
+ ELSE getrennte zeilen zusammenziehen
+ FI
+ ELSE neue zeile auffuellen;
+ IF absatz
+ THEN letzter puffer war absatz := TRUE;
+ IF letztes kommando war macro AND macro hat absatz getaetigt
+ THEN zeile in puffer und zeile lesen;
+ initialisiere neue zeile;
+ ELSE ausgabe bei zeilenende;
+ FI
+ ELSE neue zeile ggf weiterfuehren
+ FI
+ FI.
+
+neue zeile ggf weiterfuehren:
+ IF macro end in dieser oder naechster zeile
+ THEN
+ ELIF zeile = ""
+ THEN schreibe und initialisiere neue zeile;
+ letzter puffer war absatz := TRUE
+ ELIF zeilenbreite + blank breite fuer diesen schrifttyp >
+ aktuelle pitch zeilenlaenge
+ THEN loesche nachfolgende blanks;
+ schreibe und initialisiere neue zeile
+ ELIF in neuer zeile steht etwas
+ THEN neue zeile CAT blank;
+ zeilenbreite INCR blank breite fuer diesen schrifttyp
+ FI;
+ zeile in puffer und zeile lesen.
+
+macro end in dieser oder naechster zeile:
+ macro works AND (pos (puffer, "#*") <> 0 OR pos (zeile, "#*") <> 0).
+
+in neuer zeile steht etwas:
+ pos (neue zeile, ""33"", ""255"", 1) <> 0.
+
+letztes kommando war macro:
+ pos (kommando, "macro") <> 0.
+
+macro hat absatz getaetigt:
+ NOT in neuer zeile steht etwas.
+END PROC verarbeite letztes zeichen von puffer;
+
+PROC getrennte zeilen zusammenziehen:
+ zeichen := puffer SUB pufferlaenge;
+ IF NOT within kanji (puffer, pufferlaenge) AND zeichen = trennzeichen
+ THEN zeilenbreite DECR breite (trennzeichen);
+ delete char (puffer, pufferlaenge);
+ pufferlaenge := length (puffer);
+ IF ((puffer SUB pufferlaenge) = trenn k) AND ((zeile SUB 1) = "k")
+ THEN replace (puffer, pufferlaenge, "c");
+ zeilenbreite DECR breite ("k");
+ zeilenbreite INCR breite ("c");
+ FI;
+ zeichenpos := pufferlaenge + 1
+ FI;
+ puffer CAT zeile;
+ zeile lesen;
+ pufferlaenge := length (puffer);
+ ggf absatz an puffer anfuegen;
+END PROC getrennte zeilen zusammenziehen;
+
+BOOL PROC trennung vorhanden:
+ IF within kanji (puffer, pufferlaenge)
+ THEN LEAVE trennung vorhanden WITH FALSE
+ FI;
+ zeichen := puffer SUB pufferlaenge;
+ zeichen = trennzeichen OR wort mit bindestrich.
+
+wort mit bindestrich:
+ zeichen = bindestrich AND kein leerzeichen davor
+ AND NOT naechstes wort ist konjunktion AND kein loser gedankenstrich.
+
+kein leerzeichen davor:
+ NOT within kanji (puffer, pufferlaenge - 1) AND
+ (puffer SUB pufferlaenge - 1) <> blank.
+
+naechstes wort ist konjunktion:
+ pos (zeile, "und") = 1
+ OR pos (zeile, "oder") = 1
+ OR pos (zeile, "bzw") = 1
+ OR pos (zeile, "sowie") = 1.
+
+kein loser gedankenstrich:
+ pufferlaenge > 1.
+END PROC trennung vorhanden;
+
+BOOL PROC zeile hat richtige laenge:
+ zeilenbreite > aktuelle pitch zeilenlaenge - trennbreite
+END PROC zeile hat richtige laenge;
+
+(*********************** ausgabe routinen *******************)
+
+PROC ende einer neuen zeile:
+ IF zeichenpos > 0
+ THEN begin of this char (puffer, zeichenpos);
+ FI;
+ zeichen := puffer SUB zeichenpos;
+ zeichenpos bereits verarbeitet := 0;
+ IF naechstes zeichen ist absatz
+ THEN zeichenpos := pufferlaenge;
+ verarbeite letztes zeichen von puffer;
+ LEAVE ende einer neuen zeile
+ ELIF zeichen = blank
+ THEN neue zeile auffuellen (von, zeichenpos - 1);
+ zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos);
+ von := zeichenpos;
+ ELIF nach zeichenpos beginnt ein neues wort
+ THEN neue zeile auffuellen (von, zeichenpos);
+ zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos + 1);
+ von := zeichenpos
+ ELIF letzter puffer passte genau
+ THEN (* erstes zeichen des neuen puffers > zeilenbreite *)
+ zeichenpos := 1;
+ von := 1
+ ELSE zeichenpos bereits verarbeitet := zeichenpos;
+ trennung eventuell vornehmen;
+ IF erstes wort auf der absatzzeile laesst sich nicht trennen
+ THEN alte blanks := aktuelle blanks
+ FI
+ FI;
+ loesche nachfolgende blanks;
+ IF NOT in foot uebertrag
+ THEN schreibe und initialisiere neue zeile;
+ zeilenbreite und zeichenpos auf das bereits verarbeitete
+ zeichen setzen;
+ FI.
+
+erstes wort auf der absatzzeile laesst sich nicht trennen:
+ pos (neue zeile, ""33"", ""255"", 1) = 0 AND (*keine buchstaben*)
+ length (neue zeile) > 1 AND (*einrueckung*)
+ (neue zeile SUB length (neue zeile)) = blank. (* Absatz *)
+
+naechstes zeichen ist absatz:
+ zeichenpos + 1 = pufferlaenge AND puffer hat absatz.
+
+nach zeichenpos beginnt ein neues wort:
+ (pufferlaenge > zeichenpos + 2) AND (puffer SUB zeichenpos + 1) = blank.
+
+letzter puffer passte genau:
+ zeichenpos <= 0.
+
+zeilenbreite und zeichenpos auf das bereits verarbeitete zeichen setzen:
+ IF zeichenpos bereits verarbeitet <> 0
+ THEN INT VAR bis := zeichenpos, einfuege pos := bis;
+ zeilenbreite um die bereits verarbeiteten zeichen erhoehen;
+ zeichenpos := zeichenpos bereits verarbeitet;
+ IF einfuege pos > 1
+ THEN insert char (puffer, blank, einfuege pos);
+ pufferlaenge := length (puffer);
+ von := einfuege pos + 1;
+ char pos move (vorwaerts)
+ FI;
+ char pos move (vorwaerts);
+ FI.
+
+zeilenbreite um die bereits verarbeiteten zeichen erhoehen:
+ zeichenpos := zeichenpos bereits verarbeitet;
+ WHILE (puffer SUB bis) = kommandozeichen REP
+ bis := pos (puffer, kommandozeichen, bis + 1) + 1
+ END REP;
+ begin of this char (puffer, zeichenpos);
+ WHILE zeichenpos >= bis REP
+ IF (puffer SUB zeichenpos) = kommandozeichen
+ THEN ueberspringe das kommando (puffer, zeichenpos, rueckwaerts)
+ ELSE zeilenbreite INCR breite (puffer, zeichenpos);
+ FI;
+ IF zeichenpos <= 1
+ THEN LEAVE zeilenbreite um die bereits verarbeiteten zeichen erhoehen
+ FI;
+ char pos move (rueckwaerts)
+ END REP.
+END PROC ende einer neuen zeile;
+
+PROC loesche nachfolgende blanks:
+ WHILE NOT within kanji (neue zeile, length (neue zeile)) AND
+ (neue zeile SUB length (neue zeile)) = blank REP
+ delete char (neue zeile, length (neue zeile))
+ END REP
+END PROC loesche nachfolgende blanks;
+
+PROC neue zeile auffuellen:
+ dummy := subtext (puffer, von);
+ neue zeile CAT dummy
+END PROC neue zeile auffuellen;
+
+PROC neue zeile auffuellen (INT CONST from, to):
+ dummy := subtext (puffer, from, to);
+ neue zeile CAT dummy
+END PROC neue zeile auffuellen;
+
+PROC schreibe neue zeile:
+ IF macro works
+ THEN IF alte neue zeile einschliesslich macro ist auszugeben
+ THEN schreibe textteil einschliesslich macro;
+ FI
+ ELSE schreibe;
+ pruefe auf abbruch
+ FI.
+
+alte neue zeile:
+ before macro state . new line.
+
+alter puffer:
+ before macro state . buffer line.
+
+alte neue zeile einschliesslich macro ist auszugeben:
+ INT VAR text anf :: pos (alte neue zeile, ""33"", ""255"", 1);
+ text anf <> 0.
+
+schreibe textteil einschliesslich macro:
+ dummy := neue zeile;
+ neue zeile := alte neue zeile;
+ IF macro hatte absatz danach
+ THEN neue zeile CAT " "
+ ELSE zeilennr INCR 1
+ FI;
+ schreibe;
+ neue zeile := dummy;
+ alte neue zeile := subtext (alte neue zeile, 1, text anf - 1).
+
+macro hatte absatz danach:
+ length (alter puffer) - 1 = length (alte neue zeile) AND
+ (alter puffer SUB length (alter puffer)) = " ".
+
+pruefe auf abbruch:
+ IF incharety = escape
+ THEN errorstop ("Abbruch mit ESC")
+ FI.
+END PROC schreibe neue zeile;
+
+PROC schreibe:
+ IF format file in situ
+ THEN insert record (eingabe);
+ write record (eingabe, neue zeile);
+ down (eingabe)
+ ELSE insert record (ausgabe);
+ write record (ausgabe, neue zeile);
+ down (ausgabe);
+ speicher ueberlauf
+ FI;
+ execute stored commands;
+ IF (neue zeile SUB length (neue zeile)) = blank
+ THEN einrueckbreite := eingestellte indentation pitch
+ FI.
+
+speicher ueberlauf:
+ INT VAR size, used;
+ storage (size, used);
+ IF used > size
+ THEN errorstop ("Speicherengpaß")
+ FI.
+END PROC schreibe;
+
+PROC schreibe und initialisiere neue zeile:
+ schreibe neue zeile;
+ initialisiere neue zeile
+END PROC schreibe und initialisiere neue zeile;
+
+PROC ausgabe bei zeilenende:
+ schreibe und initialisiere neue zeile;
+ zeile in puffer und zeile lesen
+END PROC ausgabe bei zeilenende;
+
+PROC neue zeile auffuellen und ausgabe bei zeilenende:
+ neue zeile auffuellen;
+ schreibe und initialisiere neue zeile;
+ zeile in puffer und zeile lesen
+END PROC neue zeile auffuellen und ausgabe bei zeilenende;
+
+PROC initialisiere neue zeile:
+ einrueckung in die neue zeile;
+ zeilennummer mitzaehlen.
+
+einrueckung in die neue zeile:
+ IF zeichenpos < pufferlaenge AND
+ (puffer hat absatz OR foot ohne absatz am zeilenende)
+ THEN neue zeile := alte blanks
+ ELSE neue zeile := aktuelle blanks
+ FI;
+ zeilenbreite := length (neue zeile) * einrueckbreite;
+ IF zeilenbreite +trennbreite +einrueckbreite >= aktuelle pitch zeilenlaenge
+ THEN fehler (10, "");
+ zeilenbreite := 0;
+ FI.
+
+foot ohne absatz am zeilenende:
+ pos (puffer, "#foot#") > 1 AND pos (puffer, "#foot#") = length (puffer) -5.
+
+zeilennummer mitzaehlen:
+ IF NOT macro works
+ THEN zeilennr INCR 1;
+ cout (zeilennr);
+ FI.
+END PROC initialisiere neue zeile;
+
+PROC letzte neue zeile ausgeben:
+ IF pos (neue zeile, ""33"", ""255"", 1) <> 0
+ THEN schreibe neue zeile
+ FI;
+ offene modifikationen ausgeben;
+ offene indizes ausgeben;
+ IF aktueller editor < 1
+ THEN referenzen ueberpruefen;
+ offene counter referenzen ausgeben;
+ FI.
+
+offene modifikationen ausgeben:
+ WHILE length (modifikations speicher) <> 0 REP
+ dummy := (modifikations speicher SUB 1);
+ delete char (modifikations speicher, 1);
+ dummy CAT " in Zeile ";
+ dummy CAT text (mod zeilennr speicher ISUB 1);
+ delete int (mod zeilennr speicher, 1);
+ warnung (5, dummy)
+ END REP.
+
+offene indizes ausgeben:
+ WHILE length (index speicher) <> 0 REP
+ dummy := (index speicher SUB 1);
+ delete char (index speicher, 1);
+ dummy CAT " in Zeile ";
+ dummy CAT text (ind zeilennr speicher ISUB 1);
+ delete int (ind zeilennr speicher, 1);
+ warnung (6, dummy)
+ END REP.
+
+offene counter referenzen ausgeben:
+ INT VAR begin pos := pos (counter reference store, "#");
+ WHILE begin pos > 0 REP
+ INT VAR end pos := pos (counter reference store, "#", begin pos + 1);
+ IF (counter reference store SUB begin pos - 1) <> "u"
+ THEN fehler (60, subtext (counter reference store, begin pos + 1,
+ end pos - 1))
+ ELIF (counter reference store SUB begin pos - 2) <> "i"
+ THEN fehler (61, subtext (counter reference store, begin pos + 1,
+ end pos - 1))
+ FI;
+ begin pos := pos (counter reference store, "#", end pos + 1)
+ END REP.
+END PROC letzte neue zeile ausgeben;
+
+(*********************** silbentrenn routinen *******************)
+
+INT PROC position von (TEXT CONST such zeichen, INT CONST richtung,
+ INT VAR anz zeich, breite der z):
+ INT VAR index :: zeichenpos;
+ TEXT VAR akt z;
+ anz zeich := 0;
+ breite der z := 0;
+ WHILE index > 1 AND index < pufferlaenge REP
+ akt z := puffer SUB index;
+ IF akt z = such zeichen
+ THEN LEAVE position von WITH index
+ ELIF akt z = kommandozeichen
+ THEN ueberspringe das kommando (puffer, index, richtung);
+ IF nur ein kommandozeichen gefunden
+ THEN gehe nur bis erstes kommandozeichen
+ ELIF index <= 1 OR index >= pufferlaenge
+ THEN LEAVE position von WITH index
+ FI
+ ELSE anz zeich INCR 1;
+ breite der z INCR breite (puffer, index)
+ FI;
+ char pos move (index, richtung)
+ END REP;
+ anz zeich INCR 1;
+ breite der z INCR breite (puffer, index);
+ index.
+
+nur ein kommandozeichen gefunden:
+ (puffer SUB index) <> kommandozeichen.
+
+gehe nur bis erstes kommandozeichen:
+ index := zeichenpos; anz zeich := 0; breite der z := 0;
+ WHILE (puffer SUB index) <> kommandozeichen REP
+ anz zeich INCR 1;
+ breite der z INCR breite (puffer, index);
+ char pos move (index, richtung)
+ END REP;
+ IF richtung <> rueckwaerts
+ THEN index DECR 1
+ FI;
+ LEAVE position von WITH index.
+END PROC position von;
+
+PROC ueberspringe das kommando (TEXT CONST t, INT VAR i, INT CONST richtung):
+ REP
+ i INCR richtung;
+ IF within kanji (t, i)
+ THEN i INCR richtung
+ FI
+ UNTIL (t SUB i) = kommandozeichen OR i <= 1 OR i >= length (t) END REP.
+END PROC ueberspringe das kommando;
+
+PROC trennung eventuell vornehmen:
+INT VAR xwort1, ywort1,
+ anz zeichen davor,
+ breite davor;
+ IF macro works
+ THEN fehler (6, "")
+ FI;
+ trennsymbol := trennzeichen;
+ wortanfang := position von
+ (blank, rueckwaerts, anz zeichen davor, breite davor);
+ bereite neue zeile bis wortanfang auf;
+ IF trennung sinnvoll
+ THEN versuche zu trennen
+ ELSE zeichenpos := wortanfang
+ FI.
+
+bereite neue zeile bis wortanfang auf:
+ IF wortanfang > 1
+ THEN wortanfang INCR 1
+ FI;
+ IF von > wortanfang
+ THEN eliminiere zeichen in neuer zeile bis wortanfang
+ ELSE neue zeile auffuellen (von, wortanfang - 1)
+ FI;
+ von := wortanfang.
+
+eliminiere zeichen in neuer zeile bis wortanfang:
+ INT VAR y :: length (neue zeile);
+ begin of this char (neue zeile, y);
+ WHILE y >= 1 REP
+ IF (neue zeile SUB y) = kommandozeichen
+ THEN ueberspringe das kommando (neue zeile, y, rueckwaerts)
+ FI;
+ char pos move (neue zeile, y, rueckwaerts)
+ UNTIL (neue zeile SUB y) = blank END REP;
+ neue zeile := subtext (neue zeile, 1, y).
+
+trennung sinnvoll:
+ anz zeichen davor > 2 AND breite davor > trennbreite.
+
+versuche zu trennen:
+ INT CONST k := zeichenpos;
+ naechste zeile ggf heranziehen;
+ zeichenpos := k;
+ wortteile holen;
+ trenn (trennwort ohne komm, wort1 ohne komm, trennsymbol,
+ max trennlaenge ohne komm);
+ wort1 mit komm ermitteln;
+ IF lineform mode
+ THEN wort2 := subtext (trennwort, length (wort1) + 1, max trennlaenge);
+ display vorherige zeile bis wortanfang;
+ schreibe nicht trennbaren teil des trennwortes;
+ schreibe zeile nach trennwort;
+ skip input;
+ interaktive worttrennung
+ FI;
+ neue zeile mit trennwort versehen;
+ IF wort1 <> "" AND NOT lineform mode
+ THEN note (zeilen nr); note (": ");
+ note (trennwort);
+ note (" --> ");
+ note (wort1); note (trennsymbol);
+ wort2 := subtext (trennwort, length (wort1) + 1);
+ note (wort2);
+ note line
+ FI.
+
+wortteile holen:
+ zeichenpos durch trennzeichenbreite verschieben;
+ wort1 := subtext (puffer, wortanfang, zeichenpos);
+ max trennlaenge := length (wort1);
+ wortende ermitteln;
+ wort2 := subtext (puffer, zeichenpos, wortende);
+ trennwort := subtext (puffer, wortanfang, wortende);
+ trennwort ohne komm ermitteln;
+ wort1 ohne komm := subtext (trennwort ohne komm, 1, anz zeichen davor);
+ max trenn laenge ohne komm := anz zeichen davor.
+
+trennwort ohne komm ermitteln:
+ trennwort ohne komm := trennwort;
+ WHILE pos (trennwort ohne komm, kommando zeichen) <> 0 REP
+ INT CONST komm anf := pos (trennwort ohne komm, kommando zeichen),
+ komm ende:= pos (trennwort ohne komm, kommando zeichen,
+ komm anf + 1);
+ IF komm ende = 0
+ THEN LEAVE trennwort ohne komm ermitteln
+ FI;
+ dummy := subtext (trennwort ohne komm, komm ende + 1);
+ trennwort ohne komm := subtext (trennwort ohne komm, 1, komm anf - 1);
+ trennwort ohne komm CAT dummy;
+ END REP.
+
+wort1 mit komm ermitteln:
+ IF length (wort1 ohne komm) = 0
+ THEN wort1 := "";
+ LEAVE wort1 mit komm ermitteln
+ FI;
+ INT VAR index ohne := 0,
+ index mit := 0;
+ REP
+ index ohne INCR 1;
+ index mit INCR 1;
+ WHILE (wort1 SUB index mit) = kommando zeichen REP
+ index mit := pos (wort1, kommando zeichen, index mit + 1) + 1
+ END REP;
+ UNTIL index ohne >= length (wort1 ohne komm) END REP;
+ wort1 := subtext (wort1, 1, index mit).
+
+zeichenpos durch trennzeichenbreite verschieben:
+ REP
+ zeichen := puffer SUB zeichenpos;
+ IF zeichen = kommandozeichen
+ THEN ueberspringe das kommando (puffer, zeichenpos, rueckwaerts);
+ char pos move (rueckwaerts)
+ ELIF zeichenpos < wortanfang + 1
+ THEN zeichenpos := wortanfang;
+ LEAVE trennung eventuell vornehmen
+ ELSE zeilenbreite DECR breite (puffer, zeichenpos);
+ anz zeichen davor DECR 1;
+ char pos move (rueckwaerts);
+ IF zeilenbreite+breite(trennzeichen) <= aktuellepitchzeilenlaenge
+ AND (puffer SUB zeichenpos) <> kommandozeichen
+ THEN LEAVE zeichenpos durch trennzeichenbreite verschieben
+ FI
+ FI;
+ END REP.
+
+wortende ermitteln:
+ INT VAR x1, x2;
+ wortende := position von (blank, 1, x1, x2);
+ IF pufferlaenge > wortende
+ THEN wortende DECR 1
+ FI.
+
+display vorherige zeile bis wortanfang:
+ dummy := neue zeile;
+ dummy CAT subtext (puffer, von, wortanfang - 2);
+ line ;
+ outsubtext (dummy, length (dummy) - 78).
+
+schreibe nicht trennbaren teil des trennwortes:
+ line ;
+ get cursor (xwort1, ywort1);
+ IF length (trennwort) < 70
+ THEN cursor (max trennlaenge + 4, ywort1);
+ outsubtext (trennwort, max trennlaenge + 1)
+ FI.
+
+schreibe zeile nach trennwort:
+ dummy := subtext (puffer, wortende + 1);
+ get cursor (trennwort endepos, ywort1);
+ IF length (trennwort) >= 70
+ THEN
+ ELIF length (dummy) > 75 - trennwort ende pos
+ THEN outsubtext (dummy, 1, 75 - trennwort endepos);
+ ELSE out (dummy);
+ IF (dummy SUB length (dummy)) = blank
+ THEN cursor (78, ywort1);
+ out (begin mark);
+ out (end mark)
+ FI
+ FI.
+
+trennwort endepos:
+ xwort1.
+
+interaktive worttrennung:
+ REP
+ out (return);
+ schreibe erstes wort;
+ get cursor (xwort1, ywort1);
+ schreibe trennung;
+ schreibe zweites wort;
+ schreibe rest bei zu langem trennwort;
+ cursor (xwort1, ywort1);
+ hole steuerzeichen und veraendere worte
+ END REP.
+
+schreibe erstes wort:
+ out (begin mark);
+ IF length (trennwort) < 70
+ THEN out (wort1)
+ ELSE outsubtext (wort1, length (wort1) - 60)
+ FI.
+
+schreibe trennung:
+ IF ck vorhanden
+ THEN out (links); out ("k");
+ FI;
+ out (trennsymbol).
+
+schreibe zweites wort:
+ IF length (trennwort) < 70
+ THEN out (wort2)
+ ELSE outsubtext (wort2, 1, 70 - xwort1);
+ FI;
+ out (end mark).
+
+schreibe rest bei zu langem trennwort:
+ IF length (trennwort) >= 70
+ THEN INT VAR xakt pos;
+ out (cl eol);
+ get cursor (xakt pos, ywort1);
+ outsubtext (trennwort, max trennlaenge + 1,
+ max trennlaenge + 1 + (78 - xakt pos))
+ FI.
+
+ck vorhanden:
+ (wort1 SUB length (wort1)) = "c" AND
+ (trennwort SUB (length (wort1) + 1)) = "k".
+
+hole steuerzeichen und veraendere worte:
+TEXT VAR steuerzeichen;
+ inchar (steuerzeichen);
+ IF steuerzeichen = links
+ THEN nach links
+ ELIF steuerzeichen = rechts
+ THEN nach rechts
+ ELIF steuerzeichen = hop
+ THEN sprung
+ ELIF steuerzeichen = return
+ THEN line ;
+ LEAVE interaktive worttrennung
+ ELIF steuerzeichen = escape
+ THEN errorstop ("Abbruch mit ESC")
+ ELIF code (steuerzeichen) < 32
+ THEN
+ ELSE trennsymbol := steuerzeichen;
+ LEAVE hole steuerzeichen und veraendere worte
+ FI;
+ IF wort1 = ""
+ OR (wort1 SUB length (wort1)) = bindestrich
+ THEN trennsymbol := blank
+ ELSE trennsymbol := trennzeichen
+ FI.
+
+nach links:
+TEXT VAR ein zeichen;
+INT VAR position;
+ IF length (wort1) <> 0
+ THEN position := length (wort1);
+ IF (wort1 SUB position) = kommando zeichen
+ THEN ueberspringe das kommando (wort1, position, rueckwaerts);
+ FI;
+ position DECR 1;
+ wort1 := subtext (trennwort, 1, position);
+ wort2 := subtext (trennwort, position + 1, max trennlaenge);
+ IF rechtes teilwort mit bindestrich
+ THEN ein zeichen := (wort1 SUB length (wort1));
+ delete char (wort1, length (wort1));
+ insert char (wort2, ein zeichen, 1)
+ FI
+ FI.
+
+nach rechts:
+ IF length (wort1) < max trennlaenge
+ THEN position := length (wort1) + 1;
+ IF (trennwort SUB position) = kommando zeichen
+ THEN ueberspringe das kommando (trennwort, position, +1);
+ FI;
+ wort1 := subtext (trennwort, 1, position);
+ wort2 := subtext (trennwort, position + 1, max trennlaenge);
+ IF rechtes teilwort mit bindestrich
+ THEN wort1 CAT bindestrich;
+ delete char (wort2, 1)
+ FI
+ FI.
+
+rechtes teilwort mit bindestrich:
+ (wort2 SUB 1) = bindestrich AND
+ pos (buchstaben, wort1 SUB length (wort1)) <> 0.
+
+sprung:
+ inchar(steuerzeichen);
+ IF steuerzeichen = rechts
+ THEN wort1 := subtext (trennwort, 1, max trennlaenge);
+ wort2 := ""
+ ELIF steuerzeichen = links
+ THEN wort1 := "";
+ wort2 := subtext (trennwort, 1, max trennlaenge)
+ FI.
+
+neue zeile mit trennwort versehen:
+ IF wort1 = ""
+ THEN keine trennung
+ ELSE zeichenpos := wortanfang + length (wort1);
+ mit trennsymbol trennen;
+ von := zeichenpos
+ FI.
+
+keine trennung:
+ IF wort ist zu lang fuer limit
+ THEN warnung (7, trennwort);
+ neue zeile CAT trennwort;
+ zeichenpos := wortende + 1;
+ zeichenpos bereits verarbeitet := 0;
+ von := zeichenpos
+ ELSE loesche nachfolgende blanks;
+ zeichenpos := wortanfang
+ FI.
+
+wort ist zu lang fuer limit:
+ length (alte blanks) * einrueckbreite + breite davor + trennbreite
+ >= aktuelle pitch zeilenlaenge.
+
+mit trennsymbol trennen:
+ IF (wort1 SUB length (wort1)) = "c" AND
+ (trennwort SUB (length (wort1) + 1)) = "k"
+ THEN replace (wort1, length (wort1), trenn k)
+ FI;
+ neue zeile CAT wort1;
+ IF trennsymbol <> blank
+ THEN neue zeile CAT trennsymbol
+ FI.
+END PROC trennung eventuell vornehmen;
+
+PROC naechste zeile ggf heranziehen:
+ IF puffer hat absatz
+ OR puffer hat noch mindestens zwei woerter
+ OR zeile hat eine foot anweisung
+ OR in foot uebertrag
+ THEN LEAVE naechste zeile ggf heranziehen
+ ELIF trennung vorhanden
+ THEN IF zeichenpos < pufferlaenge
+ THEN zeilenbreite INCR breite (trennzeichen)
+ FI;
+ getrennte zeilen zusammenziehen;
+ LEAVE naechste zeile ggf heranziehen
+ FI;
+ puffer CAT blank;
+ puffer CAT zeile;
+ zeile lesen;
+ pufferlaenge := length (puffer);
+ ggf absatz an puffer anfuegen.
+
+puffer hat noch mindestens zwei woerter:
+ INT VAR anz :: 0, i :: zeichenpos;
+ WHILE pos (puffer, " ", i) > 0 REP
+ anz INCR 1;
+ i := pos (puffer, " ", i) + 1
+ END REP;
+ anz > 1.
+
+zeile hat eine foot anweisung:
+ pos (puffer, "#foot") <> 0.
+END PROC naechste zeile ggf heranziehen;
+
+(******************** initialisierungs routine *******************)
+
+PROC form initialisieren (TEXT CONST datei):
+ kommando liste :=
+"type:1.1linefeed:3.1limit:4.1free:5.1page:6.01on:8.1off:9.1pagenr:10.2
+pagelength:11.1start:12.2foot:13.0end:14.0head:15.0headeven:16.0
+headodd:17.0bottom:18.0bottomeven:19.0bottomodd:20.0block:21.0";
+ kommando liste CAT
+"material:22.1columns:23.2columnsend:24.0ib:25.012ie:28.012topage:31.1
+goalpage:32.1count:33.01setcount:35.1value:36.01table:38.0tableend:39.0
+rpos:40.1lpos:41.1cpos:42.1dpos:43.2bpos:44.2clearpos:45.01right:47.0";
+ kommando liste CAT
+"center:48.0skip:49.0skipend:50.0u:51.0d:52.0e:53.0headon:54.0headoff:55.0
+bottomon:56.0bottomoff:57.0countperpage:58.0fillchar:59.1mark:60.2
+markend:61.0pageblock:62.0b:63.0counter:64.12setcounter:66.2putcounter:67.01
+storecounter:69.1";
+ kommando liste CAT
+"ub:70.0ue:71.0fb:72.0fe:73.0";
+ line ;
+ erste fehlerzeilennr := 0;
+ anz tabs := 0;
+ zeilennr := 0;
+ zeilenbreite := 0;
+ anz blanks freihalten := 3;
+ herkunftsreferenzen := "#";
+ zielreferenzen := "#";
+ aktuelle blanks := "";
+ font nr speicher := "";
+ modifikationsspeicher := "";
+ mod zeilennr speicher := "";
+ index speicher := "";
+ ind zeilennr speicher := "";
+ counter numbering store := "";
+ counter reference store := "";
+ command store := "";
+ kommando := "";
+ neue zeile := "";
+ zeile := "";
+ puffer := " ";
+ macro works := FALSE;
+ in tabelle := FALSE;
+ in d und e verarbeitung := FALSE;
+ kommandos speichern := TRUE;
+ in foot := FALSE;
+ in foot uebertrag := FALSE;
+ test ob font table vorhanden;
+ bildschirm initialisieren;
+ zeile lesen;
+ zeile in puffer und zeile lesen;
+ einrueckung zweite zeile := "xxx";
+ limit und type ggf anfragen;
+ einrueckbreite := eingestellte indentation pitch ;
+ initialisiere neue zeile;
+ IF einrueckung zweite zeile <> "xxx"
+ THEN aktuelle blanks := einrueckung zweite zeile
+ FI.
+
+test ob font table vorhanden:
+ INT VAR xxx :: x step conversion (0.0).
+
+bildschirm initialisieren:
+ IF online
+ THEN init
+ FI.
+
+init:
+ page;
+ IF lineform mode
+ THEN put ("LINEFORM")
+ ELSE put ("AUTOFORM")
+ FI;
+ put ("(für"); put (lines (eingabe)); put ("Zeilen):");
+ put (datei);
+ cursor (1, 3).
+END PROC form initialisieren;
+
+PROC limit und type ggf anfragen:
+ conversion (limit in cm, aktuelle pitch zeilenlaenge);
+ IF ask type and limit
+ THEN type und limit setzen
+ ELSE alter schriftname := kein vorhandener schriftname;
+ stelle font ein
+ FI;
+ REAL VAR x :: limit in cm;
+ conversion (x, aktuelle pitch zeilenlaenge);
+ IF x = fehler wert
+ THEN limit in cm := 16.0;
+ conversion (limit in cm, aktuelle pitch zeilenlaenge)
+ ELSE limit in cm := x
+ FI;
+ trennbreite setzen.
+
+type und limit setzen:
+ LET type text = "#type (""",
+ limit text = "#limit (",
+ kommando ende text = ")#",
+ kein vorhandener schriftname = "#####";
+ IF type und limit anweisungen nicht vorhanden
+ THEN type und limit fragen
+ ELSE hole font;
+ alter schriftname := kein vorhandener schriftname
+ FI.
+
+type und limit fragen:
+ type anfragen;
+ type in neue zeile;
+ limit anfragen;
+ limit in neue zeile;
+ IF NOT format file in situ
+ THEN schreibe neue zeile;
+ zeilen nr INCR 1
+ FI;
+ IF NOT puffer hat absatz
+ THEN einrueckung zweite zeile := aktuelle blanks;
+ aktuelle blanks := alte blanks;(* Einrueckung fuer die erste zeile*)
+ FI;
+ line.
+
+type und limit anweisungen nicht vorhanden:
+ (pos (puffer, type text) <> 1 OR pos (puffer, "limit") < 12).
+
+type anfragen:
+ put ("Bitte Schrifttyp :");
+ IF font table name = font table
+ THEN dummy := font (font nr);
+ ELSE dummy := font (1);
+ font table name := font table
+ FI;
+ REP
+ editget (dummy);
+ IF font exists (dummy)
+ THEN alter schriftname := dummy;
+ font nr := font (dummy);
+ hole font;
+ LEAVE type anfragen
+ ELSE line ;
+ put ("ERROR: unbekannter Schrifttyp");
+ line (2);
+ put ("Schrifttyp bitte nochmal:")
+ FI
+ END REP.
+
+type in neue zeile:
+ neue zeile := type text;
+ neue zeile CAT dummy;
+ neue zeile CAT """";
+ neue zeile CAT kommando ende text.
+
+limit anfragen:
+ line ;
+ put ("Zeilenbreite (in cm):");
+ dummy := text (limit in cm);
+ REP
+ editget (dummy);
+ limit in cm := real (dummy);
+ IF last conversion ok AND pos (dummy, ".") <> 0
+ THEN LEAVE limit anfragen
+ ELSE line ;
+ put ("ERROR: Falsche Angabe");
+ line (2);
+ put ("Zeilenbreite (in cm) bitte nochmal:");
+ FI
+ END REP.
+
+limit in neue zeile:
+ neue zeile CAT limit text;
+ neue zeile CAT dummy;
+ neue zeile CAT kommando ende text;
+ neue zeile CAT " ".
+END PROC limit und type ggf anfragen;
+
+PROC start form (TEXT CONST datei):
+ IF NOT format file in situ
+ THEN last param (datei);
+ FI;
+ disable stop;
+ dateien assoziieren;
+ zeilen form (datei);
+ IF is error
+ THEN fehlerbehandlung
+ ELSE datei neu nach alt kopieren
+ FI;
+ zwischendatei loeschen;
+ enable stop;
+ col (eingabe, 1);
+ IF aktueller editor > 0
+ THEN set range (file, alter bereich)
+ FI;
+ IF anything noted
+ THEN IF aktueller editor = 0
+ THEN to line (eingabe, erste fehler zeilen nr);
+ ELSE alles neu
+ FI;
+ note edit (eingabe)
+ ELIF NOT format file in situ
+ THEN to line (eingabe, 1)
+ FI.
+
+dateien assoziieren:
+ IF format file in situ
+ THEN
+ ELIF exists (datei)
+ THEN IF subtext (datei, length (datei) - 1) = ".p"
+ THEN errorstop
+ ("'.p'-Datei kann nicht mit lineform bearbeitet werden")
+ FI;
+ eingabe := sequential file (modify, datei);
+ ausgabe datei einrichten
+ ELSE errorstop ("Datei existiert nicht")
+ FI;
+ to line (eingabe, 1);
+ col (eingabe, 1).
+
+ausgabe datei einrichten:
+ ds := nilspace;
+ ausgabe := sequential file (modify, ds);
+ to line (ausgabe, 1);
+ copy attributes (eingabe, ausgabe).
+
+fehlerbehandlung:
+ put error;
+ clear error;
+ font nr := 1;
+ font table name := "";
+ limit in cm := 16.0;
+ IF format file in situ
+ THEN insert record (eingabe);
+ write record (eingabe, neue zeile);
+ down (eingabe);
+ insert record (eingabe);
+ write record (eingabe, puffer);
+ down (eingabe);
+ insert record (eingabe);
+ write record (eingabe, zeile)
+ FI.
+
+datei neu nach alt kopieren:
+ IF NOT format file in situ
+ THEN forget (datei, quiet);
+ copy (ds, datei);
+ eingabe := sequential file (modify, datei)
+ FI.
+
+zwischendatei loeschen:
+ IF NOT format file in situ
+ THEN forget (ds)
+ FI.
+END PROC start form;
+
+(************** line/autoform fuer benannte Dateien ******************)
+
+PROC lineform:
+ IF aktueller editor > 0
+ THEN IF mark
+ THEN editor bereich bearbeiten
+ ELSE errorstop ("kein markierter Bereich")
+ FI
+ ELSE lineform (last param)
+ FI.
+
+editor bereich bearbeiten:
+ disable stop;
+ file := editfile;
+ set marked range (file, alter bereich);
+ lineform (file);
+ enable stop;
+END PROC lineform;
+
+PROC lineform (TEXT CONST datei):
+ ask type and limit := TRUE;
+ lineform mode := TRUE;
+ format file in situ := FALSE;
+ start form (datei)
+END PROC lineform;
+
+PROC autoform:
+ IF aktueller editor > 0
+ THEN IF mark
+ THEN editor bereich bearbeiten
+ ELSE errorstop ("kein markierter Bereich")
+ FI
+ ELSE auto form (last param)
+ FI.
+
+editor bereich bearbeiten:
+ disable stop;
+ file := editfile;
+ set marked range (file, alter bereich);
+ autoform (file);
+ enable stop
+END PROC autoform;
+
+PROC autoform (TEXT CONST datei):
+ ask type and limit := TRUE;
+ lineform mode := FALSE;
+ format file in situ := FALSE;
+ start form (datei)
+END PROC autoform;
+
+(******************** line/autoform fuer files ************************)
+
+PROC lineform (FILE VAR f):
+ enable stop;
+ eingabe := f;
+ format file in situ := TRUE;
+ ask type and limit := TRUE;
+ lineform mode := TRUE;
+ start form ("");
+END PROC lineform;
+
+PROC autoform (FILE VAR f):
+ enable stop;
+ eingabe := f;
+ format file in situ := TRUE;
+ ask type and limit := TRUE;
+ lineform mode := FALSE;
+ start form ("");
+END PROC autoform;
+
+PROC lineform (FILE VAR f, TEXT CONST type name, REAL CONST file limit):
+ eingabe := f;
+ format file in situ := TRUE;
+ lineform mode := TRUE;
+ ask type and limit := FALSE;
+ par1 := type name;
+ limit in cm := file limit;
+ start form ("");
+END PROC lineform;
+
+PROC autoform (FILE VAR f, TEXT CONST type name, REAL CONST file limit):
+ eingabe := f;
+ format file in situ := TRUE;
+ lineform mode := FALSE;
+ ask type and limit := FALSE;
+ par1 := type name;
+ limit in cm := file limit;
+ start form ("");
+END PROC autoform;
+END PACKET liner;
+(*
+REP
+ copy("lfehler","zz");
+ IF yes ("autoform")
+ THEN autoform ("zz")
+ ELSE lineform ("zz")
+ FI;
+ edit("zz");
+ forget("zz")
+UNTIL yes ("ENDE") ENDREP;
+*)
+
diff --git a/system/multiuser/1.7.5/src/macro store b/system/multiuser/1.7.5/src/macro store
new file mode 100644
index 0000000..dc13a1b
--- /dev/null
+++ b/system/multiuser/1.7.5/src/macro store
@@ -0,0 +1,298 @@
+(* ------------------- VERSION 13 vom 28.05.86 -------------------- *)
+PACKET macro store DEFINES macro command and then process parameters,
+ get macro line,
+ number macro lines,
+ load macros,
+ list macros:
+
+(* Programm zur Behandlung von Textkosemtik-Macros
+ Autor: Rainer Hahn
+ Stand: 1.7.1 (Febr. 1984)
+*)
+
+INITFLAG VAR this packet :: FALSE;
+
+DATASPACE VAR ds;
+
+BOUND MACROTABLE VAR macro table;
+
+FILE VAR f;
+
+LET MACROTABLE = STRUCT (ROW max macros TEXT replacement store,
+ ROW max macro zeilen TEXT macro zeilen,
+ ROW max macros TEXT macro namen,
+ ROW max macros INT anz parameter,
+ ROW max macros INT macro start);
+
+
+LET tag = 1,
+ number = 3,
+ delimiter = 6,
+ end of scan = 7,
+ max macro zeilen = 1000,
+ max macros = 200;
+
+INT VAR index aktuelle macro zeile,
+ type,
+ anz zeilen in macro,
+ anz macro zeilen,
+ anz macros :: 0;
+
+TEXT VAR symbol,
+ fehlertext,
+ dummy,
+ kommando,
+ zeile;
+
+BOOL VAR with parameters,
+ macro end gewesen;
+
+PROC init macros:
+ IF NOT initialized (this packet)
+ THEN ds := nilspace;
+ macro table := ds;
+ macros leeren
+ FI.
+
+macros leeren:
+ anz macro zeilen := 0;
+ anz macros := 0.
+END PROC init macros;
+
+PROC load macros (TEXT CONST fname):
+ init macros;
+ line;
+ IF exists (fname)
+ THEN f := sequential file (input, fname);
+ forget (ds);
+ ds := nilspace;
+ macro table := ds;
+ macros einlesen
+ ELSE errorstop ("Datei existiert nicht")
+ FI.
+
+macros einlesen:
+ macro end gewesen := TRUE;
+ anz macros := 0;
+ anz macro zeilen := 0;
+ WHILE NOT eof (f) REP
+ anz macro zeilen INCR 1;
+ IF anz macro zeilen > max macro zeilen
+ THEN errorstop ("Zu viele Zeilen (max.1000)")
+ FI;
+ cout (anz macro zeilen);
+ getline (f, zeile);
+ IF zeile = ""
+ THEN zeile := " "
+ ELIF pos (zeile, "#*") > 0
+ THEN macro name oder end vermerken
+ FI;
+ IF macro end gewesen AND zeile = " "
+ THEN anz macro zeilen DECR 1
+ ELSE macro table . macro zeilen [anz macro zeilen] := zeile
+ FI
+ END REP;
+ anz macro zeilen INCR 1;
+ macro table . macro zeilen [anz macro zeilen] := " ";
+ IF anz macros = 0
+ THEN putline ("Macros geleert")
+ FI.
+
+macro name oder end vermerken:
+ INT CONST komm anfang :: pos (zeile, "#*") + 2,
+ komm ende :: pos (zeile, "#", komm anfang);
+ IF komm anfang <> 3 OR hinter dem kommando steht noch was
+ THEN errorstop ("Macro-Anweisung steht nicht alleine auf der Zeile");
+ FI;
+ kommando := subtext (zeile, komm anfang, komm ende -1);
+ scan (kommando);
+ next symbol (symbol, type);
+ IF type = tag
+ THEN macro namen aufnehmen
+ ELSE errorstop ("kein Macroname nach #*")
+ FI;
+ next symbol (symbol, type);
+ IF type >= end of scan
+ THEN macro table . anz parameter [anz macros] := 0;
+ LEAVE macro name oder end vermerken
+ ELIF symbol = "("
+ THEN parameter aufsammeln;
+ ELSE errorstop ("keine ( nach Macro-Name")
+ FI.
+
+macro namen aufnehmen:
+ IF symbol = "macroend"
+ THEN put ("mit"); put (macro table . anz parameter [anz macros]);
+ put ("Parameter(n) geladen");
+ macro end gewesen := TRUE;
+ line;
+ LEAVE macro name oder end vermerken
+ ELIF NOT macro end gewesen
+ THEN errorstop ("macro end fehlt")
+ ELSE macro end gewesen := FALSE;
+ anz macros INCR 1;
+ IF anz macros > max macros
+ THEN errorstop ("Zu viele Macros (max. 200")
+ FI;
+ macro table . macro namen [anz macros] := symbol;
+ macro table . macro start [anz macros] := anz macro zeilen;
+ line;
+ put (symbol);
+ FI.
+
+hinter dem kommando steht noch was:
+ NOT (komm ende = length (zeile) COR
+ (komm ende + 1 = length (zeile) AND (zeile SUB komm ende + 1) = " ")).
+
+parameter aufsammeln:
+ INT VAR parameter number :: 1;
+ next symbol (symbol, type);
+ WHILE symbol = "$" REP
+ next symbol (symbol, type);
+ IF type = number CAND int (symbol) = parameter number
+ THEN IF parameter number > 9
+ THEN errorstop ("Anzahl Parameter > 9")
+ FI;
+ macro table . anz parameter [anz macros] := parameter number;
+ parameter number INCR 1;
+ ELSE errorstop ("Parameter-Nummer inkorrekt: " + symbol)
+ FI;
+ next symbol (symbol, type);
+ IF symbol = ")"
+ THEN LEAVE parameter aufsammeln
+ ELIF symbol = ","
+ THEN next symbol (symbol, type)
+ ELSE errorstop (", oder ) erwartet:" + symbol)
+ FI
+ END REP;
+ errorstop ("Parameterliste inkorrekt bei" + symbol).
+END PROC load macros;
+
+PROC load macros:
+ load macros (last param)
+END PROC load macros;
+
+PROC list macros:
+ init macros;
+ note ("");
+ INT VAR i := 1;
+ WHILE i <= anz macro zeilen REP
+ cout (i);
+ note (macro table . macro zeilen [i]);
+ note line;
+ i INCR 1
+ END REP;
+ note edit
+END PROC list macros;
+
+BOOL PROC macro exists (TEXT CONST name, INT VAR anz params):
+ INT VAR i;
+ FOR i FROM 1 UPTO anz macros REP
+ IF macro table . macro namen [i] = name
+ THEN anz params := macro table . anz parameter [i];
+ index aktuelle macro zeile := macro table . macro start [i] + 1;
+ berechne anzahl zeilen in macro;
+ IF anz params = 0
+ THEN with parameters := FALSE
+ ELSE with parameters := TRUE;
+ lade macro in replacement store;
+ index aktuelle macro zeile := 1;
+ FI;
+ LEAVE macro exists WITH TRUE
+ FI
+ END REP;
+ FALSE.
+
+berechne anzahl zeilen in macro:
+ IF i = anz macros
+ THEN anz zeilen in macro :=
+ anz macro zeilen - index aktuelle macro zeile;
+ ELSE anz zeilen in macro :=
+ macro table . macro start [i + 1] - index aktuelle macro zeile
+ FI.
+
+lade macro in replacement store:
+ INT VAR k;
+ FOR k FROM 1 UPTO anz zeilen in macro REP
+ macro table . replacement store [k] :=
+ macro table . macro zeilen [index aktuelle macro zeile +k-1]
+ END REP.
+END PROC macro exists;
+
+PROC replace macro parameter (INT CONST number, TEXT CONST param):
+ TEXT VAR param text := "$" + text (number);
+ INT VAR k;
+ FOR k FROM 1 UPTO anz zeilen in macro - 1 REP
+ change all (macro table . replacement store [k], param text, param);
+ END REP
+END PROC replace macro parameter;
+
+BOOL PROC macro command and then process parameters (TEXT VAR komm):
+ init macros;
+ LET tag = 1;
+ scan (komm);
+ next symbol (symbol, type);
+ IF type = tag
+ THEN untersuche ob deklariertes macro
+ ELSE FALSE
+ FI.
+
+untersuche ob deklariertes macro:
+ INT VAR anz macro params;
+ IF macro exists (symbol, anz macro params)
+ THEN fehlertext := "in Makro: "; fehlertext CAT symbol;
+ IF anz macro params > 0
+ THEN macro parameter ersetzen
+ FI;
+ TRUE
+ ELSE FALSE
+ FI.
+
+macro parameter ersetzen:
+ next symbol (symbol, type);
+ IF symbol = "("
+ THEN ersetze
+ ELSE report text processing error (34, 0, dummy, symbol + fehlertext);
+ LEAVE macro command and then process parameters WITH FALSE
+ FI.
+
+ersetze:
+ LET text type = 4,
+ end of scan = 7;
+ INT VAR number parameter :: 1;
+ REP
+ next symbol (symbol, type);
+ IF type = texttype
+ THEN replace macro parameter (number parameter, symbol);
+ ELSE report text processing error (35, 0, dummy, fehlertext + symbol);
+ LEAVE macro command and then process parameters WITH FALSE
+ FI;
+ number parameter INCR 1;
+ IF number parameter > anz macro params
+ THEN LEAVE macro command and then process parameters WITH TRUE
+ FI;
+ next symbol (symbol, type);
+ IF symbol <> "," OR type >= end of scan
+ THEN report text processing error (36, 0, dummy, fehlertext + symbol);
+ LEAVE macro command and then process parameters WITH FALSE
+ FI
+ END REP.
+END PROC macro command and then process parameters;
+
+PROC get macro line (TEXT VAR macro zeile):
+ IF index aktuelle macro zeile > anz zeilen in macro
+ THEN macro zeile := "#### "
+ ELIF with parameters
+ THEN macro zeile :=
+ macro table . replacement store [index aktuelle macro zeile]
+ ELSE macro zeile :=
+ macro table . macro zeilen [index aktuelle macro zeile]
+ FI;
+ index aktuelle macro zeile INCR 1;
+END PROC get macro line;
+
+INT PROC number macro lines:
+ anz zeilen in macro
+END PROC number macro lines;
+END PACKET macro store;
+
diff --git a/system/multiuser/1.7.5/src/multi user monitor b/system/multiuser/1.7.5/src/multi user monitor
new file mode 100644
index 0000000..dd3051e
--- /dev/null
+++ b/system/multiuser/1.7.5/src/multi user monitor
@@ -0,0 +1,93 @@
+(* ------------------- VERSION 2 16.05.86 ------------------- *)
+PACKET multi user monitor DEFINES (* Autor: J.Liedtke *)
+
+ monitor :
+
+
+LET command list =
+
+"edit:1.01run:4.01runagain:6.0insert:7.01forget:9.01rename:11.2copy:12.2
+list:13.0storageinfo:14.0taskinfo:15.0
+fetch:16.1save:17.01break:19.0saveall:20.0 " ;
+
+LET text param type = 4 ;
+
+
+INT VAR command index , number of params , previous heap size ;
+TEXT VAR param 1, param 2 ;
+
+
+ lernsequenz auf taste legen ("q", ""1""8""1""12"break"13"") ;
+ lernsequenz auf taste legen ("e", ""1""8""1""12"edit"13"") ;
+
+
+PROC monitor :
+
+ disable stop ;
+ previous heap size := heap size ;
+ REP
+ command dialogue (TRUE) ;
+ sysin ("") ;
+ sysout ("") ;
+ cry if not enough storage ;
+ get command ("gib kommando :") ;
+ reset editor ;
+ analyze command (command list, text param type,
+ command index, number of params, param1, param2) ;
+ execute command ;
+ collect heap garbage if necessary
+ PER .
+
+collect heap garbage if necessary :
+ IF heap size > previous heap size + 10
+ 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 .
+
+reset editor :
+ WHILE aktueller editor > 0 REP
+ quit
+ PER ;
+ clear error .
+
+ENDPROC monitor ;
+
+PROC execute command :
+
+ enable stop ;
+ SELECT command index OF
+ CASE 1 : edit
+ CASE 2 : edit (param1)
+ CASE 3 : (* war frueher paralleleditor *)
+ 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: break
+ CASE 20: save all
+
+ OTHERWISE do command
+ ENDSELECT .
+
+ENDPROC execute command ;
+
+ENDPACKET multi user monitor ;
+
diff --git a/system/multiuser/1.7.5/src/nameset b/system/multiuser/1.7.5/src/nameset
new file mode 100644
index 0000000..8ea4359
--- /dev/null
+++ b/system/multiuser/1.7.5/src/nameset
@@ -0,0 +1,355 @@
+(* ------------------- VERSION 3 17.03.86 ------------------- *)
+PACKET name set DEFINES (* Autor: J.Liedtke *)
+
+ ALL ,
+ SOME ,
+ LIKE ,
+ + ,
+ - ,
+ / ,
+ do ,
+ FILLBY ,
+ remainder ,
+
+ fetch ,
+ save ,
+ fetch all ,
+ save all ,
+ forget ,
+ erase ,
+ insert ,
+ edit :
+
+
+LET cr lf = ""13""10"" ;
+
+TEXT VAR name ;
+DATASPACE VAR edit space ;
+
+THESAURUS VAR remaining thesaurus := empty thesaurus ;
+
+
+THESAURUS OP + (THESAURUS CONST left, right) :
+
+ THESAURUS VAR union := left ;
+ INT VAR index := 0 ;
+ get (right, name, index) ;
+ WHILE name <> "" REP
+ IF NOT (union CONTAINS name)
+ THEN insert (union, name)
+ FI ;
+ get (right, name, index)
+ PER ;
+ union .
+
+ENDOP + ;
+
+THESAURUS OP + (THESAURUS CONST left, TEXT CONST right) :
+
+ THESAURUS VAR union := left ;
+ IF NOT (union CONTAINS right)
+ THEN insert (union, right)
+ FI ;
+ union .
+
+ENDOP + ;
+
+THESAURUS OP - (THESAURUS CONST left, right) :
+
+ THESAURUS VAR difference := empty thesaurus ;
+ INT VAR index := 0 ;
+ get (left, name, index) ;
+ WHILE name <> "" REP
+ IF NOT (right CONTAINS name)
+ THEN insert (difference, name)
+ FI ;
+ get (left, name, index)
+ PER ;
+ difference .
+
+ENDOP - ;
+
+THESAURUS OP - (THESAURUS CONST left, TEXT CONST right) :
+
+ THESAURUS VAR difference := left ;
+ INT VAR index ;
+ delete (difference, right, index) ;
+ difference .
+
+ENDOP - ;
+
+THESAURUS OP / (THESAURUS CONST left, right) :
+
+ THESAURUS VAR intersection := empty thesaurus ;
+ INT VAR index := 0 ;
+ get (left, name, index) ;
+ WHILE name <> "" REP
+ IF right CONTAINS name
+ THEN insert (intersection, name)
+ FI ;
+ get (left, name, index)
+ PER ;
+ intersection .
+
+ENDOP / ;
+
+THESAURUS OP ALL (TEXT CONST file name) :
+
+ FILE VAR file := sequential file (input, file name) ;
+ THESAURUS VAR thesaurus := empty thesaurus ;
+ thesaurus FILLBY file ;
+ thesaurus .
+
+ENDOP ALL ;
+
+THESAURUS OP SOME (THESAURUS CONST thesaurus) :
+
+ copy thesaurus into file ;
+ edit file ;
+ copy file into thesaurus .
+
+copy thesaurus into file :
+ forget (edit space) ;
+ edit space := nilspace ;
+ FILE VAR file := sequential file (output, edit space) ;
+ file FILLBY thesaurus .
+
+edit file :
+ modify (file) ;
+ edit (file) .
+
+copy file into thesaurus :
+ THESAURUS VAR result := empty thesaurus ;
+ input (file) ;
+ result FILLBY file ;
+ forget (edit space) ;
+ result .
+
+ENDOP SOME ;
+
+THESAURUS OP SOME (TASK CONST task) :
+
+ SOME ALL task
+
+ENDOP SOME ;
+
+THESAURUS OP SOME (TEXT CONST file name) :
+
+ SOME ALL file name
+
+ENDOP SOME ;
+
+THESAURUS OP LIKE (THESAURUS CONST thesaurus, TEXT CONST pattern) :
+
+ THESAURUS VAR result:= empty thesaurus ;
+ INT VAR index:= 0 ;
+ REP get (thesaurus, name, index) ;
+ IF name = ""
+ THEN LEAVE LIKE WITH result
+ ELIF name LIKE pattern
+ THEN insert (result, name)
+ FI
+ PER ;
+ result .
+
+ENDOP LIKE ;
+
+THESAURUS PROC remainder :
+
+ remaining thesaurus
+
+ENDPROC remainder ;
+
+PROC do (PROC (TEXT CONST) operate, THESAURUS CONST thesaurus) :
+
+ INT VAR index := 0 , operation number := 0 ;
+ TEXT VAR name ;
+
+ remaining thesaurus := empty thesaurus ;
+ disable stop ;
+ work off thesaurus ;
+ fill leftover with remainder .
+
+work off thesaurus :
+ REP
+ get (thesaurus, name, index) ;
+ IF name = ""
+ THEN LEAVE work off thesaurus
+ FI ;
+ operation number INCR 1 ;
+ cout (operation number) ;
+ execute (PROC (TEXT CONST) operate, name)
+ UNTIL is error ENDREP .
+
+fill leftover with remainder :
+ WHILE name <> "" REP
+ insert (remaining thesaurus, name) ;
+ get (thesaurus, name, index)
+ PER .
+
+ENDPROC do ;
+
+PROC execute (PROC (TEXT CONST) operate, TEXT CONST name) :
+
+ enable stop ;
+ operate (name)
+
+ENDPROC execute ;
+
+PROC do (PROC (TEXT CONST, TASK CONST) operate, THESAURUS CONST thesaurus,
+ TASK CONST task) :
+
+ INT VAR index := 0 , operation number := 0 ;
+ TEXT VAR name ;
+
+ remaining thesaurus := empty thesaurus ;
+ disable stop ;
+ work off thesaurus ;
+ fill leftover with remainder .
+
+work off thesaurus :
+ REP
+ get (thesaurus, name, index) ;
+ IF name = ""
+ THEN LEAVE work off thesaurus
+ FI ;
+ operation number INCR 1 ;
+ cout (operation number) ;
+ execute (PROC (TEXT CONST, TASK CONST) operate, name, task)
+ UNTIL is error ENDREP .
+
+fill leftover with remainder :
+ WHILE name <> "" REP
+ insert (remaining thesaurus, name) ;
+ get (thesaurus, name, index)
+ PER .
+
+ENDPROC do ;
+
+PROC execute (PROC (TEXT CONST, TASK CONST) operate,
+ TEXT CONST name, TASK CONST task) :
+
+ enable stop ;
+ operate (name, task)
+
+ENDPROC execute ;
+
+OP FILLBY (THESAURUS VAR thesaurus, FILE VAR file) :
+
+ WHILE NOT eof (file) REP
+ getline (file, name) ;
+ delete trailing blanks ;
+ IF name <> "" CAND NOT (thesaurus CONTAINS name)
+ THEN insert (thesaurus, name)
+ FI
+ PER .
+
+delete trailing blanks :
+ WHILE (name SUB LENGTH name) = " " REP
+ name := subtext (name, 1, LENGTH name - 1)
+ PER .
+
+ENDOP FILLBY ;
+
+OP FILLBY (FILE VAR file, THESAURUS CONST thesaurus) :
+
+ INT VAR index := 0 ;
+ REP
+ get (thesaurus, name, index) ;
+ IF name = ""
+ THEN LEAVE FILLBY
+ FI ;
+ putline (file, name)
+ PER .
+
+ENDOP FILLBY ;
+
+OP FILLBY (TEXT CONST file name, THESAURUS CONST thesaurus) :
+
+ FILE VAR f := sequential file (output, file name) ;
+ f FILLBY thesaurus
+
+ENDOP FILLBY ;
+
+
+
+PROC fetch (THESAURUS CONST nameset) :
+
+ do (PROC (TEXT CONST) fetch, nameset)
+
+ENDPROC fetch ;
+
+PROC fetch (THESAURUS CONST nameset, TASK CONST task) :
+
+ do (PROC (TEXT CONST, TASK CONST) fetch, nameset, task)
+
+ENDPROC fetch ;
+
+PROC save (THESAURUS CONST nameset) :
+
+ do (PROC (TEXT CONST) save, nameset)
+
+ENDPROC save ;
+
+PROC save (THESAURUS CONST nameset, TASK CONST task) :
+
+ do (PROC (TEXT CONST, TASK CONST) save, nameset, task)
+
+ENDPROC save ;
+
+PROC fetch all :
+
+ fetch all (father)
+
+ENDPROC fetch all ;
+
+PROC fetch all (TASK CONST manager) :
+
+ fetch (ALL manager, manager)
+
+ENDPROC fetch all ;
+
+PROC save all :
+
+ save all (father)
+
+ENDPROC save all ;
+
+PROC save all (TASK CONST manager) :
+
+ save (ALL myself, manager)
+
+ENDPROC save all ;
+
+PROC forget (THESAURUS CONST nameset) :
+
+ do (PROC (TEXT CONST) forget, nameset)
+
+ENDPROC forget ;
+
+PROC erase (THESAURUS CONST nameset) :
+
+ do (PROC (TEXT CONST) erase, nameset)
+
+ENDPROC erase ;
+
+PROC erase (THESAURUS CONST nameset, TASK CONST task) :
+
+ do (PROC (TEXT CONST, TASK CONST) erase, nameset, task)
+
+ENDPROC erase ;
+
+PROC insert (THESAURUS CONST nameset) :
+
+ do (PROC (TEXT CONST) insert, nameset)
+
+ENDPROC insert ;
+
+PROC edit (THESAURUS CONST nameset) :
+
+ do (PROC (TEXT CONST) edit, nameset)
+
+ENDPROC edit ;
+
+ENDPACKET name set ;
+
diff --git a/system/multiuser/1.7.5/src/pager b/system/multiuser/1.7.5/src/pager
new file mode 100644
index 0000000..35189a4
--- /dev/null
+++ b/system/multiuser/1.7.5/src/pager
@@ -0,0 +1,2451 @@
+(*-------------------- VERSION 197 vom 05.05.86 -------(1.7.5)------ *)
+PACKET seiten formatieren DEFINES pageform,
+ auto pageform,
+ number empty lines before foot,
+ first head,
+ last bottom:
+
+(* Programm zur interaktiven Formatierung von Seiten, Fussnoten, Kopf- und
+ Fusszeilen, Seitennummern usw.
+ Autor: Rainer Hahn
+ *)
+
+(***************** Deklarationen fuer pageform ************)
+
+LET type1 = 1,
+ linefeed = 3,
+ limit = 4,
+ free = 5,
+ page command0= 6,
+ page command1= 7,
+ pagenr = 8,
+ pagelength = 9,
+ foot = 10,
+ end = 11,
+ head = 12,
+ headeven = 13,
+ headodd = 14,
+ bottom = 15,
+ bottomeven = 16,
+ bottomodd = 17,
+ columns = 18,
+ columnsend = 19,
+ topage = 20,
+ goalpage = 21,
+ count0 = 22,
+ count1 = 23,
+ setcount = 24,
+ value0 = 25,
+ value1 = 26,
+ on = 27,
+ off = 28,
+ head on = 29,
+ head off = 30,
+ bottom on = 31,
+ bottom off = 32,
+ count per page=33,
+ foot contd = 34,
+ table = 35,
+ table end = 36,
+ r pos = 37,
+ l pos = 38,
+ c pos = 39,
+ d pos = 40,
+ b pos = 41,
+ clearpos0 = 42,
+ clearpos1 = 43,
+ fillchar = 44,
+ pageblock = 45,
+ counter1 = 46,
+ counter2 = 47,
+ counter store= 48,
+ countervalue0= 49,
+ countervalue1= 50,
+ set counter = 51,
+ u = 52,
+ d = 53,
+ e = 54,
+ fehler index = 100,
+ hop = ""1"",
+ upchar = ""3"",
+ cl eop = ""4"",
+ cl eol = ""5"",
+ downchar = ""10"",
+ rub in = ""11"",
+ rub out = ""12"",
+ return = ""13"",
+ end mark = ""14"",
+ begin mark = ""15"",
+ begin end mark = ""15""14"",
+ esc = ""27"",
+ blank = " ",
+ kommando zeichen = "#",
+ kopf = 1,
+ kopf gerade = 2,
+ fuss = 3,
+ fuss gerade = 4,
+ kopf ungerade = 5,
+ fuss ungerade = 6,
+ foot note = 7,
+ dina4 limit = "16.0",
+ dina4 pagelength = 25.0,
+ pos seitengrenze = 17,
+ zeilen nach oben = 13,
+ zeilen nach unten = 6,
+ max foot zeilen = 120,
+ max zeilen zahl = 15,
+ max refers = 300,
+ max anz seitenzeichen = 3;
+
+BOOL VAR interaktiv,
+ bereich aufnehmen,
+ zeile noch nicht verarbeitet,
+ es war ein linefeed in der zeile,
+ mindestens ein topage gewesen,
+ insert first head :: TRUE,
+ insert last bottom :: TRUE,
+ pageblock on,
+ ausgeschalteter head,
+ ausgeschalteter bottom,
+ count seitenzaehlung,
+ file works,
+ in tabelle,
+ in nullter seite,
+ letzte textzeile war mit absatz,
+ letztes seitenende war mit absatz,
+ letztes seitenende war in tabelle;
+
+INT VAR kommando anfangs pos,
+ kommando ende pos,
+ kommando index,
+ number blank lines before foot :: 1,
+ in index oder exponent,
+ durchgang,
+ nummer erste seite,
+ nummer letzte seite,
+ laufende spaltennr,
+ anz refers,
+ counter,
+ anz spalten,
+ anz zeilen nach oben,
+ anz vertauschte zeilen,
+ font nr,
+ type zeilenvorschub,
+ berechneter zeilenvorschub,
+ max zeilenvorschub,
+ max type zeilenvorschub,
+ textbegin zeilennr,
+ anz textzeilen,
+ text laenge vor columns,
+ bereichshoehe,
+ aktuelle seitenlaenge,
+ eingestellte seitenlaenge;
+
+REAL VAR real eingestellter zeilenvorschub,
+ realparam;
+
+TEXT VAR kommando,
+ par1, par2,
+ macro line,
+ vor macro,
+ nach macro,
+ dummy,
+ fehlerdummy,
+ modifikation,
+ modifikations speicher,
+ kommando seitenspeicher,
+ dec value,
+ counter numbering store,
+ counter reference store,
+ letzte kommandoleiste,
+ kommando speicher,
+ tab pos speicher,
+ bereich kommando speicher,
+ seitenzeichen,
+ name druck datei,
+ name eingabe datei,
+ zeile,
+ eingestellter typ,
+ eingestelltes limit;
+
+TEXT VAR kommando liste ::
+"type:1.1linefeed:3.1limit:4.1free:5.1page:6.01pagenr:8.2pagelength:9.1
+foot:10.0end:11.0head:12.0headeven:13.0headodd:14.0bottom:15.0bottomeven:16.0
+bottomodd:17.0columns:18.2columnsend:19.0topage:20.1goalpage:21.1count:22.01
+setcount:24.1";
+
+kommando liste CAT
+"value:25.01on:27.1off:28.1headon:29.0headoff:30.0bottomon:31.0bottomoff:32.0
+countperpage:33.0footcontinued:34.0table:35.0tableend:36.0rpos:37.1lpos:38.1
+cpos:39.1dpos:40.2bpos:41.2clearpos:42.01fillchar:44.1pageblock:45.0";
+
+kommando liste CAT
+"counter:46.12storecounter:48.1putcounter:49.01setcounter:51.2u:52.0d:53.0
+e:54.0";
+
+FILE VAR eingabe,
+ ausgabe;
+
+ROW 6 ROW max zeilenzahl TEXT VAR kopf fuss zeilen;
+
+ROW max foot zeilen TEXT VAR foot zeilen;
+
+ROW max foot zeilen BOOL VAR kommandos vorhanden;
+
+ROW 7 INT VAR anz kopf oder fuss zeilen,
+ kopf oder fuss laenge;
+
+ROW max anz seitenzeichen INT VAR laufende seitennr;
+
+BOUND ROW max refers REFER VAR refer sammler;
+
+LET REFER = STRUCT (TEXT kennzeichen, INT nummer, BOOL referenced);
+
+DATASPACE VAR ds;
+
+(********************* Einstell-Prozeduren ***************************)
+
+PROC first head (BOOL CONST was):
+ insert first head := was
+END PROC first head;
+
+PROC last bottom (BOOL CONST was):
+ insert last bottom := was
+END PROC last bottom;
+
+PROC number empty lines before foot (INT CONST n):
+ IF n >= 0 AND n < 10
+ THEN number blank lines before foot := n
+ ELSE errorstop ("nur einstellbar zwischen 0 und 9")
+ FI
+END PROC number empty lines before foot;
+
+(************************** Fehlermeldungen **********************)
+
+PROC fehler (INT CONST nr, TEXT CONST addition):
+ IF durchgang = 1 OR
+ kommando index = goalpage OR kommandoindex = count0 OR
+ kommando index = count1 OR kommando index = value1 OR
+ kommando index = topage OR kommando index = pagelength OR
+ kommando index = counterstoreOR kommando index = counter1 OR
+ kommando index = counter2 OR kommando index = countervalue1
+ THEN fehler melden;
+ fehlermeldung auf terminal ausgeben
+ FI.
+
+fehler melden:
+ report text processing error (nr, line no (ausgabe), fehlerdummy, addition).
+
+fehlermeldung auf terminal ausgeben:
+ IF interaktiv
+ THEN cursor(1,2); out(cleop);
+ ELSE line
+ FI;
+ out (fehlerdummy);
+ line.
+END PROC fehler;
+
+PROC warnung (INT CONST nr, TEXT CONST addition):
+ IF durchgang = 1 OR
+ kommando index = goalpage OR kommandoindex = count0 OR
+ kommando index = count1 OR kommando index = value1 OR
+ kommando index = topage OR kommando index = set counter
+ THEN fehler melden;
+ meldung auf terminal ausgeben
+ FI.
+
+fehler melden:
+ report text processing warning (nr, line no (ausgabe), fehlerdummy, addition).
+
+meldung auf terminal ausgeben:
+ IF interaktiv
+ THEN cursor(1,2); out(cleop);
+ ELSE line
+ FI;
+ out (fehlerdummy);
+ line.
+END PROC warnung;
+
+(*************************** Globale Dateibehandlung **************)
+
+PROC datei assoziieren:
+ IF exists (name eingabe datei)
+ THEN ausgabe datei einrichten
+ ELSE errorstop (name eingabe datei + " existiert nicht")
+ FI.
+
+ausgabe datei einrichten:
+ IF name eingabe datei = name druck datei
+ THEN errorstop ("Name Eingabedatei = Name Ausgabedatei")
+ ELIF subtext (name eingabe datei, length (name eingabe datei) - 1) = ".p"
+ THEN errorstop ("Druckdatei kann nicht nochmal formatiert werden")
+ ELSE eingabe := sequential file (input, name eingabe datei);
+ copy (name eingabedatei, name druck datei);
+ ausgabe := sequential file (modify, name druck datei);
+ copy attributes (eingabe, ausgabe);
+ headline (ausgabe, name druck datei);
+ FI
+END PROC datei assoziieren;
+
+PROC record einfuegen (TEXT CONST rec):
+ insert record (ausgabe);
+ write record (ausgabe, rec);
+ down (ausgabe);
+END PROC record einfuegen;
+
+(******************** Kopf- oder Fusszeilen aufnehmen *************)
+
+PROC fussnote aufnehmen:
+ bereich aufnehmen := TRUE;
+ IF keine zeichen ausser blank nach dem kommando
+ THEN aufnehmen (footnote)
+ ELSE fehler (19, kommando)
+ FI;
+ in index oder exponent := 0;
+ bereich aufnehmen := FALSE
+END PROC fussnote aufnehmen;
+
+PROC aufnehmen (INT CONST was):
+ kommando zustand vor bereich speichern;
+ aktuelle zeile ggf mitzaehlen;
+ aufnehmen initialisieren;
+ kopf oder fuss zeilen aufnehmen.
+
+kommando zustand vor bereich speichern:
+ kommandos in dummy speichern;
+ bereich kommando speicher := dummy.
+
+aktuelle zeile ggf mitzaehlen:
+INT VAR einleitungs kommando anfang :: kommando anfangs pos;
+ IF kommando anfangs pos > 1
+ THEN IF NOT only command line (zeile)
+ THEN aktuelle seitenlaenge INCR max zeilenvorschub
+ FI;
+ read record (ausgabe, zeile)
+ FI.
+
+aufnehmen initialisieren:
+ IF was = foot note
+ THEN initialisierung fuer fussnoten
+ ELSE anz kopf oder fuss zeilen [was] := 1;
+ kommandos in dummy speichern;
+ kopf fuss zeilen [was] [1] := dummy;
+ kopf oder fuss laenge [was] := 0;
+ FI;
+ bereichshoehe := kopf oder fusslaenge [was].
+
+initialisierung fuer fussnoten:
+ INT CONST fussnotenlaenge vorher :: kopf oder fuss laenge [footnote],
+ anz fusszeilen vorher :: anz kopf oder fusszeilen [footnote];
+ anz kopf oder fuss zeilen [footnote] INCR 1;
+ kommandos in dummy speichern;
+ kommandoleiste in fussnote speichern; (* davor *)
+ IF anz kopf oder fuss zeilen [footnote] = 1
+ THEN unterstreichungsstrich
+ FI.
+
+kommandoleiste in fussnote speichern:
+ foot zeilen [anz kopf oder fuss zeilen [footnote]] := dummy;
+ kommandos vorhanden [anz kopf oder fuss zeilen [footnote]]:= TRUE.
+
+unterstreichungsstrich:
+ FOR i FROM 2 UPTO max foot zeilen REP
+ kommandos vorhanden [i] := FALSE
+ ENDREP;
+ FOR i FROM 1 UPTO number blank lines before foot REP
+ foot zeilen [i + 1] := " "
+ END REP;
+ foot zeilen [number blank lines before foot + 2] :=
+ "#on(""underline"")#               #off(""underline"")# ";
+ kopf oder fuss laenge [footnote] :=
+ (number blank lines before foot + 1) * berechneter zeilenvorschub;
+ anz kopf oder fuss zeilen [footnote] := number blank lines before foot + 2.
+
+kopf oder fuss zeilen aufnehmen:
+INT VAR anzahl :: 1;
+ REP
+ naechste zeile lesen;
+ cout (line no (ausgabe));
+ IF mindestens ein kommando vorhanden
+ THEN kommandos von kopf oder fuss verarbeiten
+ FI;
+ in index oder exponent := 0;
+ zeile aufnehmen;
+ anzahl INCR 1
+ UNTIL eof (ausgabe) END REP;
+ errorstop ("end fehlt bei Dateiende").
+
+kommandos von kopf oder fuss verarbeiten:
+ max zeilenvorschub := berechneter zeilenvorschub;
+ max type zeilenvorschub := type zeilenvorschub;
+ kommando anfangs pos := pos (zeile, kommando zeichen);
+ WHILE kommando anfangs pos <> 0 REP
+ verarbeite kommando;
+ kommandos von kopf oder fuss pruefen;
+ kommando anfangs pos :=
+ pos (zeile, kommando zeichen, kommando ende pos + 1)
+ END REP.
+
+kommandos von kopf oder fuss pruefen:
+ IF kommandoindex = end
+ THEN aufnehmen beenden
+ ELIF kommando index = free
+ THEN IF y step conversion (realparam) >= eingestellte seitenlaenge
+ THEN fehler (24, text (realparam))
+ ELSE kopf oder fusslaenge [was] INCR y step conversion (realparam)
+ FI
+ ELIF seitenende
+ THEN INT VAR xx := durchgang;
+ durchgang := 1;
+ fehler (25, "");
+ durchgang := xx;
+ zeile zurueck lesen;
+ kommando index := end;
+ LEAVE aufnehmen
+ ELIF kommando index = fehler index
+ THEN LEAVE aufnehmen
+ ELIF kommando index > free AND kommando index < to page
+ THEN fehler (11, kommando);
+ kommando index := fehler index;
+ LEAVE aufnehmen
+ FI.
+
+aufnehmen beenden:
+ IF kommando anfangs pos > 1
+ THEN IF absatzzeile
+ THEN zeile := subtext (zeile, 1, kommando anfangs pos -1);
+ zeile CAT blank;
+ ELSE zeile := subtext (zeile, 1, kommando anfangs pos -1);
+ FI;
+ zeile aufnehmen
+ FI;
+ IF NOT (durchgang = 1 AND was = footnote)
+ THEN die aufgenommenen zeilen in druckdatei loeschen
+ FI;
+ LEAVE aufnehmen.
+
+die aufgenommenen zeilen in druckdatei loeschen:
+ INT VAR i;
+ delete record (ausgabe);
+ FOR i FROM 1 UPTO anzahl - 1 REP
+ up (ausgabe);
+ delete record (ausgabe)
+ END REP;
+ zeile zurueck lesen;
+ letztes kommando dieser zeile loeschen;
+ ggf kommandoleiste generieren.
+
+letztes kommando dieser zeile loeschen:
+ IF einleitungs kommando anfang = 1
+ THEN delete record (ausgabe);
+ IF line no (ausgabe) = 1
+ THEN zeile noch nicht verarbeitet := TRUE
+ ELSE zeile zurueck lesen
+ FI
+ ELSE dummy := subtext (zeile, 1, einleitungs kommando anfang - 1);
+ IF absatz zeile
+ THEN dummy CAT blank;
+ ELIF (dummy SUB length (dummy)) = " "
+ THEN delete char (dummy, length (dummy))
+ FI;
+ write record (ausgabe, dummy)
+ FI.
+
+ggf kommandoleiste generieren:
+ kommandos in dummy speichern;
+ IF was = footnote
+ THEN anz kopf oder fusszeilen [footnote] INCR 1;
+ kommandoleiste in fussnote speichern (* danach *)
+ FI;
+ IF dummy <> bereich kommando speicher
+ THEN down (ausgabe);
+ record einfuegen (dummy);
+ up (ausgabe, 2);
+ FI.
+
+zeile aufnehmen:
+ zeile speichern (was, anzahl);
+ IF erreichte seitenlaenge > eingestellte seitenlaenge
+ THEN bereich aufnehmen := FALSE;
+ IF kommando index = end
+ THEN seitenende nach geteilter fussnote
+ ELSE seitenende vor der fussnote
+ FI;
+ kommando index := end;
+ LEAVE aufnehmen
+ FI.
+
+seitenende nach geteilter fussnote:
+ kopf oder fuss laenge [footnote] DECR max zeilenvorschub;
+ anz kopf oder fuss zeilen [footnote] DECR 1;
+ seitenende einbringen und zurueck.
+
+seitenende vor der fussnote:
+ kopf oder fuss laenge [footnote] := fussnotenlaenge vorher;
+ anz kopf oder fuss zeilen [footnote] := anz fusszeilen vorher;
+ ende einer seite.
+END PROC aufnehmen;
+
+PROC zeile speichern (INT CONST was, anzahl):
+ zeile mitzaehlen;
+ IF was = footnote
+ THEN fussnote aufnehmen
+ ELIF anz kopf oder fuss zeilen [was] > max zeilenzahl
+ THEN errorstop ("Zu viele 'head' oder 'bottom' Zeilen");
+ ELSE kopf fuss zeilen [was] [anz kopf oder fuss zeilen [was]] := zeile
+ FI.
+
+zeile mitzaehlen:
+ anz kopf oder fuss zeilen [was] INCR 1;
+ IF NOT only command line (zeile)
+ THEN IF mindestens ein kommando vorhanden
+ THEN kopf oder fuss laenge [was] INCR max zeilenvorschub;
+ bereichshoehe INCR max zeilenvorschub
+ ELSE kopf oder fuss laenge [was] INCR berechneter zeilenvorschub;
+ bereichshoehe INCR berechneter zeilenvorschub
+ FI;
+ IF bereichshoehe >= eingestellte seitenlaenge
+ THEN errorstop
+ ("head, bottom oder footzeilen > Seitenlänge (end vergessen?)")
+ FI
+ FI;
+ IF es war ein linefeed in der zeile
+ THEN berechne zeilenvorschub;
+ es war ein linefeed in der zeile := FALSE
+ FI;
+ IF erreichte seitenlaenge > eingestellte seitenlaenge
+ THEN fussnotenumbruch pruefung
+ FI.
+
+fussnote aufnehmen:
+ IF anz kopf oder fuss zeilen [footnote] > max footzeilen
+ THEN errorstop ("Zu viele Fußnotenzeilen")
+ ELIF bereichshoehe > eingestellte seitenlaenge - seitenlaenge fester teil
+ - (eingestellte seitenlaenge DIV 100 * 15)
+ THEN errorstop ("Fußnote > 85% der Seitenlänge (end vergessen?)")
+ ELSE foot zeilen [anz kopf oder fuss zeilen [footnote]] := zeile
+ FI.
+
+fussnotenumbruch pruefung:
+ IF fussnotenumbruch moeglich
+ THEN ggf fussnote aufbrechen
+ ELSE lese rueckwaerts um (anzahl);
+ IF only command line (zeile)
+ THEN lese rueckwaerts um (1)
+ FI
+ FI.
+
+fussnotenumbruch moeglich:
+ was = footnote AND anzahl > 2.
+
+ggf fussnote aufbrechen:
+ up (ausgabe);
+ IF interaktiv
+ THEN fussnotenumbruch anfrage;
+ line (2)
+ FI;
+ anweisungen fuer umbruch einfuegen.
+
+fussnotenumbruch anfrage:
+ schreibe titelzeile ("Weiterführen der Fußnote auf nächster Seite (j/n)?");
+ line (2);
+ schreibe bildschirm;
+ cursor (53, 1);
+ skip input;
+ REP
+ TEXT VAR steuerzeichen;
+ inchar (steuerzeichen);
+ IF steuerzeichen = "n"
+ THEN lese rueckwaerts um (anzahl - 1);
+ IF only command line (zeile)
+ THEN lese rueckwaerts um (1)
+ FI;
+ LEAVE ggf fussnote aufbrechen
+ ELIF steuerzeichen = "j" OR steuerzeichen = return
+ THEN LEAVE fussnotenumbruch anfrage
+ ELIF steuerzeichen = esc
+ THEN errorstop ("Abbruch durch ESC")
+ FI
+ END REP.
+
+anweisungen fuer umbruch einfuegen:
+ record einfuegen ("#end#");
+ record einfuegen ("#foot continued#");
+ kommandos in dummy speichern;
+ record einfuegen (dummy);
+ record einfuegen ("Forts. von letzter Seite: ");
+ lese rueckwaerts um (3);
+ kommando index := end.
+END PROC zeile speichern;
+
+PROC lese rueckwaerts um (INT CONST anzahl):
+ to line (ausgabe, line no (ausgabe) - anzahl);
+ read record (ausgabe, zeile)
+END PROC lese rueckwaerts um;
+
+PROC schreibe kopf oder fuss (INT CONST was):
+ IF was = footnote
+ THEN fussnoten generieren
+ ELIF laufende spaltennr < 2
+ THEN kopf oder fuss zeilen generieren
+ FI.
+
+kopf oder fusszeilen generieren:
+INT VAR i :: 1;
+BOOL VAR in generierter zeile war kommando :: FALSE;
+ ggf anfangs kommandos generieren;
+ FOR i FROM 2 UPTO anz kopf oder fuss zeilen [was] REP
+ dummy := kopf fuss zeilen [was] [i];
+ IF NOT in generierter zeile war kommando
+ THEN in generierter zeile war kommando :=
+ pos (dummy, kommandozeichen) <> 0
+ FI;
+ fuege seitennr ein;
+ record einfuegen (dummy)
+ END REP;
+ ggf ende kommandos generieren.
+
+ggf anfangs kommandos generieren:
+ kommandos in dummy speichern;
+ IF dummy <> kopf fuss zeilen [was] [1]
+ THEN record einfuegen (kopf fuss zeilen [was] [1])
+ FI.
+
+ggf ende kommandos generieren:
+ kommandos in dummy speichern;
+ IF dummy <> kopf fuss zeilen [was] [1] OR
+ in generierter zeile war kommando
+ THEN record einfuegen (dummy)
+ FI.
+
+fuege seitennr ein:
+INT VAR k;
+ change all (dummy,
+ (seitenzeichen SUB 1) + (seitenzeichen SUB 1),
+ text (laufende seitennr [1] +1));
+ FOR k FROM 1 UPTO length (seitenzeichen) REP
+ change all (dummy, seitenzeichen SUB k, text (laufende seitennr [k]));
+ END REP.
+
+fussnoten generieren:
+ kommandos in dummy speichern;
+ letzte kommandoleiste := dummy;
+ i := 1;
+ WHILE i < anz kopf oder fusszeilen [footnote] REP
+ IF kommandos vorhanden [i]
+ THEN IF letzte kommandoleiste <> footzeilen [i]
+ THEN record einfuegen (footzeilen [i]);
+ letzte kommandoleiste := footzeilen [i]
+ FI
+ ELSE record einfuegen (footzeilen [i])
+ FI;
+ i INCR 1
+ END REP;
+ IF footzeilen [i] <> dummy
+ THEN record einfuegen (dummy)
+ FI
+END PROC schreibe kopf oder fuss;
+
+PROC fussnoten loeschen:
+ kopf oder fuss laenge [footnote] := 0;
+ anz kopf oder fuss zeilen [footnote] := 0
+END PROC fussnoten loeschen;
+
+PROC schreibe ggf fuss:
+ record einfuegen ("#text end#");
+ ggf tabellenende generieren;
+ letztes seitenende war mit absatz := letzte textzeile war mit absatz;
+ IF erreichte seitenlaenge <> eingestellte seitenlaenge
+ THEN schreibe freien platz
+ FI;
+ IF kopf oder fuss laenge [footnote] > 0
+ THEN ggf tabellenende generieren;
+ schreibe kopf oder fuss (footnote);
+ fussnoten loeschen
+ FI;
+ IF (NOT insert last bottom AND laufende seitennr [1] = nummer letzte seite)
+ OR ausgeschalteter bottom
+ THEN
+ ELSE schreibe mal fussbereich
+ FI.
+
+schreibe mal fussbereich:
+ IF kopf oder fuss laenge [fuss] > 0
+ THEN schreibe kopf oder fuss (fuss)
+ ELIF kopf oder fuss laenge [fuss gerade] > 0 AND
+ (laufende seitennr [1] MOD 2 = 0)
+ THEN schreibe kopf oder fuss (fuss gerade)
+ ELIF kopf oder fuss laenge [fuss ungerade] > 0 AND
+ (laufende seitennr [1] MOD 2 <> 0)
+ THEN schreibe kopf oder fuss (fuss ungerade)
+ FI.
+
+ggf tabellenende generieren:
+ IF tab pos speicher <> ""
+ THEN record einfuegen ("#clear pos# ")
+ FI;
+ IF in tabelle
+ THEN record einfuegen ("#table end# ");
+ letztes seitenende war in tabelle := TRUE;
+ in tabelle := FALSE
+ FI.
+
+schreibe freien platz:
+ IF pageblock on
+ THEN schreibe ggf stauchung oder streckungs anweisung
+ ELSE schreibe free (eingestellte seitenlaenge - erreichte seitenlaenge)
+ FI.
+
+schreibe ggf stauchung oder streckungs anweisung:
+ IF interaktiv AND seitenluecke > fuenf prozent der seitenlaenge
+ THEN cursor (1, 2);
+ dummy := begin mark;
+ dummy CAT "Soll die Seite beim Druck gestreckt werden (";
+ dummy CAT text (ystepconversion (seitenluecke));
+ dummy CAT " cm)";
+ dummy CAT end mark;
+ IF no (dummy)
+ THEN cursor (1, 2);
+ out (cl eol);
+ schreibe free
+ (eingestellte seitenlaenge - erreichte seitenlaenge);
+ line;
+ LEAVE schreibe ggf stauchung oder streckungs anweisung
+ FI;
+ cursor (1, 2);
+ out (cl eol);
+ line
+ FI;
+ INT VAR i :: lineno (ausgabe);
+ to line (ausgabe, textbegin zeilennr);
+ dummy := "#textbegin (";
+ dummy CAT text (anz textzeilen);
+ dummy CAT ", """;
+ dummy CAT text (ystepconversion (seitenluecke));
+ dummy CAT """)#";
+ read record (ausgabe, zeile);
+ IF (zeile SUB length (zeile)) = blank
+ THEN dummy CAT blank
+ FI;
+ write record (ausgabe, dummy);
+ to line (ausgabe, i).
+
+seitenluecke:
+ eingestellte seitenlaenge - erreichte seitenlaenge.
+
+fuenf prozent der seitenlaenge:
+ ((eingestellte seitenlaenge + 99) DIV 100) * 5.
+END PROC schreibe ggf fuss;
+
+(**************************** kommando speicherung *****************)
+
+PROC grenzmarkierung in dummy speichern:
+ dummy := "#page##";
+ dummy CAT (3 * "-----------");
+ dummy CAT " Ende der Seite ";
+ IF in nullter seite
+ THEN dummy CAT "0 "
+ ELSE dummy CAT (text (laufende seitennr [1]) + blank)
+ FI;
+ IF anz spalten > 1
+ THEN dummy CAT "und Spalte ";
+ dummy CAT (text (laufende spaltennr) + blank)
+ ELSE dummy CAT "-----------"
+ FI;
+ dummy CAT kommando zeichen
+END PROC grenzmarkierung in dummy speichern;
+
+PROC kommandos in dummy speichern:
+ type speichern;
+ dummy CAT modifikation;
+ limit speichern;
+ linefeed mit absatzblank speichern.
+
+type speichern:
+ dummy := "#type(""";
+ dummy CAT eingestellter typ;
+ dummy CAT """)#".
+
+limit speichern:
+ dummy CAT "#limit(";
+ dummy CAT eingestelltes limit;
+ dummy CAT ")#".
+
+linefeed mit absatzblank speichern:
+ dummy CAT "#linefeed(0";
+ dummy CAT text (real eingestellter zeilenvorschub);
+ dummy CAT ")# ".
+END PROC kommandos in dummy speichern;
+
+PROC kommandos aufheben:
+ kommandos in dummy speichern;
+ kommando speicher := dummy
+END PROC kommandos aufheben;
+
+PROC kommandos wiederherstellen:
+ zeile := kommando speicher;
+ kommandos verarbeiten;
+ berechneter zeilenvorschub :=
+ int (real (type zeilenvorschub) * real eingestellter zeilenvorschub + 0.5);
+ max zeilenvorschub := berechneter zeilenvorschub;
+ max type zeilenvorschub := type zeilenvorschub
+END PROC kommandos wiederherstellen;
+
+(**************************** headzeilen einfuegen ************************)
+
+PROC schreibe ggf kopf:
+ IF (NOT insert first head AND laufende seiten nr [1] = nummer erste seite)
+ OR ausgeschalteter head
+ THEN
+ ELSE schreibe mal
+ FI;
+ ggf tabellenanfang generieren;
+ text begin anweisung generieren.
+
+schreibe mal:
+ IF kopf oder fuss laenge [kopf] > 0
+ THEN schreibe kopf oder fuss (kopf);
+ aktuelle seitenlaenge INCR kopf oder fuss laenge [kopf]
+ ELIF kopf oder fuss laenge [kopf gerade] > 0
+ AND (laufende seitennr [1] MOD 2 = 0)
+ THEN schreibe kopf oder fuss (kopf gerade);
+ aktuelle seitenlaenge INCR kopf oder fuss laenge [kopf gerade]
+ ELIF kopf oder fuss laenge [kopf ungerade] > 0
+ AND (laufende seitennr [1] MOD 2 <> 0)
+ THEN schreibe kopf oder fuss (kopf ungerade);
+ aktuelle seitenlaenge INCR kopf oder fuss laenge [kopf ungerade]
+ FI.
+
+ggf tabellenanfang generieren:
+ IF tab pos speicher <> ""
+ THEN record einfuegen ("#clearpos#");
+ record einfuegen (tab pos speicher)
+ FI;
+ IF letztes seitenende war in tabelle
+ THEN record einfuegen ("#table# ");
+ letztes seitenende war in tabelle := FALSE;
+ in tabelle := TRUE
+ FI.
+
+text begin anweisung generieren:
+ dummy := "#text begin#";
+ IF letztes seitenende war mit absatz
+ THEN dummy CAT " "
+ FI;
+ record einfuegen (dummy);
+ textbegin zeilennr := line no (ausgabe) - 1.
+END PROC schreibe ggf kopf;
+
+PROC erhoehe seiten und spaltennr:
+ IF anz spalten > 1
+ THEN erhoehe spaltennummer
+ FI;
+ IF NOT in nullter seite
+ THEN erhoehe seitennummer
+ FI.
+
+erhoehe spaltennummer:
+ laufende spaltennr INCR 1;
+ IF laufende spaltennr > anz spalten
+ THEN laufende spaltennr := 1;
+ text laenge vor columns := 0
+ ELSE LEAVE erhoehe seiten und spaltennr
+ FI.
+
+erhoehe seitennummer:
+ INT VAR i;
+ FOR i FROM 1 UPTO length (seitenzeichen) REP
+ laufende seitennr [i] INCR 1
+ END REP
+END PROC erhoehe seiten und spaltennr;
+
+PROC seitennummer setzen (INT CONST akt nummer):
+ IF pos (seitenzeichen, par1) = 0
+ THEN IF length (seitenzeichen) >= max anz seitenzeichen
+ THEN fehler (16, "");
+ LEAVE seitennummer setzen
+ FI;
+ seitenzeichen CAT par1
+ FI;
+ laufende seitennr [pos (seitenzeichen, par1)] := akt nummer.
+END PROC seitennummer setzen;
+
+PROC kommando seitenspeicher fuellen:
+ kommando seitenspeicher CAT "#";
+ kommando seitenspeicher CAT kommando;
+ kommando seitenspeicher CAT "#"
+END PROC kommando seitenspeicher fuellen;
+
+(************************** kommandos verarbeiten ********************)
+
+PROC verarbeite kommando:
+INT VAR anz params, intparam;
+ kommando ende pos :=
+ pos (zeile, kommando zeichen, kommando anfangs pos + 1);
+ IF kommando ende pos <> 0
+ THEN kommando oder kommentar kommando verarbeiten
+ ELSE fehler (2,
+ subtext (zeile, kommandoanfangspos, kommandoanfangspos+9)+"...");
+ zeile CAT kommando zeichen;
+ write record (ausgabe, zeile);
+ kommando ende pos := length (zeile)
+ FI.
+
+kommando oder kommentar kommando verarbeiten:
+ IF pos ("-/"":", zeile SUB kommando anfangs pos + 1) = 0
+ THEN kommando :=
+ subtext (zeile, kommando anfangs pos + 1, kommando ende pos - 1);
+ scanne kommando;
+ setze kommando um
+ ELSE kommando index := 0
+ FI.
+
+scanne kommando:
+ analyze command (kommandoliste, kommando, 3,
+ kommando index, anz params, par1, par2);
+ disable stop;
+ command error;
+ IF is error
+ THEN dummy := error message;
+ clear error;
+ dummy CAT " -> ";
+ dummy CAT kommando;
+ fehler (22, dummy);
+ enable stop;
+ LEAVE verarbeite kommando
+ FI;
+ enable stop.
+
+setze kommando um:
+ IF durchgang = 3 AND kommando index <> value1 AND kommando index <> to page
+ AND kommando index <> counter value1
+ THEN LEAVE verarbeite kommando
+ FI;
+ SELECT kommando index OF
+
+CASE type1:
+ modifikation := "";
+ IF in index oder exponent > 0
+ THEN LEAVE setze kommando um
+ ELIF font exists (par1)
+ THEN font nr := font (par1);
+ eingestellter typ := par1;
+ type zeilenvorschub :=
+ font height (fontnr) + font lead (fontnr) + font depth (fontnr);
+ IF type zeilenvorschub > max type zeilenvorschub
+ THEN max type zeilenvorschub := type zeilenvorschub
+ FI
+ ELSE fehler (1, par1)
+ FI;
+ berechne zeilenvorschub
+
+CASE linefeed:
+ realparam := real (par1);
+ IF last conversion ok AND pos (par1, ".") <> 0
+ THEN real eingestellter zeilenvorschub := realparam;
+ es war ein linefeed in der zeile := TRUE
+ ELSE fehler (4, par1)
+ FI
+
+CASE limit:
+ eingestelltes limit := par1
+
+CASE free:
+ realparam := real (par1);
+ IF last conversion ok AND pos (par1, ".") <> 0
+ THEN IF keine zeichen ausser blank nach dem kommando
+ THEN free kommando ausfuehren
+ ELSE fehler (19, kommando);
+ FI
+ ELSE fehler (4, par1)
+ FI
+
+CASE page command0:
+ IF keine zeichen ausser blank nach dem kommando
+ THEN page behandlung;
+ schreibe titelzeile
+ ELSE fehler (19, kommando)
+ FI
+
+CASE page command1:
+ IF keine zeichen ausser blank nach dem kommando
+ THEN INT VAR seitennummer mit page := int (par1);
+ page behandlung;
+ laufende spaltennr := 1;
+ text laenge vor columns := 0;
+ IF seitennummer mit page <= 0
+ THEN fehler (27, "page (" + text (seitennummer mit page) + ")")
+ ELSE laufende seitennr [1] := seitennummer mit page
+ FI
+ ELSE fehler (19, kommando)
+ FI
+
+CASE pagenr:
+ IF in nullter seite OR durchgang = 4
+ THEN intparam := int (par2);
+ IF length (par1) <> 1
+ THEN fehler (14, "")
+ ELIF NOT last conversion ok
+ THEN fehler (5, kommando)
+ ELIF intparam <= 0
+ THEN fehler (27, kommando)
+ ELSE seitennummer setzen (intparam)
+ FI
+ ELIF durchgang = 2
+ THEN kommando seitenspeicher fuellen
+ FI
+
+CASE pagelength:
+ realparam := real (par1);
+ IF last conversion ok AND pos (par1, ".") <> 0
+ THEN IF in nullter seite OR durchgang = 4
+ THEN eingestellte seitenlaenge := y step conversion (realparam)
+ ELIF durchgang = 2
+ THEN kommando seitenspeicher fuellen
+ FI
+ ELSE fehler (4, kommando)
+ FI
+
+CASE foot, foot contd:
+ fussnote aufnehmen
+
+CASE end:
+ IF NOT bereich aufnehmen
+ THEN fehler (31, "")
+ FI;
+ bereich aufnehmen := FALSE;
+ kommando index := end;
+ IF NOT keine zeichen ausser blank nach dem kommando
+ THEN fehler (19, kommando)
+ FI
+
+CASE head:
+ bereich aufnehmen := TRUE;
+ IF keine zeichen ausser blank nach dem kommando
+ THEN kopf oder fuss laenge [kopf ungerade] := 0;
+ kopf oder fuss laenge [kopf gerade] := 0;
+ aufnehmen (kopf)
+ ELSE fehler (19, kommando)
+ FI;
+ bereich aufnehmen := FALSE
+
+CASE headeven:
+ bereich aufnehmen := TRUE;
+ IF keine zeichen ausser blank nach dem kommando
+ THEN kopf oder fuss laenge [kopf] := 0;
+ aufnehmen (kopf gerade)
+ ELSE fehler (19, kommando)
+ FI;
+ bereich aufnehmen := FALSE
+
+CASE headodd:
+ bereich aufnehmen := TRUE;
+ IF keine zeichen ausser blank nach dem kommando
+ THEN kopf oder fuss laenge [kopf] := 0;
+ aufnehmen (kopf ungerade)
+ ELSE fehler (19, kommando)
+ FI;
+ bereich aufnehmen := FALSE
+
+CASE bottom:
+ bereich aufnehmen := TRUE;
+ IF keine zeichen ausser blank nach dem kommando
+ THEN kopf oder fuss laenge [fuss ungerade] := 0;
+ kopf oder fuss laenge [fuss gerade] := 0;
+ aufnehmen (fuss)
+ ELSE fehler (19, kommando)
+ FI;
+ bereich aufnehmen := FALSE
+
+CASE bottomeven:
+ bereich aufnehmen := TRUE;
+ IF keine zeichen ausser blank nach dem kommando
+ THEN kopf oder fuss laenge [fuss] := 0;
+ aufnehmen (fuss gerade)
+ ELSE fehler (19, kommando)
+ FI;
+ bereich aufnehmen := FALSE
+
+CASE bottomodd:
+ bereich aufnehmen := TRUE;
+ IF keine zeichen ausser blank nach dem kommando
+ THEN kopf oder fuss laenge [fuss] := 0;
+ aufnehmen (fuss ungerade)
+ ELSE fehler (19, kommando)
+ FI;
+ bereich aufnehmen := FALSE
+
+CASE columns:
+ IF anz spalten > 1
+ THEN fehler (29, "")
+ ELSE anz spalten := int (par1);
+ laufende spalten nr := 1;
+ IF anz spalten < 2
+ THEN fehler (26, "");
+ anz spalten := 2
+ FI;
+ text laenge vor columns :=
+ aktuelle seitenlaenge + kopf oder fuss laenge [footnote]
+ FI
+
+CASE columnsend:
+ IF durchgang = 1
+ THEN delete record (ausgabe);
+ IF NOT nur dateiende danach
+ THEN seitenende einbringen und zurueck;
+ record einfuegen ("#columnsend#");
+ text laenge vor columns := 0;
+ laufende spaltennr := 1;
+ anz spalten := 1;
+ kommando index := page command0;
+ down (ausgabe)
+ FI
+ FI
+
+CASE topage:
+ IF durchgang > 1
+ THEN ggf gespeicherte nummer einsetzen (par1);
+ mindestens ein topage gewesen := TRUE
+ FI
+
+CASE goalpage:
+ IF durchgang > 1
+ THEN nummer und kennzeichen speichern (laufende seitennr[1], par1)
+ FI
+
+CASE count0, count1:
+ IF durchgang > 1
+ THEN counter INCR 1;
+ change (zeile,
+ kommando anfangs pos, kommando ende pos, text(counter));
+ kommando ende pos := kommando anfangs pos;
+ write record (ausgabe, zeile);
+ IF anz params = 1
+ THEN nummer und kennzeichen speichern (counter, par1)
+ FI
+ FI
+
+CASE setcount:
+ intparam := int (par1);
+ IF last conversion ok AND intparam >= 0
+ THEN counter := intparam - 1
+ ELSE fehler (30, par1)
+ FI
+
+CASE value0:
+ IF durchgang > 1
+ THEN change (zeile, kommando anfangs pos, kommando ende pos,
+ text (counter));
+ write record (ausgabe, zeile);
+ kommando ende pos := kommando anfangs pos
+ FI
+
+CASE value1:
+ IF durchgang > 1
+ THEN ggf gespeicherte nummer einsetzen (par1)
+ FI
+
+CASE on:
+ change all (par1, " ", "");
+ par1 := (par1 SUB 1);
+ modifikation CAT "#on(""" + par1 + """)#"
+
+CASE off:
+ change all (par1, " ", "");
+ par1 := (par1 SUB 1);
+ changeall (modifikation, "#on(""" + par1 + """)#", "");
+
+CASE head on: ausgeschalteter head := FALSE
+CASE head off: ausgeschalteter head := TRUE
+
+CASE bottom on: ausgeschalteter bottom := FALSE
+CASE bottom off: ausgeschalteter bottom := TRUE
+
+CASE count per page: count seitenzaehlung := TRUE
+
+CASE table:
+ IF durchgang > 1
+ THEN in tabelle := TRUE
+ FI
+
+CASE table end:
+ IF durchgang > 1
+ THEN in tabelle := FALSE
+ FI
+
+CASE r pos, l pos, c pos, d pos, b pos, clearpos1, fillchar:
+ IF durchgang > 1
+ THEN tab pos speicher CAT "#";
+ tab pos speicher CAT kommando;
+ tab pos speicher CAT "#"
+ FI
+
+CASE clearpos0:
+ IF durchgang > 1
+ THEN tab pos speicher := ""
+ FI
+
+CASE pageblock : pageblock on := TRUE
+
+CASE counter1, counter2:
+ IF durchgang > 1
+ THEN process counter
+ FI
+
+CASE set counter:
+ IF durchgang > 1
+ THEN process set counter
+ FI
+
+CASE counter store:
+ IF durchgang > 1
+ THEN process counter store
+ FI
+
+CASE counter value0:
+ IF durchgang > 1
+ THEN write dec value into file
+ FI
+
+CASE counter value1:
+ IF durchgang > 1
+ THEN process counter value
+ FI
+
+CASE u, d:
+ in index oder exponent INCR 1
+
+CASE e:
+ in index oder exponent DECR 1
+
+OTHERWISE
+ kommando index := 0;
+ IF macro command and then process parameters (kommando)
+ THEN ersetze macro
+ FI
+END SELECT.
+
+nur dateiende danach:
+ INT VAR diese zeile :: line no (ausgabe);
+ WHILE NOT eof (ausgabe) REP
+ read record (ausgabe, zeile);
+ IF length (zeile) > 1
+ THEN to line (ausgabe, diese zeile);
+ read record (ausgabe, zeile);
+ LEAVE nur dateiende danach WITH FALSE
+ FI;
+ down (ausgabe)
+ END REP;
+ to line (ausgabe, diese zeile);
+ read record (ausgabe, zeile);
+ TRUE.
+END PROC verarbeite kommando;
+
+(************************ Makro-Ersetzung **************************)
+
+PROC ersetze macro:
+ INT VAR erste zeile :: line no (ausgabe);
+ hole texte um macro herum;
+ fuege macro zeilen ein;
+ fuege text nach macro an;
+ positioniere zurueck.
+
+hole texte um macro herum:
+ vor macro := subtext (zeile, 1, kommando anfangs pos - 1);
+ nach macro := subtext (zeile, kommando ende pos + 1).
+
+fuege macro zeilen ein:
+ INT VAR anz :: 1;
+ WHILE anz < number macro lines REP
+ get macro line (macro line);
+ IF anz = 1
+ THEN vor macro CAT macro line ;
+ write record (ausgabe, vor macro);
+ ELSE down (ausgabe);
+ insert record (ausgabe);
+ write record (ausgabe, macro line)
+ FI;
+ anz INCR 1
+ END REP.
+
+fuege text nach macro an:
+ read record (ausgabe, zeile);
+ IF length (nach macro) <> 0
+ THEN zeile CAT nach macro
+ ELIF (zeile SUB length (zeile)) <> blank AND number macro lines > 2
+ THEN delete record (ausgabe);
+ read record (ausgabe, dummy);
+ zeile CAT dummy
+ FI;
+ IF subtext (zeile, length (zeile) - 1, length (zeile)) = " "
+ THEN delete char (zeile, length (zeile))
+ FI;
+ write record (ausgabe, zeile).
+
+positioniere zurueck:
+ to line (ausgabe, erste zeile);
+ read record (ausgabe, zeile);
+ IF in nullter seite
+ THEN zeile noch nicht verarbeitet := TRUE
+ FI;
+ kommando ende pos := kommando anfangs pos - 1.
+END PROC ersetze macro;
+
+(************************ Zeilenvorschub-Berechnung ****************)
+
+PROC berechne zeilenvorschub:
+ berechneter zeilenvorschub :=
+ int (real (type zeilenvorschub) * real eingestellter zeilenvorschub + 0.5);
+ IF real eingestellter zeilenvorschub >= 1.0
+ THEN max zeilenvorschub := max
+ (int (real (max type zeilenvorschub)*real eingestellter zeilenvorschub + 0.5),
+ berechneter zeilenvorschub)
+ ELIF berechneter zeilenvorschub > max zeilenvorschub
+ THEN max zeilenvorschub := berechneter zeilenvorschub
+ FI
+END PROC berechne zeilenvorschub;
+
+(**************************** counter processing **********************)
+
+PROC process counter:
+ dummy := "#";
+ dummy CAT par1;
+ dummy CAT "#";
+ IF pos (counter numbering store, dummy) = 0
+ THEN fehler (34, par1);
+ LEAVE process counter
+ FI;
+ get dec value (counter numbering store);
+ IF kommando index = counter2
+ THEN resize dec value to needed points
+ FI;
+ IF dec value was just initialized
+ THEN dec value := subtext (dec value, 2)
+ ELIF kommando index = counter1
+ THEN digit value := int (dec value);
+ digit value INCR 1;
+ dec value := text (digit value)
+ ELSE incr counter value
+ FI;
+ write dec value into file;
+ replace value in numbering store (dec value).
+
+resize dec value to needed points:
+ INT VAR needed points :: int (par2),
+ begin of last digit :: 1;
+ WHILE needed points > 0 REP
+ IF next point pos = 0
+ THEN IF needed points = 1
+ THEN dec value CAT ".0"
+ ELSE dec value CAT ".1"
+ FI;
+ begin of last digit := length (dec value)
+ ELSE begin of last digit := next point pos + 1
+ FI;
+ needed points DECR 1
+ END REP;
+ INT VAR end of last digit := next point pos - 1;
+ IF end of last digit < 0
+ THEN end of last digit := length (dec value)
+ FI;
+ dec value := subtext (dec value, 1, end of last digit).
+
+next point pos:
+ pos (dec value, ".", begin of last digit).
+
+dec value was just initialized:
+ (dec value SUB 1) = "i".
+
+incr counter value:
+ INT VAR digit value :: int (
+ subtext (dec value, begin of last digit, end of last digit));
+ digit value INCR 1;
+ change (dec value, begin of last digit, end of last digit,
+ text (digit value)).
+END PROC process counter;
+
+PROC process set counter:
+ dummy := "#";
+ dummy CAT par1;
+ dummy CAT "#";
+ IF pos (counter numbering store, dummy) <> 0
+ THEN warnung (15, par1);
+ replace value in numbering store (par2);
+ INT VAR begin pos :: pos (counter numbering store, dummy) + 1;
+ begin pos := pos (counter numbering store, "#", beginpos) + 1;
+ insert char (counter numbering store, "i", begin pos)
+ ELSE counter numbering store CAT dummy;
+ counter numbering store CAT "i";
+ counter numbering store CAT par2
+ FI.
+END PROC process set counter;
+
+PROC process counter store:
+ IF pos (counter reference store, par1) <> 0
+ THEN fehler (35, par1)
+ ELSE store it
+ FI.
+
+store it:
+ counter reference store CAT "#";
+ counter reference store CAT par1;
+ counter reference store CAT "#";
+ counter reference store CAT dec value
+END PROC process counter store;
+
+PROC process counter value:
+ dummy := "#";
+ dummy CAT par1;
+ dummy CAT "#";
+ IF pos (counter reference store, dummy) <> 0
+ THEN get dec value (counter reference store);
+ write dec value into file
+ ELIF durchgang = 3
+ THEN fehler (61, par1)
+ FI.
+END PROC process counter value;
+
+PROC replace value in numbering store (TEXT CONST val):
+ INT VAR begin pos :: pos (counter numbering store, dummy) + 1;
+ begin pos := pos (counter numbering store, "#", begin pos) + 1;
+ INT VAR end pos := pos (counter numbering store, "#", begin pos)-1;
+ IF end pos <= 0
+ THEN end pos := length (counter numbering store)
+ FI;
+ change (counter numbering store, begin pos, end pos, val)
+END PROC replace value in numbering store;
+
+PROC write dec value into file:
+ change (zeile, kommando anfangs pos, kommando ende pos, dec value);
+ kommando ende pos := kommando anfangs pos;
+ write record (ausgabe, zeile)
+END PROC write dec value into file;
+
+PROC get dec value (TEXT CONST store):
+ INT VAR value begin :: pos (store, dummy);
+ value begin := pos (store, "#", value begin + 1) + 1;
+ INT VAR value end :: pos (store, "#", value begin)-1;
+ IF value end < 0
+ THEN value end := length (store)
+ FI;
+ dec value := subtext (store, value begin, value end).
+END PROC get dec value;
+
+(************************** Zaehler routinen ('refer') ***************)
+
+PROC nummer und kennzeichen speichern (INT CONST number, TEXT VAR kennung):
+ ueberpruefe auf bereits vorhandenes kennzeichen;
+ anz refers INCR 1;
+ IF anz refers > max refers
+ THEN errorstop ("Anzahl Referenzen zu gross")
+ FI;
+ refer sammler [anz refers] . kennzeichen := kennung;
+ refer sammler [anz refers] . nummer := number;
+ refer sammler [anz refers] . referenced := FALSE.
+
+ueberpruefe auf bereits vorhandenes kennzeichen:
+ INT VAR i;
+ FOR i FROM 1 UPTO anz refers REP
+ IF refer sammler [i] . kennzeichen = kennung
+ THEN warnung (9, kennung);
+ LEAVE nummer und kennzeichen speichern
+ FI
+ END REP.
+END PROC nummer und kennzeichen speichern;
+
+PROC ggf gespeicherte nummer einsetzen (TEXT VAR kennung):
+ IF kennzeichen vorhanden
+ THEN change (zeile, kommando anfangs pos, kommando ende pos, textnummer);
+ refer sammler [i] . referenced := TRUE;
+ kommando ende pos := kommando anfangs pos;
+ write record (ausgabe, zeile)
+ ELIF durchgang = 3
+ THEN warnung (4, kennung)
+ FI.
+
+textnummer:
+ text (refer sammler [i] . nummer).
+
+kennzeichen vorhanden:
+INT VAR i;
+ FOR i FROM 1 UPTO anz refers REP
+ IF refer sammler [i] . kennzeichen = kennung
+ THEN LEAVE kennzeichen vorhanden WITH TRUE
+ FI
+ END REP;
+ FALSE.
+END PROC ggf gespeicherte nummer einsetzen;
+
+(************************** free-Kommando *****************************)
+
+PROC free kommando ausfuehren:
+INT CONST wert in y steps :: y step conversion (realparam);
+ IF bereich aufnehmen
+ THEN
+ ELIF wert in y steps>=eingestellte seitenlaenge - seitenlaenge fester teil
+ THEN fehler (13, "")
+ ELIF erreichte seitenlaenge + wert in y steps > eingestellte seitenlaenge
+ THEN ende einer seite;
+ kommando index := fehler index
+ ELSE aktuelle seitenlaenge INCR wert in y steps
+ FI
+END PROC free kommando ausfuehren;
+
+(*************************** page-Kommando ******************************)
+
+PROC page behandlung:
+TEXT VAR steuerzeichen;
+ page kommando entfernen;
+ IF aktuelle seitenlaenge <= 0
+ THEN IF line no (ausgabe) = 1
+ THEN zeile noch nicht verarbeitet := TRUE
+ ELSE up (ausgabe)
+ FI;
+ LEAVE page behandlung
+ FI;
+ IF interaktiv
+ THEN initialisiere bildschirm fuer page;
+ mit page interaktiv formatieren;
+ schreibe titelzeile;
+ FI;
+ BOOL CONST hilf :: pageblock on;
+ pageblock on := FALSE;
+ seitenende einbringen und zurueck;
+ pageblock on := hilf;
+ kommando index := page command0.
+
+page kommando entfernen:
+ IF kommando anfangs pos = 1
+ THEN delete record (ausgabe);
+ IF line no (ausgabe) = 1
+ THEN zeile noch nicht verarbeitet := TRUE
+ FI
+ ELSE zeile := subtext (zeile, 1, kommando anfangs pos - 1);
+ write record (ausgabe, zeile);
+ IF NOT only command line (zeile)
+ THEN aktuelle seitenlaenge INCR max zeilenvorschub
+ FI;
+ down (ausgabe)
+ FI.
+
+initialisiere bildschirm fuer page:
+ schreibe titelzeile
+ ("#page# bestaetigen: RETURN / loeschen: HOP RUBOUT / Abbruch: ESC");
+ line ; out (cleol);
+ put ("#page# nach");
+ put (y step conversion (erreichte seitenlaenge)); put ("cm");
+ schreibe bildschirm;
+ out (hop).
+
+mit page interaktiv formatieren:
+ REP
+ inchar (steuerzeichen);
+ IF steuerzeichen = return
+ THEN zeilenmitteilung loeschen;
+ LEAVE mit page interaktiv formatieren
+ ELIF steuerzeichen = rubout
+ THEN weitermachen
+ ELIF steuerzeichen = esc
+ THEN errorstop ("Abbruch mit ESC")
+ FI
+ END REP.
+
+weitermachen:
+ zeilenmitteilung loeschen;
+ up (ausgabe);
+ LEAVE page behandlung.
+
+zeilenmitteilung loeschen:
+ cursor (1, 2); out (cleol); line.
+END PROC page behandlung;
+
+PROC seite nochmal durchgehen:
+ zurueck bis seitenende;
+ kommandos wiederherstellen;
+ down (ausgabe);
+ IF count seitenzaehlung
+ THEN counter := 0
+ FI;
+ schreibe ggf kopf;
+ read record (ausgabe, zeile);
+ seitenlaenge initialisieren;
+ fussnoten loeschen;
+ bis seitenende lesen und kommandos verarbeiten;
+ schreibe ggf fuss;
+ initialisieren fuer neue seite.
+
+bis seitenende lesen und kommandos verarbeiten:
+ durchgang := 2;
+ zeilen und kommandos verarbeiten;
+ durchgang := 1.
+
+zeilen und kommandos verarbeiten:
+ anz textzeilen := 0;
+ WHILE NOT seitenende REP
+ IF mindestens ein kommando vorhanden
+ THEN IF NOT only command line (zeile)
+ THEN anz textzeilen INCR 1
+ FI;
+ kommandos verarbeiten und ggf zeile mitzaehlen;
+ ELSE aktuelle seitenlaenge INCR berechneter zeilenvorschub;
+ anz textzeilen INCR 1
+ FI;
+ naechste zeile lesen
+ END REP.
+
+initialisieren fuer neue seite:
+ kommandos aufheben;
+ fussnoten loeschen;
+ erhoehe seiten und spaltennr;
+ seitenlaenge initialisieren
+END PROC seite nochmal durchgehen;
+
+PROC seitenlaenge initialisieren:
+ IF anz spalten > 1 AND laufende spaltennr > 1
+ THEN aktuelle seitenlaenge := text laenge vor columns
+ ELSE aktuelle seitenlaenge := 0;
+ verarbeite seitenkommandos
+ FI.
+
+verarbeite seitenkommandos:
+ IF kommando seitenspeicher <> ""
+ THEN zeile := kommando seitenspeicher;
+ kommando seitenspeicher := "";
+ INT CONST xx := durchgang;
+ durchgang := 4;
+ kommandos verarbeiten;
+ durchgang := xx
+ FI.
+END PROC seitenlaenge initialisieren;
+
+PROC zurueck bis seitenende:
+ up (ausgabe, "#page##---", line no (ausgabe));
+ IF anz spalten > 1 AND laufende spaltennr > 1
+ THEN down (ausgabe);
+ schreibe free (text laenge vor columns + head laenge);
+ up (ausgabe)
+ FI;
+ read record (ausgabe, zeile);
+ cout (line no (ausgabe));
+END PROC zurueck bis seitenende;
+
+BOOL PROC seitenende:
+ pos (zeile, "#page#") = 1 AND pos (zeile, "-----", 8) = 8
+END PROC seitenende;
+
+(**************************** eigentliche seitenform-routine *********)
+
+PROC seiten form:
+ enable stop;
+ datei assoziieren;
+ page form initialisieren;
+ to line (ausgabe, 1);
+ read record (ausgabe, zeile);
+ in nullter seite := TRUE;
+ nullte seite verarbeiten;
+ nullte seitengrenze einfuegen;
+ in nullter seite := FALSE;
+ formieren.
+
+nullte seite verarbeiten:
+ aktuelle seitenlaenge := 0;
+ WHILE only command line (zeile) REP
+ IF seitenende
+ THEN errorstop ("Bitte Originaldatei bearbeiten (keine Druckdatei)")
+ FI;
+ kommandos verarbeiten;
+ IF es war ein free kommando OR tabellen kommando
+ THEN LEAVE nullte seite verarbeiten
+ ELIF es war ein linefeed in der zeile
+ THEN berechne zeilenvorschub;
+ es war ein linefeed in der zeile := FALSE;
+ naechste zeile lesen
+ ELIF zeile noch nicht verarbeitet
+ THEN read record (ausgabe, zeile);
+ zeile noch nicht verarbeitet := FALSE
+ ELSE naechste zeile lesen
+ FI;
+ cout (line no (ausgabe))
+ ENDREP.
+
+es war ein free kommando:
+ aktuelle seitenlaenge <> 0.
+
+tabellen kommando:
+ kommando index >= 35 AND kommando index <= 44.
+
+nullte seitengrenze einfuegen:
+ laufende spaltennr := 0;
+ grenzmarkierung in dummy speichern;
+ record einfuegen (dummy);
+ read record (ausgabe, zeile);
+ kommandos aufheben;
+ aktuelle seitenlaenge := 0;
+ erhoehe seiten und spaltennr;
+ nummer erste seite := laufende seiten nr [1].
+
+formieren:
+ REP
+ cout (line no (ausgabe));
+ IF mindestens ein kommando vorhanden
+ THEN kommandos verarbeiten und ggf zeile mitzaehlen
+ ELSE aktuelle seitenlaenge INCR berechneter zeilenvorschub;
+ FI;
+ IF erreichte seitenlaenge > eingestellte seitenlaenge
+ THEN ende einer seite
+ FI;
+ IF eof (ausgabe)
+ THEN eof behandlung;
+ LEAVE formieren
+ ELSE down (ausgabe);
+ IF eof (ausgabe)
+ THEN eof behandlung;
+ LEAVE formieren
+ ELSE read record (ausgabe, zeile)
+ FI
+ FI
+ END REP.
+END PROC seiten form;
+
+PROC eof behandlung:
+ grenzmarkierung in dummy speichern;
+ insert record (ausgabe);
+ write record (ausgabe, dummy);
+ nummer letzte seite := laufende seiten nr [1];
+ pageblock on := FALSE;
+ seite nochmal durchgehen;
+ IF anz refers <> 0 OR mindestens ein topage gewesen
+ OR counter reference store <> ""
+ THEN ausgabe datei nochmals durchgehen;
+ offene referenzen pruefen
+ FI.
+
+ausgabe datei nochmals durchgehen:
+ to line (ausgabe, 1); col (ausgabe, 1);
+ durchgang := 3;
+ REP
+ down (ausgabe, "#", lines (ausgabe));
+ IF pattern found
+ THEN read record (ausgabe, zeile);
+ cout (line no (ausgabe));
+ kommandos verarbeiten;
+ IF eof (ausgabe)
+ THEN LEAVE ausgabe datei nochmals durchgehen
+ ELSE down (ausgabe); col (ausgabe, 1)
+ FI
+ ELSE LEAVE ausgabe datei nochmals durchgehen
+ FI
+ END REP.
+
+offene referenzen pruefen:
+ INT VAR i;
+ FOR i FROM 1 UPTO anz refers REP
+ IF NOT refer sammler [i] . referenced
+ THEN report text processing warning
+ (3, 0, fehlerdummy, CONCR(refersammler) [i] . kennzeichen)
+ FI
+ END REP.
+END PROC eof behandlung;
+
+(************************** kommando verarbeitung **********)
+
+BOOL PROC mindestens ein kommando vorhanden:
+ pos (zeile, kommando zeichen) <> 0.
+END PROC mindestens ein kommando vorhanden;
+
+PROC kommandos verarbeiten:
+ kommando anfangs pos := pos (zeile, kommando zeichen);
+ WHILE kommando anfangs pos <> 0 REP
+ verarbeite kommando;
+ IF kommando index = end OR kommando index = page command0
+ OR kommando index = page command1 OR kommando index = fehler index
+ THEN LEAVE kommandos verarbeiten
+ ELSE kommando anfangs pos :=
+ pos (zeile, kommando zeichen, kommando ende pos + 1)
+ FI
+ END REP.
+END PROC kommandos verarbeiten;
+
+PROC kommandos verarbeiten und ggf zeile mitzaehlen:
+ max zeilenvorschub := berechneter zeilenvorschub;
+ max type zeilenvorschub := type zeilenvorschub;
+ kommandos verarbeiten;
+ in index oder exponent := 0;
+ zeile zur seitenlaenge ggf addieren;
+ IF es war ein linefeed in der zeile
+ THEN berechne zeilenvorschub;
+ es war ein linefeed in der zeile := FALSE
+ FI.
+
+zeile zur seitenlaenge ggf addieren:
+ IF only command line (zeile) OR
+ kommando index = end OR kommando index = page command0 OR
+ kommando index = page command1 OR kommando index = fehler index
+ THEN
+ ELSE aktuelle seitenlaenge INCR max zeilenvorschub;
+ FI.
+END PROC kommandos verarbeiten und ggf zeile mitzaehlen;
+
+BOOL PROC keine zeichen ausser blank nach dem kommando:
+ IF kommando anfangs pos > 1 AND
+ pos (zeile, ""33"", ""255"", 1) = kommando anfangs pos
+ THEN warnung (13, kommando)
+ FI;
+ kommando ende pos = length (zeile) OR
+ pos (zeile, ""33"", ""254"", kommando ende pos + 1) = 0
+END PROC keine zeichen ausser blank nach dem kommando;
+
+BOOL PROC absatz zeile:
+ (zeile SUB length (zeile)) = blank
+END PROC absatz zeile;
+
+(********************** routinen fuers seitenende *************)
+
+INT PROC erreichte seitenlaenge:
+ aktuelle seitenlaenge + kopf oder fuss laenge [footnote] +
+ seitenlaenge fester teil
+END PROC erreichte seitenlaenge;
+
+INT PROC seitenlaenge fester teil:
+ head laenge + bottom laenge.
+
+bottom laenge:
+ IF (NOT insert last bottom AND laufende seitennr [1] = nummer letzte seite)
+ OR ausgeschalteter bottom
+ THEN 0
+ ELSE kopf oder fuss laenge [fuss] +
+ bottom laenge fuer gerade oder ungerade seiten
+ FI.
+
+bottom laenge fuer gerade oder ungerade seiten:
+ IF laufende seitennr [1] MOD 2 = 0
+ THEN kopf oder fuss laenge [fuss gerade]
+ ELSE kopf oder fuss laenge [fuss ungerade]
+ FI.
+END PROC seitenlaenge fester teil;
+
+INT PROC head laenge:
+ IF (NOT insert first head AND laufende seitennr [1] = nummer erste seite)
+ OR ausgeschalteter head
+ THEN 0
+ ELSE kopf oder fuss laenge [kopf] +
+ head laenge fuer gerade oder ungerade seiten
+ FI.
+
+head laenge fuer gerade oder ungerade seiten:
+ IF laufende seitennr [1] MOD 2 = 0
+ THEN kopf oder fuss laenge [koπ3Πφ&η6φζ�
+ ELSE kopf oder fuss laenge [kopf ungerade]
+ FI.
+END PROC head laenge;
+
+PROC ende einer seite:
+ IF interaktiv
+ THEN seitenende ggf verschieben
+ ELSE seitenende fuer autopageform ggf verschieben
+ FI;
+ seitenende einbringen und zurueck.
+
+seitenende ggf verschieben:
+ BOOL VAR veraenderungen in der seite :: FALSE;
+ formatiere ueber bildschirm (veraenderungen in der seite);
+ schreibe titelzeile;
+ IF veraenderungen in der seite
+ THEN zum seitenanfang zur erneuten bearbeitung;
+ LEAVE ende einer seite
+ FI.
+
+seitenende fuer autopageform ggf verschieben:
+INT VAR i, hier :: line no (ausgabe);
+ FOR i FROM 1 UPTO 4 REP
+ zeile zurueck lesen;
+ IF absatz zeile OR line no (ausgabe) <= 2
+ THEN ggf um leerzeilen nach oben lesen;
+ naechste zeile lesen;
+ LEAVE seitenende fuer autopageform ggf verschieben
+ FI
+ END REP;
+ to line (ausgabe, hier);
+ read record (ausgabe, zeile);
+ IF pageblock on
+ THEN FOR i FROM 1 UPTO 4 REP
+ IF absatz zeile OR eof (ausgabe) OR pos (zeile, "#foot") <> 0
+ OR pos (zeile, "#free") <> 0
+ THEN naechste zeile lesen;
+ LEAVE seitenende fuer autopageform ggf verschieben
+ FI;
+ naechste zeile lesen
+ END REP;
+ to line (ausgabe, hier);
+ read record (ausgabe, zeile)
+ FI.
+
+ggf um leerzeilen nach oben lesen:
+ INT VAR ii := i;
+ WHILE zeile = " " AND pageblock on AND ii <= 4 REP
+ IF line no (ausgabe) <= 2
+ THEN LEAVE ggf um leerzeilen nach oben lesen
+ FI;
+ zeile zurueck lesen;
+ ii INCR 1
+ END REP.
+END PROC ende einer seite;
+
+PROC seitenende einbringen und zurueck:
+ letzte textzeile war mit absatz := letzte zeile;
+ down (ausgabe);
+ grenzmarkierung in dummy speichern;
+ record einfuegen (dummy);
+ up (ausgabe);
+ seite nochmal durchgehen.
+
+letzte zeile:
+ up (ausgabe);
+ read record (ausgabe, zeile);
+ absatz zeile.
+END PROC seitenende einbringen und zurueck;
+
+PROC zum seitenanfang zur erneuten bearbeitung:
+ zurueck bis seitenende;
+ durchgang := 1;
+ aktuelle seitenlaenge := 0;
+ fussnoten loeschen;
+ kommandos wiederherstellen
+END PROC zum seitenanfang zur erneuten bearbeitung;
+
+(********************** positionierungs routinen ************)
+
+PROC naechste zeile lesen:
+ down (ausgabe);
+ read record (ausgabe, zeile)
+END PROC naechste zeile lesen;
+
+PROC zeile zurueck lesen:
+ up (ausgabe);
+ read record (ausgabe, zeile);
+END PROC zeile zurueck lesen;
+
+(***************** seitenende interaktiv positionieren **********)
+
+PROC formatiere ueber bildschirm (BOOL VAR veraenderungen):
+ veraenderungen := FALSE;
+ anz zeilen nach oben := 0;
+ erste bildschirmzeile schreiben;
+ schreibe bildschirm;
+ REP
+ positioniere lfd satz nach steuerzeichen und ggf schirm schreiben
+ END REP.
+
+positioniere lfd satz nach steuerzeichen und ggf schirm schreiben:
+TEXT VAR steuerzeichen;
+ inchar (steuerzeichen);
+ IF steuerzeichen = upchar
+ THEN nach oben;
+ IF fussnoten ende
+ THEN ueberspringe fussnote nach oben;
+ schreibe bildschirm
+ FI
+ ELIF steuerzeichen = downchar
+ THEN IF fussnoten anfang
+ THEN ueberspringe fussnote nach unten;
+ schreibe bildschirm
+ ELSE nach unten;
+ IF fussnoten anfang
+ THEN ueberspringe fussnote nach unten;
+ schreibe bildschirm
+ FI
+ FI
+ ELIF steuerzeichen = hop
+ THEN sprung oder leerzeilen veraenderung;
+ schreibe bildschirm;
+ ELIF steuerzeichen = return
+ THEN IF anz zeilen nach oben < 0
+ THEN down (ausgabe);
+ read record (ausgabe, zeile)
+ FI;
+ IF zeile = "" OR zeile = " "
+ THEN leerzeilen vor neuer seite loeschen
+ FI;
+ LEAVE formatiere ueber bildschirm
+ ELIF steuerzeichen = esc
+ THEN errorstop ("Abbruch mit ESC")
+ FI.
+
+fussnoten anfang:
+ pos (zeile, "#foot") <> 0 AND anz zeilen nach oben > 0.
+
+fussnoten ende:
+ pos (zeile, "#end") <> 0.
+
+nach oben:
+ IF anz zeilen nach oben < 0
+ THEN nach oben unterhalb der seitengrenze
+ ELIF eine zeile nach oben war moeglich
+ THEN IF fussnoten ende
+ THEN ueberspringe fussnote nach oben;
+ schreibe bildschirm
+ ELIF anz vertauschte zeilen < zeilen nach oben
+ THEN out (upchar); raus; out (upchar);
+ schreibe seitenbegrenzung auf bildschirm;
+ anz vertauschte zeilen INCR 1
+ ELSE schreibe bildschirm
+ FI
+ FI.
+
+nach oben unterhalb der seitengrenze:
+ IF anz zeilen nach oben = -1
+ THEN cursor (1, pos seitengrenze); out (cl eop);
+ schreibe seitenbegrenzung auf bildschirm;
+ cursor (1, pos seitengrenze);
+ schreibe untere zeilen;
+ anz zeilen nach oben := 0
+ ELSE INT VAR bildschirmzeile unterhalb ::
+ pos seitengrenze + abs (anz zeilen nach oben) + 1;
+ cursor (1, bildschirmzeile unterhalb);
+ out (cl eol);
+ outsubtext (zeile, 1, 76);
+ anz zeilen nach oben INCR 1;
+ bildschirmzeile unterhalb DECR 1;
+ cursor (1, bildschirmzeile unterhalb);
+ schreibe seitenbegrenzung auf bildschirm;
+ zeile zurueck lesen;
+ cursor (1, pos seitengrenze)
+ FI.
+
+nach unten:
+ IF anz zeilen nach oben < -4
+ THEN
+ ELIF anz zeilen nach oben < 1
+ THEN ggf nach unten formatieren
+ ELIF anz vertauschte zeilen > 0
+ THEN out (upchar); raus; line ;
+ schreibe seitenbegrenzung auf bildschirm;
+ eine zeile nach unten wenn moeglich;
+ anz vertauschte zeilen DECR 1
+ ELSE eine zeile nach unten wenn moeglich;
+ IF fussnoten anfang
+ THEN ueberspringe fussnote nach unten;
+ FI;
+ schreibe bildschirm
+ FI.
+
+ggf nach unten formatieren:
+ IF pageblock on
+ THEN zeile nach unten ueber seitengrenze;
+ cursor (1, pos seitengrenze);
+ FI.
+
+zeile nach unten ueber seitengrenze:
+ IF eof (ausgabe) OR page oder free oder foot anweisung
+ THEN LEAVE zeile nach unten ueber seitengrenze
+ ELSE naechste zeile lesen;
+ IF eof (ausgabe) OR page oder free oder foot anweisung
+ THEN zeile zurueck lesen;
+ LEAVE zeile nach unten ueber seitengrenze
+ FI;
+ zeile zurueck lesen
+ FI;
+ IF anz zeilen nach oben = 0
+ THEN out (cl eol);
+ out (begin mark);
+ out ("Über Seitenende hinaus (Stauchung): UP/DOWN");
+ out (end mark);
+ cursor (1, pos seitengrenze + 1);
+ schreibe untere zeilen;
+ ELSE naechste zeile lesen;
+ FI;
+ cursor (1, pos seitengrenze + abs (anz zeilen nach oben) + 1);
+ out (cl eol);
+ outsubtext (zeile, 1, 76);
+ anz zeilen nach oben DECR 1;
+ cursor (1, pos seitengrenze + abs (anz zeilen nach oben) + 1);
+ schreibe seitenbegrenzung auf bildschirm.
+
+page oder free oder foot anweisung:
+ pos (zeile, "#page") <> 0 OR pos (zeile, "#free") <> 0
+ OR pos (zeile, "#foot") <> 0.
+
+sprung oder leerzeilen veraenderung:
+ INT VAR i :: 0;
+ REP
+ inchar (steuerzeichen);
+ IF steuerzeichen = upchar
+ THEN sprung nach oben
+ ELIF steuerzeichen = downchar
+ THEN sprung nach unten
+ ELIF steuerzeichen = rub out
+ THEN zeile loeschen;
+ ELIF steuerzeichen = rub in
+ THEN leerzeilen einfuegen;
+ FI
+ END REP.
+
+sprung nach oben:
+ WHILE eine zeile nach oben war moeglich REP
+ i INCR 1;
+ IF fussnoten ende
+ THEN ueberspringe fussnote nach oben;
+ LEAVE sprung oder leerzeilen veraenderung
+ FI
+ UNTIL i >= zeilen nach oben END REP;
+ LEAVE sprung oder leerzeilen veraenderung.
+
+sprung nach unten:
+ WHILE i < zeilen nach oben REP
+ IF fussnoten anfang
+ THEN ueberspringe fussnote nach unten;
+ LEAVE sprung oder leerzeilen veraenderung
+ ELSE eine zeile nach unten wenn moeglich;
+ i INCR 1;
+ FI;
+ IF fussnoten anfang
+ THEN ueberspringe fussnote nach unten;
+ LEAVE sprung oder leerzeilen veraenderung
+ FI
+ END REP;
+ LEAVE sprung oder leerzeilen veraenderung.
+
+zeile loeschen:
+ veraenderungen := TRUE;
+ up (ausgabe);
+ read record (ausgabe, zeile);
+ IF seiten ende
+ THEN down (ausgabe);
+ ELSE delete record (ausgabe);
+ FI;
+ LEAVE formatiere ueber bildschirm.
+
+leerzeilen einfuegen:
+ veraenderungen := TRUE;
+ out (cl eop);
+ REP
+ inchar (steuerzeichen);
+ IF steuerzeichen = return
+ THEN insert record (ausgabe);
+ zeile := " ";
+ write record (ausgabe, zeile);
+ out (upchar);
+ raus;
+ line
+ ELIF steuerzeichen = rubin
+ THEN LEAVE formatiere ueber bildschirm
+ FI
+ END REP.
+END PROC formatiere ueber bildschirm;
+
+PROC leerzeilen vor neuer seite loeschen:
+ WHILE zeile = "" OR zeile = " " REP
+ delete record (ausgabe);
+ IF eof (ausgabe)
+ THEN LEAVE leerzeilen vor neuer seite loeschen
+ ELSE read record (ausgabe, zeile)
+ FI
+ END REP.
+END PROC leerzeilen vor neuer seite loeschen;
+
+PROC ueberspringe fussnote nach oben:
+ WHILE eine zeile nach oben war moeglich REP
+ IF fussnoten anfang
+ THEN IF eine zeile nach oben war moeglich
+ THEN
+ FI;
+ LEAVE ueberspringe fussnote nach oben
+ FI
+ END REP.
+
+fussnoten anfang:
+ pos (zeile, "#foot#") <> 0.
+END PROC ueberspringe fussnote nach oben;
+
+PROC ueberspringe fussnote nach unten:
+ REP
+ eine zeile nach unten wenn moeglich;
+ IF fussnoten ende
+ THEN eine zeile nach unten wenn moeglich;
+ LEAVE ueberspringe fussnote nach unten
+ FI
+ END REP.
+
+fussnoten ende:
+ pos (zeile, "#end#") <> 0.
+END PROC ueberspringe fussnote nach unten;
+
+PROC schreibe free (INT CONST wert):
+REAL CONST wert in y steps :: y step conversion (wert);
+ dummy := "#free(";
+ IF wert in y steps < 1.0
+ THEN dummy CAT "0";
+ FI;
+ dummy CAT text (wert in y steps);
+ dummy CAT ")#";
+ record einfuegen (dummy);
+END PROC schreibe free;
+
+BOOL PROC eine zeile nach oben war moeglich:
+ IF line no (ausgabe) = 1
+ THEN FALSE
+ ELSE zeile zurueck lesen;
+ IF seitenende OR columns kommando in dieser zeile
+ THEN naechste zeile lesen;
+ FALSE
+ ELSE anz zeilen nach oben INCR 1;
+ TRUE
+ FI
+ FI.
+
+columns kommando in dieser zeile:
+ anz spalten > 1 AND pos (zeile, "#columns") <> 0.
+END PROC eine zeile nach oben war moeglich;
+
+PROC eine zeile nach unten wenn moeglich:
+ IF anz zeilen nach oben > 0
+ THEN naechste zeile lesen;
+ anz zeilen nach oben DECR 1
+ FI
+END PROC eine zeile nach unten wenn moeglich;
+
+PROC erste bildschirmzeile schreiben:
+ IF anz spalten > 1
+ THEN dummy := "Spalten"
+ ELSE dummy := "Seiten"
+ FI;
+ dummy CAT "ende verschieben: UP, DOWN / bestaetigen: RETURN / Abbruch: ESC";
+ schreibe titelzeile (dummy).
+END PROC erste bildschirmzeile schreiben;
+
+PROC schreibe bildschirm:
+ anz vertauschte zeilen := 0;
+ cursor (1, 3);
+ out (cl eop);
+ gehe zurueck;
+ wieder nach vorne und zeilen ausgeben;
+ cursor (1, pos seitengrenze);
+ schreibe seitenbegrenzung auf bildschirm;
+ cursor (1, pos seitengrenze);
+ schreibe untere zeilen.
+
+gehe zurueck:
+ INT VAR hier :: line no (ausgabe) -1;
+ to line (ausgabe, hier - zeilen nach oben + 1);
+ INT VAR anz read zeilen :: hier - line no (ausgabe) + 2.
+
+ wieder nach vorne und zeilen ausgeben:
+ IF line no (ausgabe) = 1
+ THEN ggf leerzeilen auf bildschirm schreiben;
+ FI;
+ WHILE line no (ausgabe) <= hier REP
+ read record (ausgabe, zeile);
+ raus;
+ down (ausgabe);
+ END REP;
+ read record (ausgabe, zeile).
+
+ggf leerzeilen auf bildschirm schreiben:
+ IF zeilen nach oben - anz read zeilen >= 0
+ THEN INT VAR i;
+ FOR i FROM 1 UPTO zeilen nach oben - anz read zeilen REP
+ line ; out (cl eol); out(" ")
+ END REP;
+ line ; out (cl eol);
+ out ("<< DATEI ANFANG >>"); out (return)
+ FI.
+END PROC schreibe bildschirm;
+
+PROC schreibe untere zeilen:
+ gehe weiter und gebe zeilen aus;
+ gehe wieder zurueck;
+ skip input;
+ cursor (1, pos seitengrenze).
+
+gehe weiter und gebe zeilen aus:
+INT VAR anz read zeilen :: 0,
+ i :: line no (ausgabe);
+ WHILE anz read zeilen < zeilen nach unten REP
+ IF eof (ausgabe)
+ THEN line ; out (cleol); out ("<< DATEI ENDE >>");
+ LEAVE gehe weiter und gebe zeilen aus
+ FI;
+ raus;
+ naechste zeile lesen;
+ anz read zeilen INCR 1
+ END REP.
+
+gehe wieder zurueck:
+ to line (ausgabe, i);
+ read record (ausgabe, zeile).
+END PROC schreibe untere zeilen;
+
+(***************** schreib-routinen fuer den bildschirm ************)
+
+PROC schreibe seitenbegrenzung auf bildschirm:
+ out (cl eol); out (begin mark);
+ grenzmarkierung in dummy speichern;
+ out (dummy);
+ out (end mark);
+ out (return)
+END PROC schreibe seitenbegrenzung auf bildschirm;
+
+PROC raus:
+INT VAR xzeile, yspalte;
+ line ; out (cl eol);
+ outsubtext (zeile, 1, 76);
+ IF absatz zeile
+ THEN get cursor (yspalte, xzeile);
+ cursor (77, xzeile);
+ out (begin end mark)
+ FI;
+ out (return)
+END PROC raus;
+
+PROC schreibe titelzeile:
+ IF online
+ THEN schreibe
+ FI.
+
+schreibe:
+ out (hop); out (cleol);
+ put ("PAGEFORM"); put ("(für"); put (lines (ausgabe)); put ("Zeilen):");
+ put (name eingabe datei);
+ put ("->");
+ put (name druck datei);
+ cursor (1, 3).
+END PROC schreibe titelzeile;
+
+PROC schreibe titelzeile (TEXT CONST t):
+ IF online
+ THEN schreibe
+ FI.
+
+schreibe:
+ out (hop); out (cl eol);
+ out (begin mark);
+ out (t);
+ out (end mark)
+END PROC schreibe titelzeile;
+
+(************************** initialisierungs-routine ************)
+
+PROC page form initialisieren:
+BOOL VAR exists;
+INT VAR i;
+ letzte textzeile war mit absatz := TRUE;
+ letztes seitenende war mit absatz := TRUE;
+ pageblock on := FALSE;
+ zeile noch nicht verarbeitet := FALSE;
+ bereich aufnehmen := FALSE;
+ count seitenzaehlung := FALSE;
+ ausgeschalteter head := FALSE;
+ ausgeschalteter bottom := FALSE;
+ in tabelle := FALSE;
+ es war ein linefeed in der zeile := FALSE;
+ letztes seitenende war in tabelle := FALSE;
+ mindestens ein topage gewesen := FALSE;
+ in index oder exponent := 0;
+ anz refers := 0;
+ kommando index := 0;
+ counter := 0;
+ laufende seitennr [1] := 1;
+ durchgang := 1;
+ anz spalten := 1;
+ modifikation := "";
+ tab pos speicher := "";
+ kommando seitenspeicher := "";
+ counter numbering store := "";
+ counter reference store := "";
+ dec value := "";
+ seitenzeichen := "%";
+ eingestelltes limit := dina4 limit;
+ IF NOT file works
+ THEN font nr := 1;
+ eingestellter typ := font (1);
+ type zeilenvorschub :=
+ font height (1) + font lead (1) + font depth (1);
+ eingestellte seitenlaenge := y step conversion (dina4 pagelength);
+ real eingestellter zeilenvorschub := 1.0
+ FI;
+ berechneter zeilenvorschub :=
+ int (real (type zeilenvorschub) * real eingestellter zeilenvorschub + 0.5);
+ max zeilenvorschub := berechneter zeilenvorschub;
+ max type zeilenvorschub := type zeilenvorschub;
+ FOR i FROM 1 UPTO 7 REP
+ kopf oder fuss laenge [i] := 0;
+ anz kopf oder fuss zeilen [i] := 0
+ END REP;
+ IF online
+ THEN page
+ FI;
+ IF command dialogue
+ THEN interaktiv := TRUE;
+ ELSE interaktiv := FALSE;
+ FI;
+ IF online
+ THEN page
+ FI;
+ schreibe titelzeile
+END PROC page form initialisieren;
+
+PROC central pagefo9ü̈NSγJr+�Cβ+̂γ��{s�β�KrΓλγb�#Τκ�ZK��
+ name eingabe datei := input;
+ name druck datei := druck;
+ IF exists (druck)
+ THEN forget (druck, quiet)
+ FI;
+ disable stop;
+ ds := nilspace;
+ refer sammler := ds;
+ seiten form;
+ forget(ds);
+ IF is error
+ THEN put error;
+ clear error;
+ last param (name eingabe datei)
+ ELSE last param (name druck datei)
+ FI;
+ enable stop;
+ IF anything noted
+ THEN note edit (ausgabe)
+ FI.
+END PROC central pageform routine;
+
+PROC pageform (TEXT CONST input, druck):
+ file works := FALSE;
+ central pageform routine (input, druck).
+END PROC pageform;
+
+PROC pageform (TEXT CONST input):
+ file works := FALSE;
+ central pageform routine (input, input + ".p").
+END PROC pageform;
+
+PROC pageform:
+ file works := FALSE;
+ pageform (last param)
+END PROC pageform;
+
+PROC pageform (TEXT CONST input, REAL CONST lf, seitenlaenge):
+ file works := TRUE;
+ eingestellte seitenlaenge := y step conversion (seitenlaenge);
+ real eingestellter zeilenvorschub := lf;
+ central pageform routine (input, input + ".p")
+END PROC pageform;
+
+PROC autopageform:
+ autopageform (last param)
+END PROC autopageform;
+
+PROC autopageform (TEXT CONST input):
+ command dialogue (false);
+ pageform (input);
+ command dialogue (true)
+END PROC autopageform;
+END PACKET seiten formatieren;
+(*
+REP
+ IF yes ("autopageform")
+ THEN autopageform ("pfehler")
+ ELSE pageform ("pfehler")
+ FI;
+ edit("pfehler.p");
+UNTIL yes ("ENDE") ENDREP;
+*)
+
diff --git a/system/multiuser/1.7.5/src/print cmd b/system/multiuser/1.7.5/src/print cmd
new file mode 100644
index 0000000..1fcb475
--- /dev/null
+++ b/system/multiuser/1.7.5/src/print cmd
@@ -0,0 +1,29 @@
+
+PACKET print cmd DEFINES print, printer :
+
+PROC print :
+
+ print (last param)
+
+ENDPROC print ;
+
+PROC print (TEXT CONST file name) :
+
+ save (file name, task ("PRINTER")) ;
+
+ENDPROC print ;
+
+PROC print (THESAURUS CONST nameset) :
+
+ do (PROC (TEXT CONST) print, nameset)
+
+ENDPROC print ;
+
+TASK PROC printer :
+
+ task ("PRINTER")
+
+ENDPROC printer ;
+
+ENDPACKET print cmd ;
+
diff --git a/system/multiuser/1.7.5/src/priv ops b/system/multiuser/1.7.5/src/priv ops
new file mode 100644
index 0000000..a92ee76
--- /dev/null
+++ b/system/multiuser/1.7.5/src/priv ops
@@ -0,0 +1,268 @@
+(* ------------------- VERSION 10 22.04.86 ------------------- *)
+PACKET privileged operations DEFINES (* Autor: J.Liedtke *)
+
+ block ,
+ calendar ,
+ collect garbage blocks ,
+ define collector ,
+ fixpoint ,
+ info password ,
+ prio ,
+ save system ,
+ send ,
+ set clock ,
+ set date ,
+ shutup ,
+ unblock :
+
+LET prio field = 6 ,
+ cr = ""13"" ,
+ archive channel = 31 ,
+
+ ack = 0 ,
+
+ garbage collect code = 1 ,
+ fixpoint code = 2 ,
+ shutup code = 4 ,
+ shutup and save code = 12 ,
+ reserve code = 19 ,
+ release code = 20 ;
+
+
+
+INT PROC prio (TASK CONST task) :
+ pcb (task, prio field)
+ENDPROC prio ;
+
+PROC prio (TASK CONST task, INT CONST new prio) :
+ pcb (task, prio field, new prio)
+ENDPROC prio ;
+
+TEXT VAR date text ;
+
+PROC collect garbage blocks :
+
+ system operation (garbage collect code)
+
+ENDPROC collect garbage blocks ;
+
+PROC fixpoint :
+
+ system operation (fixpoint code)
+
+ENDPROC fixpoint ;
+
+PROC info password (TEXT CONST old info password, new info password) :
+
+ INT VAR error code ;
+ IF online
+ THEN say (""3""5""10"")
+ FI ;
+ IF LENGTH new info password < 10
+ THEN infopw (old info password + cr, new info pw, error code) ;
+ IF error code = 0
+ THEN shutup
+ ELSE errorstop ("Falsches Info-Passwort")
+ FI
+ ELSE errorstop ("Passwort zu lang (max. 9 Zeichen)")
+ FI ;
+ cover tracks .
+
+new info pw :
+ IF new info password = "-"
+ THEN "-" + 9 * "0"
+ ELSE new info password + "cr"
+ FI .
+
+ENDPROC info password ;
+
+PROC shutup :
+
+ system operation (shutup code) ;
+ IF command dialogue
+ THEN wait for configurator ;
+ page ;
+ set date
+ FI
+
+ENDPROC shutup ;
+
+PROC save system :
+
+ INT VAR reply ;
+ TASK VAR channel owner ;
+ enable stop ;
+ reserve archive channel ;
+ IF yes ("Leere Floppy eingelegt")
+ THEN
+ reserve archive channel ;
+ system operation (shutup and save code) ;
+ release archive channel ;
+ IF command dialogue
+ THEN wait for configurator ;
+ page ;
+ set date
+ FI
+ FI ;
+ release archive channel .
+
+reserve archive channel :
+ channel owner := task (archive channel) ;
+ IF NOT is niltask (channel owner)
+ THEN ask channel owner to reserve the channel ;
+ IF channel owner does not reserve channel
+ THEN errorstop ("Task """ + name (channel owner)
+ + """ gibt Kanal "
+ + text (archive channel)
+ + " nicht frei")
+ FI
+ FI .
+
+ask channel owner to reserve the channel :
+ forget (ds) ;
+ ds := nilspace ;
+ pingpong (channel owner, reserve code, ds, reply) .
+
+channel owner does not reserve channel :
+ (reply <> ack) AND task exists .
+
+task exists :
+ reply <> -1 .
+
+release archive channel :
+ forget (ds) ;
+ ds := nilspace ;
+ pingpong (channel owner, release code, ds, reply) .
+
+ENDPROC save system ;
+
+PROC system operation (INT CONST code) :
+
+ INT VAR size, used ;
+ storage (size, used) ;
+ IF used <= size
+ THEN sys op (code)
+ ELSE errorstop ("Speicherengpass")
+ FI
+
+ENDPROC system operation ;
+
+DATASPACE VAR ds := nilspace ;
+
+PROC wait for configurator :
+
+ INT VAR i , receipt ;
+ FOR i FROM 1 UPTO 20 WHILE configurator exists REP
+ pause (30) ;
+ forget (ds) ;
+ ds := nilspace ;
+ ping pong (configurator, ack, ds, receipt)
+ UNTIL receipt >= 0 PER .
+
+configurator exists :
+ disable stop ;
+ TASK VAR configurator := task ("configurator") ;
+ clear error ;
+ NOT is niltask (configurator) .
+
+ENDPROC wait for configurator ;
+
+BOOL VAR hardware clock ok ;
+REAL VAR now ;
+
+PROC set date :
+
+ hardware clock ok := TRUE ;
+ try to get date and time from hardware ;
+ IF NOT hardware clock ok
+ THEN get date and time from user
+ FI ;
+ define date and time .
+
+try to get date and time from hardware :
+ disable stop ;
+ REAL VAR previous now ;
+ now := 0.0 ;
+ INT VAR try ;
+ FOR try FROM 1 UPTO 3 WHILE hardware clock ok REP
+ previous now := now ;
+ now := date (hardwares today) + time (hardwares time)
+ UNTIL now = previous now OR is error PER ;
+ clear error ;
+ enable stop .
+
+get date and time from user :
+ line (2) ;
+ put (" Bitte geben Sie das heutige Datum ein :") ;
+ date text := date ;
+ TEXT VAR exit char ;
+ editget (date text, cr, "", exit char) ;
+ now := date (date text) ;
+ line ;
+ put (" und die aktuelle Uhrzeit :") ;
+ date text := time of day ;
+ editget (date text, cr, "", exit char) ;
+ now INCR time (date text) ;
+ IF NOT last conversion ok
+ THEN errorstop ("Falsche Zeitangabe")
+ FI .
+
+hardwares today : calendar (3) + "." + calendar (4) + "." + calendar (5) .
+
+hardwares time : calendar (2) + ":" + calendar (1) .
+
+define date and time :
+ set clock (now) .
+
+ENDPROC set date ;
+
+TEXT PROC calendar (INT CONST index) :
+
+ INT VAR bcd ;
+ control (10, index, 0, bcd) ;
+ IF bcd < 0
+ THEN hardware clock ok := FALSE ; ""
+ ELSE text (low digit + 10 * high digit)
+ FI .
+
+low digit : bcd AND 15 .
+
+high digit: (bcd AND (15*256)) DIV 256 .
+
+ENDPROC calendar ;
+
+PROC infopw (TEXT CONST old, new, INT VAR error code) :
+ EXTERNAL 81
+ENDPROC infopw ;
+
+PROC sys op (INT CONST code) :
+ EXTERNAL 90
+ENDPROC sys op ;
+
+PROC set clock (REAL CONST time) :
+ EXTERNAL 103
+ENDPROC set clock ;
+
+PROC pcb (TASK CONST task, INT CONST field, value) :
+ EXTERNAL 105
+ENDPROC pcb ;
+
+PROC unblock (TASK CONST task) :
+ EXTERNAL 108
+ENDPROC unblock ;
+
+PROC block (TASK CONST task) :
+ EXTERNAL 109
+ENDPROC block ;
+
+PROC send (TASK CONST from, to, INT CONST order, DATASPACE VAR ds,
+ INT VAR receipt) :
+ EXTERNAL 127
+ENDPROC send ;
+
+PROC define collector (TASK CONST task) :
+ EXTERNAL 128
+ENDPROC define collector ;
+
+ENDPACKET privileged operations ;
+
diff --git a/system/multiuser/1.7.5/src/silbentrennung b/system/multiuser/1.7.5/src/silbentrennung
new file mode 100644
index 0000000..dfbdf75
--- /dev/null
+++ b/system/multiuser/1.7.5/src/silbentrennung
@@ -0,0 +1,1166 @@
+(* ------------------- VERSION 170 vom 30.09.85 -------------------- *)
+PACKET silbentrennung DEFINES
+ trenn,
+ schreibe trennvektor,
+ ist ausnahme wort,
+ lade ausnahmen,
+ entlade ausnahmen:
+
+(* Programm zur Silbentrennung
+ Autor: Klaus-Uwe Koschnick / Rainer Hahn
+ Stand: 1.7.1 (Febr. 1984)
+ 1.7.4 (Mai 1984) (Ausnahme-Woerterbuch, Verbesserungen)
+*)
+
+(*--------------------- Ausnahme Woerterbuch -----------------------*)
+
+DATASPACE VAR ds1 :: nilspace;
+
+FILE VAR f;
+
+LET name table length = 1024,
+ max hash chars = 5;
+
+INT VAR anz worte :: 0,
+ hash index;
+
+INITFLAG VAR this packet :: FALSE;
+
+TEXT VAR dummy,
+ name ohne trennstellen,
+ trennstellen,
+ blanked name;
+
+BOUND ROW name table length TEXT VAR name table;
+
+PROC init packet:
+ IF NOT initialized (this packet)
+ THEN anz worte := 0
+ FI
+END PROC init packet;
+
+PROC init name table:
+ forget (ds1);
+ ds1 := nilspace;
+ name table := ds1;
+ INT VAR i;
+ FOR i FROM 1 UPTO name table length REP
+ cout (i);
+ name table [i] := ""
+ END REP;
+ anz worte := 0.
+END PROC init name table;
+
+PROC lade ausnahmen:
+ lade ausnahmen (last param)
+END PROC lade ausnahmen;
+
+PROC lade ausnahmen (TEXT CONST filename):
+ IF exists (filename)
+ THEN lade
+ ELSE errorstop ("Datei nicht vorhanden")
+ FI.
+
+lade:
+ init packet;
+ IF anz worte > 0
+ THEN IF yes ("überschreiben")
+ THEN init nametable
+ ELIF no ("anfügen")
+ THEN LEAVE lade ausnahmen
+ FI
+ ELSE init nametable
+ FI;
+ line (2);
+ f := sequential file (input, file name);
+ WHILE NOT eof (f) REP
+ get (f, dummy);
+ IF subtext (dummy, 1, 2) = "(*"
+ THEN ueberlese kommentar
+ ELSE lade wort (* Vor.: Worte ohne Blanks *)
+ FI
+ END REP.
+
+ueberlese kommentar:
+ WHILE NOT eof (f) AND pos (dummy, "*)") = 0 REP
+ get (f, dummy);
+ END REP.
+
+lade wort:
+ line ;
+ anz worte INCR 1;
+ put (anz worte);
+ stelle namen ohne trennstellen her;
+ put (name ohne trennstellen);
+ blanked name := " ";
+ name ohne trennstellen CAT " ";
+ blanked name CAT name ohne trennstellen;
+ hash;
+ IF pos (name table [hash index], blanked name) > 0
+ THEN put ("(bereits geladen)")
+ ELSE insert char (name ohne trennstellen, " ", 1);
+ name ohne trennstellen CAT trennstellen;
+ name table [hash index] CAT name ohne trennstellen;
+ FI.
+
+stelle namen ohne trennstellen her:
+ INT VAR number;
+ name ohne trennstellen := dummy;
+ trennstellen := "";
+ WHILE pos (name ohne trennstellen, "-") > 0 REP
+ number := pos (name ohne trennstellen, "-");
+ delete char (name ohne trennstellen, number);
+ trennstellen CAT text (number - 1);
+ trennstellen CAT " "
+ END REP.
+END PROC lade ausnahmen;
+
+PROC entlade ausnahmen (TEXT CONST file name):
+ init packet;
+ IF exists (file name)
+ THEN errorstop ("Datei existiert bereits")
+ ELSE unload
+ FI.
+
+unload:
+ f := sequential file (output, file name);
+ INT VAR i;
+ FOR i FROM 1 UPTO name table length REP
+ cout (i);
+ IF name table [i] <> ""
+ THEN putline (f, name table [i])
+ FI
+ END REP.
+END PROC entlade ausnahmen;
+
+BOOL PROC ist ausnahme wort (TEXT CONST word,
+ INT CONST maximum, INT VAR trenn position):
+ init packet;
+ IF anz worte > 0
+ THEN blanked name fuer hash bilden;
+ hash;
+ IF pos (name table [hash index], blanked name) > 0
+ THEN trennstelle suchen
+ FI
+ FI;
+ FALSE.
+
+blanked name fuer hash bilden:
+ blanked name := " ";
+ IF maximum <= max hash chars
+ THEN eliminiere ggf satzzeichen hinter dem wort;
+ blanked name CAT
+ subtext (word, 1, min (max hash chars, wortlaenge))
+ ELSE blanked name CAT subtext (word, 1, maximum);
+ FI.
+
+eliminiere ggf satzzeichen hinter dem wort:
+ INT VAR wort laenge := length (word);
+ WHILE letztes zeichen ist kein buchstabe REP
+ wort laenge DECR 1;
+ IF wort laenge <= 2
+ THEN LEAVE ist ausnahme wort WITH FALSE
+ FI
+ END REP.
+
+letztes zeichen ist kein buchstabe:
+ TEXT CONST letztes zeichen :: (word SUB wortlaenge);
+ NOT (letztes zeichen >= "A" AND letztes zeichen <= "Z" OR
+ letztes zeichen >= "a" AND letztes zeichen <= "z" OR
+ letztes zeichen >= "Ä" AND letztes zeichen <= "k" OR
+ letztes zeichen = "ß").
+
+trennstelle suchen:
+ index der ersten ziffer suchen;
+ INT VAR neue ziffer := 0;
+ trenn position := 0;
+ ziffern holen.
+
+index der ersten ziffer suchen:
+ dummy := name table [hash index];
+ INT VAR ziffern index := pos (dummy, blanked name);
+ ziffern index := pos (dummy, " ", ziffern index + 1) + 1.
+
+ziffern holen:
+ WHILE ist ziffer REP
+ hole neue ziffer;
+ IF gefundene ziffer ist ausserhalb des trennbereichs
+ THEN LEAVE ist ausnahme wort WITH TRUE
+ FI;
+ trenn position := neue ziffer
+ END REP;
+ LEAVE ist ausnahme wort WITH TRUE.
+
+ist ziffer:
+ ziffern index < length (dummy) AND
+((dummy SUB ziffern index + 1) = " " OR (dummy SUB ziffern index + 2) = " ").
+
+hole neue ziffer:
+ INT VAR ende position :: pos (dummy, " ", ziffern index);
+ neue ziffer := int (subtext (dummy, ziffern index, ende position - 1));
+ ziffern index := ende position + 1.
+
+gefundene ziffer ist ausserhalb des trennbereichs:
+ neue ziffer > maximum.
+END PROC ist ausnahme wort;
+
+PROC hash:
+ INT VAR i;
+ hash index := code (blanked name SUB 2);
+ FOR i FROM 3 UPTO min (length (blanked name), max hash chars) REP
+ hash index INCR hash index;
+ hash index INCR code (blanked name SUB i);
+ decrementiere hash index
+ END REP.
+
+decrementiere hash index:
+ WHILE hash index > name table length REP
+ hash index DECR 1023
+ END REP.
+END PROC hash;
+
+(*-------------- eigentlicher Trenn-Algorithmus --------------*)
+
+LET zeichenkette n = "-/",
+ regelmaessig = " bl br chl chr dr fl fr gl gr kl kn kr pf ph pl pr
+ sp st schl schm schn schr schw th tr zw ",
+ vokal string = "aeiouyäöü",
+ buchstaben =
+ "abcdefghijklmnopqrstuvwxyzäöüßABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ",
+ grosse buchstaben = "ABCDEFGHIJKLMNOPQRSTUVWXYZ",
+ trennstrich = ""221"",
+ cv a = 97 , cv b = 98 , cv c = 99 , cv d = 100, cv e = 101,
+ cv f = 102, cv g = 103, cv i = 105, cv k = 107,
+ cv l = 108, cv m = 109, cv n = 110, cv o = 111,
+ cv p = 112, cv r = 114, cv s = 115, cv t = 116,
+ cv u = 117, cv w = 119, cv x = 120, cv y = 121,
+ cv ae = 217 , cv oe = 218 , cv ue = 219 , cv sz = 251,
+ weder h noch ch = 0 ,
+ buchstabe h = 1 ,
+ zeichenfolge ch = 2 ;
+
+INT CONST minus one :: - 1;
+
+INT VAR i, grenze, absolute grenze, sonderzeichen trennpos,
+ zeichen vor teilwort, teilwort laenge, a pos, e pos,
+ a pos minus 2, a pos minus 1, a pos plus 1, a pos plus 2,
+ e pos minus 1;
+
+ROW 50 INT VAR vektor ;
+
+TEXT VAR wort,
+ teilwort,
+ kons gr,
+ search,
+ zeichen;
+
+BOOL VAR trennstelle gefunden ;
+
+PROC trenn (TEXT CONST word, TEXT VAR part1, trennsymbol, INT CONST maximum):
+ IF ist ausnahme wort (word, maximum, position)
+ THEN ausnahme wort behandlung;
+ LEAVE trenn
+ FI;
+ INT VAR laenge :: length (word) ;
+ IF laenge < 4
+ THEN trennung nicht moeglich
+ ELSE wort := word ;
+ grenze := min (50, maximum) ;
+ absolute grenze := min (laenge, grenze + 5) ;
+ trennung versuchen
+ FI .
+
+ausnahme wort behandlung:
+ IF position <= 0
+ THEN trennung nicht moeglich
+ ELSE part1 := subtext (word, 1, position);
+ IF pos (zeichenkette n, word SUB position + 1) > 0
+ THEN trennsymbol := " "
+ ELSE trennsymbol := trennstrich
+ FI
+ FI.
+
+trennung nicht moeglich :
+ part 1 := "";
+ trennsymbol := " ".
+
+trennung versuchen :
+ erstelle trennvektor ;
+ IF sonderzeichen trennpos > 0
+ THEN part 1 := subtext (word, 1, sonderzeichen trennpos) ;
+ trennsymbol := " "
+ ELSE bestimme trennposition ;
+ IF position = 0
+ THEN trennung nicht moeglich
+ ELSE part 1 := subtext (wort, 1, position) ;
+ trennsymbol := trennstrich
+ FI
+ FI .
+
+bestimme trennposition :
+ INT VAR position ;
+ FOR position FROM grenze DOWNTO 1 REP
+ IF vektor [position] = 1
+ THEN LEAVE bestimme trennposition
+ FI
+ END REP ;
+ position := 0
+END PROC trenn ;
+
+BOOL PROC buchstabe (INT CONST posi) :
+ pos (buchstaben, wort SUB posi) > 0 OR spezialcode.
+
+spezialcode:
+ INT CONST z code :: code (wort SUB posi) ;
+ (zcode > 96 AND zcode < 123).
+END PROC buchstabe ;
+
+OP SPERRE (INT CONST element) :
+ INT CONST w element :: zeichen vor teilwort + element ;
+ IF w element > 0 AND w element <= grenze
+ THEN vektor [w element] := minus one
+ FI
+END OP SPERRE ;
+
+OP SETZE (INT CONST element) :
+ INT CONST w element :: zeichen vor teilwort + element;
+ IF w element > 0 AND w element <= grenze AND vektor [w element] <> minus one
+ THEN vektor [w element] := 1 ;
+ trennstelle gefunden := TRUE
+ FI
+END OP SETZE ;
+
+BOOL PROC vorletzter buchstabe oderkeine trennung oder sperre gesetzt
+ (INT CONST akt buchstabenpos):
+ vorletzter buchstabe (akt buchstabenpos)
+ OR NOT trennung oder sperre gesetzt (akt buchstabenpos).
+END PROC vorletzter buchstabe oderkeine trennung oder sperre gesetzt;
+
+BOOL PROC vorletzter buchstabe (INT CONST akt buchstabenpos):
+ akt buchstabenpos = absolute grenze - 1
+END PROC vorletzter buchstabe;
+
+BOOL PROC trennung oder sperre gesetzt (INT CONST element):
+ INT CONST w element :: zeichen vor teilwort + element;
+ IF w element > 1 AND w element < teilwort laenge
+ THEN vektor [w element] = 1 OR gesperrt
+ ELSE TRUE
+ FI.
+
+gesperrt:
+ IF w element >= length (wort) - 1
+ THEN TRUE
+ ELSE vektor [w element] = minus one
+ FI.
+END PROC trennung oder sperre gesetzt;
+
+PROC sperren und setzen (INT CONST element) :
+ INT CONST w element :: zeichen vor teilwort + element ;
+ vektor [w element - 1] := minus one;
+ vektor [w element] := 1
+END PROC sperren und setzen ;
+
+TEXT PROC string (INT CONST anf pos, end pos) :
+ subtext (teilwort, maximum, minimum).
+
+maximum:
+ IF anf pos > 1
+ THEN anf pos
+ ELSE 1
+ FI.
+
+minimum:
+ IF teilwort laenge < end pos
+ THEN teilwort laenge
+ ELSE end pos
+ FI.
+END PROC string ;
+
+BOOL PROC silbenanfang vor (INT CONST akt buchstabenpos):
+ zwei silber (akt buchstabenpos - 2) OR drei silber (akt buchstabenpos - 3)
+END PROC silbenanfang vor;
+
+BOOL PROC silbenanfang nach (INT CONST akt buchstabenpos):
+ zwei silber (akt buchstabenpos + 1) OR drei silber (akt buchstabenpos + 1)
+END PROC silbenanfang nach;
+
+BOOL PROC zwei silber (INT CONST akt buchstabenpos):
+ TEXT VAR zweier :: string (akt buchstabenpos, akt buchstabenpos + 1);
+ length (zweier) = 2 AND
+ pos ("ab an ar be er ge in um un zu re", zweier) > 0
+END PROC zwei silber;
+
+BOOL PROC drei silber (INT CONST akt buchstabenpos):
+ TEXT VAR dreier :: string (akt buchstabenpos, akt buchstabenpos + 2);
+ length (dreier) = 3 AND
+ pos ("auf aus bei ein end ent mit", dreier) > 0
+END PROC drei silber;
+
+BOOL PROC reg (INT CONST st pos) :
+ INT CONST code one :: code (teilwort SUB st pos) ,
+ code two :: code (teilwort SUB st pos + 1) ;
+ pos (regelmaessig, konsonanten) > 0 .
+
+konsonanten :
+ search := " " ;
+ IF code one = cv c
+ THEN search CAT string (st pos, st pos + 2)
+ ELIF code one = cv s AND code two = cv c
+ THEN search CAT string (st pos, st pos + 3)
+ ELSE search CAT string (st pos, st pos + 1)
+ FI ;
+ search CAT " " ;
+ search
+END PROC reg ;
+
+INT PROC grenz position (INT CONST start pos, richtung):
+ INT VAR posit :: start pos ;
+ REP
+ posit INCR richtung
+ UNTIL sonderzeichen oder position unzulaessig END REP;
+ posit - richtung.
+
+sonderzeichen oder position unzulaessig:
+ posit = 0 AND posit > absolute grenze OR ist kein buchstabe.
+
+ist kein buchstabe:
+ pos (buchstaben, wort SUB posit) = 0 AND kein spezialcode.
+
+kein spezialcode:
+ INT CONST z code :: code (wort SUB posit) ;
+ (zcode < 97 OR zcode > 121).
+END PROC grenz position ;
+
+PROC schreibe trennvektor (TEXT CONST ttt):
+line ; put (ttt); INT VAR ii;
+FOR ii FROM 1 UPTO length (wort) REP put(vektor [ii]) PER
+END PROC schreibe trennvektor;
+
+PROC erstelle trennvektor :
+INT VAR akt pos, anfang teilwort, ende teilwort, anzahl,
+ zuletzt, tr pos, ind, code 1, code 2, code 3,
+ rechts von a pos, z code, posit;
+BOOL VAR sonderzeichen modus,
+ aktueller buchstabe ist vokal,
+ vorsilbe oder nachsilbe;
+
+ sonderzeichen trennpos := 0 ;
+ trennstelle gefunden := FALSE ;
+ initialisiere trennvektor ;
+ akt pos := grenze ;
+ IF buchstabe (akt pos)
+ THEN zuerst teilwort
+ ELSE zuerst sonderzeichenblock
+ FI;
+ WHILE akt pos > 0 REP
+ IF sonderzeichen modus
+ THEN behandle sonderzeichenblock
+ ELSE suche trennstellen in teilwort
+ FI
+ END REP.
+
+initialisiere trennvektor :
+ FOR i FROM 1 UPTO grenze REP vektor [i] := 0 END REP .
+
+zuerst teilwort:
+ ende teilwort := grenz position (akt pos, 1) ;
+ sonderzeichen modus := FALSE .
+
+zuerst sonderzeichenblock:
+ sonderzeichen modus := TRUE .
+
+behandle sonderzeichenblock:
+ WHILE sonderzeichen modus REP
+ IF buchstabe (akt pos)
+ THEN sonderzeichen modus := FALSE
+ ELSE zeichen := wort SUB akt pos ;
+ IF pos (zeichenkette n, zeichen) <> 0
+ THEN sonderzeichen trennpos := akt pos ;
+ LEAVE erstelle trennvektor
+ FI ;
+ akt pos DECR 1 ;
+ IF akt pos = 0
+ THEN LEAVE erstelle trennvektor
+ FI
+ FI
+ END REP;
+ ende teilwort := akt pos .
+
+suche trennstellen in teilwort:
+ bestimme anfang von teilwort ;
+ IF teilwort lang genug
+ THEN teilwort ausbauen und wandeln ;
+ SPERRE 1 ; SPERRE (teilwort laenge - 1) ;
+ vorsilben untersuchen ;
+ nachsilben untersuchen ;
+ vorsilbe oder nachsilbe := trennstelle gefunden ;
+ trennstelle gefunden := FALSE ;
+ weitere trennstellen suchen ;
+ IF vorsilbe oder nachsilbe
+ THEN LEAVE erstelle trennvektor
+ FI
+ FI ;
+ akt pos := anfang teilwort - 1 ;
+ sonderzeichen modus := TRUE .
+
+bestimme anfang von teilwort:
+ anfang teilwort := grenz position (ende teilwort, minus one) .
+
+teilwort lang genug:
+ teilwort laenge := ende teilwort - anfang teilwort + 1 ;
+ teilwort laenge > 3 .
+
+teilwort ausbauen und wandeln:
+ teilwort := subtext (wort, anfang teilwort, ende teilwort);
+ zeichen vor teilwort := anfang teilwort - 1 ;
+ IF pos (grosse buchstaben, teilwort SUB 1) > 0
+ THEN replace (teilwort, 1, code (code (teilwort SUB 1) + 32))
+ FI .
+ (* Es ist nicht notwendig, gross geschriebene Umlaute am
+ Wortanfang zu wandeln! *)
+
+weitere trennstellen suchen:
+ e pos := teilwort laenge ;
+ aktueller buchstabe ist vokal := letzter buchstabe ist vokal ;
+ WHILE e pos > 1 REP
+ anzahl := 0 ;
+ a pos := e pos ;
+ IF aktueller buchstabe ist vokal
+ THEN behandle vokalgruppe
+ ELSE behandle konsonantengruppe
+ FI ;
+ IF trennstelle gefunden
+ THEN LEAVE erstelle trennvektor
+ FI ;
+ e pos := a pos - 1 ;
+ END REP .
+
+letzter buchstabe ist vokal:
+ pos (vokal string,teilwort SUB e pos) > 0 .
+
+behandle vokalgruppe:
+ vokalgruppe lokalisieren ;
+ IF a pos > 1 AND e pos < teilwort laenge
+ THEN a pos plus 1 := a pos + 1 ;
+ a pos plus 2 := a pos + 2 ;
+ IF anzahl = 2
+ THEN vokal 2
+ ELIF anzahl > 2
+ THEN vokal 3
+ ELSE vokal 1
+ FI
+ FI .
+
+vokalgruppe lokalisieren:
+ zuletzt := 0 ;
+ WHILE aktueller buchstabe ist vokal REP
+ zeichen := teilwort SUB a pos ;
+ IF pos (vokal string,zeichen) > 0
+ THEN z code := code(zeichen) ;
+ IF zuletzt <> cv e
+ OR (z code <> cv a AND z code <> cv o AND z code <> cv u)
+ THEN anzahl INCR 1
+ FI ;
+ IF a pos > 1
+ THEN a pos DECR 1 ;
+ zuletzt := z code
+ ELSE aktueller buchstabe ist vokal := FALSE
+ FI
+ ELSE a pos INCR 1 ;
+ aktueller buchstabe ist vokal := FALSE
+ FI
+ END REP .
+
+behandle konsonantengruppe:
+ konsonantengruppe lokalisieren ;
+ IF a pos > 1 AND e pos < teilwort laenge
+ THEN a pos minus 2 := a pos - 2 ;
+ a pos minus 1 := a pos - 1 ;
+ a pos plus 1 := a pos + 1 ;
+ a pos plus 2 := a pos + 2 ;
+ e pos minus 1 := e pos - 1 ;
+ SELECT anzahl OF
+ CASE 1 : konsonant 1
+ CASE 2 : konsonant 2
+ OTHERWISE : konsonant 3
+ END SELECT
+ FI .
+
+konsonantengruppe lokalisieren:
+ rechts von a pos := weder h noch ch ;
+ REP
+ zeichen := teilwort SUB a pos ;
+ IF pos (vokal string, zeichen) = 0
+ THEN anzahl INCR 1 ;
+ IF zeichen = "h"
+ THEN rechts von a pos := buchstabe h
+ ELIF zeichen = "c" AND rechts von a pos = buchstabe h
+ THEN anzahl DECR 1 ;
+ rechts von a pos := zeichenfolge ch
+ ELIF zeichen = "s" AND rechts von a pos = zeichenfolge ch
+ THEN anzahl DECR 1 ;
+ rechts von a pos := weder h noch ch
+ ELSE rechts von a pos := weder h noch ch
+ FI ;
+ IF a pos > 1
+ THEN a pos DECR 1
+ ELSE aktueller buchstabe ist vokal := TRUE
+ FI
+ ELSE a pos INCR 1 ;
+ aktueller buchstabe ist vokal := TRUE
+ FI
+ UNTIL aktueller buchstabe ist vokal END REP .
+
+vorsilben untersuchen:
+ code 2 := code (teilwort SUB 2);
+ code 3 := code (teilwort SUB 3);
+ IF ch vierer silbe
+ THEN sperren und setzen (4)
+ ELSE restliche vorsilben
+ FI.
+
+ch vierer silbe:
+ string (2, 4) = "ach" OR string (2, 4) = "och" OR string (2, 4) = "uch".
+
+restliche vorsilben:
+ ind := pos ("abdefghimnrstuvwüu", teilwort SUB 1);
+SELECT ind OF
+CASE1(*a*): IF drei silber (1)
+ THEN sperren und setzen (3)
+ ELIF code 2 = cv b (*ab*)
+ THEN IF string(3,5) = "end" (*abend*)
+ THEN SPERRE 2; sperren und setzen (5)
+ ELIF string(3,4) = "er" (*aber*)
+ THEN sperren und setzen (4)
+ ELSE sperren und setzen (2)
+ FI
+ ELIF code 2 = cv n AND string(3,5) <> "alo" (*analo*)
+ THEN SETZE 2
+ FI
+CASE2(*b*): IF code 2 = cv e (* be *)
+ THEN IF (teilwort SUB 3) = "h" (* be-handeln usw *)
+ OR (teilwort SUB 3) = "a" (* beamter *)
+ THEN sperren und setzen (2)
+ ELIF string (3, 4) = "ob" (* beobachten *)
+ THEN SETZE 2; sperren und setzen (4)
+ FI
+ ELIF string (2, 3) = "au" (* bauer usw *)
+ THEN sperren und setzen (3)
+ FI
+CASE3(*d*): IF (code 3 = cv s AND (code 2 = cv i OR code 2 = cv e))
+ OR string (2, 3) = "ar" (* dis, des, dar*)
+ THEN sperren und setzen (3)
+ ELIF string (2, 4) = "enk" (* denk.. *)
+ THEN sperren und setzen (4)
+ ELIF string(2,5) = "urch" (*durch*)
+ THEN SPERRE 3 ; SETZE 5
+ FI
+CASE4(*e*): IF code 2 = cv r AND code 3 <> cv n AND code 3 <> cv d
+ AND string (3, 4) <> "ro" (* er, aber nicht: ern, erd, erro *)
+ THEN SETZE 2
+ ELIF code 2 = cv x (* ex *)
+ THEN SETZE 2
+ ELIF (code 2 = cv m AND code 3 = cv p AND (teilwort SUB 4) = "f")
+ OR (code 2 = cv n AND code 3 = cv t) (* empf, ent *)
+ THEN sperren und setzen (3)
+ FI
+CASE5(*f*):
+CASE6(*g*): IF string (2, 5) = "egen" (* gegen *)
+ THEN sperren und setzen (5)
+ ELIF string (2, 6) = "leich" (* gleich *)
+ THEN IF vorletzter buchstabe (5)
+ THEN SPERRE 6
+ ELIF vorletzter buchstabe (6)
+ THEN sperren und setzen (4)
+ ELSE sperren und setzen (6)
+ FI
+ ELIF zwei silber (1)
+ THEN SETZE 2
+ FI
+CASE7(*h*): IF string (2, 3) = "in" OR string (2, 3) = "er" (* hin, her *)
+ THEN sperren und setzen (3)
+ FI
+CASE8(*i*): IF code 2 = cv n (* in *)
+ THEN IF string (3, 5) = "ter" (* inter *)
+ THEN sperren und setzen (5)
+ ELIF subtext (teilwort, 1, 5) = "insbe"
+ THEN sperren und setzen (3)
+ ELSE sperren und setzen (2)
+ FI;
+ FI
+CASE9(*m*): IF string (2, 3) = "ög" AND teilwort laenge > 5 (* mög *)
+ THEN sperren und setzen (3);
+ FI
+CASE10(*n*): IF string (2, 4) = "ach" AND teilwort laenge >= 7
+ AND (teilwort SUB 5) <> "t" (* nach, aber nicht: nacht *)
+ THEN SETZE 4
+ ELIF string (2, 6) = "ieder" (* nieder *)
+ THEN sperren und setzen (6)
+ ELIF string (2, 5) = "icht" (* nicht *)
+ THEN sperren und setzen (5)
+ ELIF string (2, 3) = "eu" (* neu *)
+ THEN sperren und setzen (3);
+ IF dreisilber (4)
+ THEN sperren und setzen (6)
+ FI
+ ELIF string (2, 5) = "iste"
+ THEN sperren und setzen (2)
+ FI
+CASE11(*r*): IF code 2 = cv e (* re *)
+ THEN IF silbenanfang nach (4) (* Realeinkommen *)
+ THEN sperren und setzen (4)
+ ELSE sperren und setzen (2)
+ FI
+ FI
+CASE12(*s*): IF string (2, 6) = "elbst" (* selbst *)
+ THEN sperren und setzen (6); SPERRE 4
+ FI
+CASE13(*t*): IF string (2, 3) = "at" (* tat *)
+ THEN sperren und setzen (3)
+ ELIF string (2, 5) = "rans" (* trans *)
+ THEN sperren und setzen (5)
+ ELIF string (2, 4) = "heo" (* theo *)
+ THEN sperren und setzen (4)
+ FI
+CASE14(*u*): IF code 2 = cv m (* um *)
+ THEN SETZE 2
+ ELIF code 2 = cv n (* un *)
+ THEN IF code 3 = cv i (* uni *)
+ THEN sperren und setzen (3)
+ ELSE sperren und setzen (2);
+ IF string (3, 5) = "ter" (* unter *)
+ THEN sperren und setzen (5)
+ FI
+ FI
+ FI
+CASE15(*v*): IF string (2, 3) = "or" OR string (2, 3) = "on" OR
+ string (2, 3) = "er" (* vor, von, ver *)
+ THEN sperren und setzen (3)
+ FI
+CASE16(*w*): IF code 2 = cv e AND code 3 = cv g (* weg *)
+ THEN sperren und setzen (3)
+ ELIF code 2 = cv i (* wi *)
+ THEN IF string(3,5) = "der" (* wider *)
+ THEN sperren und setzen (5)
+ ELIF string(3,6) = "eder" (* weder *)
+ THEN sperren und setzen (6)
+ FI
+ FI
+CASE17(*ü*): IF string (2, 4) = "ber" (* über *)
+ THEN sperren und setzen (4)
+ FI
+CASE18(*z*): IF code 2 = cv u (*zu*)
+ THEN sperren und setzen (2);
+ IF drei silber (3) (* zuein *)
+ THEN sperren und setzen (5)
+ FI
+ FI
+END SELECT.
+
+nachsilben untersuchen:
+ IF (teilwort SUB teilwort laenge) = "t"
+ THEN IF (string (teilwort laenge - 3,teilwort laenge) = "heit"
+ AND (teilwort SUB teilwort laenge - 4) <> "c")
+ OR string (teilwort laenge - 3, teilwort laenge -1) = "kei"
+ THEN sperren und setzen (teilwort laenge - 4)
+ FI
+ ELIF string (teilwort laenge - 2, teilwort laenge) = "tag"
+ THEN sperren und setzen (teilwort laenge - 3)
+ ELIF string (teilwort laenge - 3, teilwort laenge) = "tags"
+ THEN sperren und setzen (teilwort laenge - 4)
+ FI.
+
+vokal 1:
+ IF string (a pos, a pos plus 2) = "uel"
+ THEN SETZE a pos
+ FI.
+
+vokal 2 :
+ ind := pos (vokal string, teilwort SUB a pos);
+ code 2 := code (teilwort SUB a pos plus 1);
+SELECT ind OF
+CASE1(*a*): IF code 2 = cv a OR code 2 = cv i OR code 2 = cv y (*aa,ai,ay*)
+ THEN
+ ELIF code 2 = cv u
+ THEN silbe au behandlung
+ ELSE SETZE a pos
+ FI
+CASE2(*e*): IF code 2 = cv u AND (teilwort SUB a pos plus 2) = "e" (*eue*)
+ THEN SETZE a pos plus 1
+ ELIF code 2 = cv o OR code 2 = cv ae OR code 2 = cv ue
+ OR code 2 = cv oe (*eo, eä, eü, eö *)
+ THEN SETZE a pos
+ FI
+CASE3(*i*): IF code 2 <> cv e AND code 2 <> cv o (* i, aber nicht: ie, io *)
+ THEN SETZE a pos
+ FI
+CASE4(*o*): IF code 2 = cv o OR code 2 = cv u (* oo, ou *)
+ THEN
+ ELIF code 2 = cv e (* oe *)
+ THEN SETZE a pos plus 1
+ ELSE SETZE a pos
+ FI
+CASE5(*u*): IF (teilwort SUB a pos - 1) = "q" (* qu *)
+ THEN
+ ELIF code 2 = cv e (* ue *)
+ THEN SETZE a pos plus 1
+ ELSE SETZE a pos
+ FI
+CASE7(*y*): IF code 2 <> cv u (* yu *)
+ THEN SETZE a pos
+ FI
+OTHERWISE (*äöü*): SETZE a pos
+END SELECT.
+
+silbe au behandlung:
+ IF (teilwort SUB a pos + 2) = "e" (* aue, wie in dau-ernd *)
+ THEN SETZE a pos plus 1
+ ELIF a pos > 2 AND trennung oder sperre gesetzt (a pos + 2) AND
+ ((teilwort SUB a pos + 2) = "f" OR (teilwort SUB a pos + 2) = "s")
+ (* aus- oder auf-Mittelsilben *)
+ THEN SETZE (a pos - 1)
+ FI.
+
+vokal 3 :
+ IF string (a pos, a pos plus 2) <> "eau"
+ AND string (a pos plus 1, a pos+3) <> "eau"
+ THEN IF e pos - a pos = anzahl - 1
+ THEN SETZE a pos plus 1
+ ELSE code 1 := code(teilwort SUB a pos) ;
+ tr pos := a pos plus 1 ;
+ IF (code 1 = cv a OR code 1 = cv o OR code 1 = cv u)
+ AND (teilwort SUB a pos plus 1) = "e"
+ THEN tr pos INCR 1
+ FI;
+ code 2 := code (teilwort SUB tr pos) ;
+ IF (code 2 = cv a OR code 2 = cv o OR code 2 = cv u)
+ AND (teilwort SUB tr pos + 1) = "e"
+ THEN tr pos INCR 1
+ FI ;
+ SETZE tr pos
+ FI
+ FI .
+
+konsonant 1 :
+ ind := pos ("bcklmnrstß", teilwort SUB a pos);
+SELECT ind OF
+CASE1(*b*): IF string (a pos minus 1, a pos plus 2) = "über"
+ THEN SETZE a pos minus 2
+ ELIF silbenanfang nach (a pos)
+ AND NOT trennung oder sperre gesetzt (a pos minus 1)
+ THEN SETZE a pos
+ ELIF vorletzter buchstabe oderkeine trennung oder sperre gesetzt
+ (a pos)
+ THEN SETZE a pos minus 1
+ FI;
+CASE2(* c oder ch *):
+ IF ((teilwort SUB a pos plus 1) = "h"
+ AND (silbenanfang nach (a pos plus 1)
+ OR string (a pos, a pos + 3) = "chen"))
+ OR (teilwort SUB a pos plus 1) <> "h"
+ THEN SETZE a pos minus 1
+ ELSE SETZE a pos plus 1
+ FI
+CASE3(*k*): IF string (a pos minus 2, a pos minus 1) = "ti" (* tik *)
+ AND silbenanfang nach (a pos)
+ THEN SETZE a pos
+ ELSE SETZE a pos minus 1
+ FI
+CASE4(*l*): IF string (a pos - 3, a pos plus 1) = "reali"
+ THEN SETZE a pos plus 1
+ ELIF string (a pos minus 1, a pos plus 1) = "aly"
+ THEN SETZE a pos minus 1
+ ELIF string (a pos minus 2, a pos minus 1) = "ta" (*..tal..*)
+ OR string (a pos minus 2, a pos minus 1) = "na" (*..nal..*)
+ OR string (a pos minus 2, a pos minus 1) = "ia" (*..ial..*)
+ THEN SETZE a pos
+ ELSE SETZE a pos minus 1
+ FI
+CASE5(*m*): IF string (a pos minus 2, a pos minus 1) = "to" (* ..tom..*)
+ THEN SETZE a pos
+ ELSE SETZE a pos minus 1
+ FI
+CASE6(*n*): IF string (a pos - 4, a pos minus 1) = "gege"
+ OR string (a pos - 4, a pos minus 1) = "nebe" (*gegen, neben*)
+ THEN SETZE (a pos - 3) ; SETZE a pos
+ ELIF string (a pos minus 1, a pos plus 1) = "ini"
+ THEN
+ ELIF NOT silbenanfang vor (a pos)
+ AND ((teilwort SUB a pos minus 1) = "e" (* en *)
+ OR (teilwort SUB a pos minus 1) = "u") (* un *)
+ AND (silbenanfang nach (a pos)
+ OR string (a pos plus 1, a pos plus 2) = "ob")
+ THEN SETZE a pos
+ ELIF string (a pos minus 2, a pos plus 1) = "eina"
+ THEN SETZE a pos
+ ELSE SETZE a pos minus 1
+ FI
+CASE7(*r*): IF string (a pos minus 2, a pos minus 1) = "tu" (*..tur..*)
+ THEN IF string (a pos plus 1, a pos plus 2) = "el"
+ OR (string (a pos plus 1, a pos plus 2) = "en"
+ AND string (a pos minus 1, apos +3) <> "ent")
+ (* turel OR <>turentwick*)
+ THEN SETZE a pos minus 1
+ ELSE SETZE a pos
+ FI
+ ELIF string (a pos minus 2, a pos minus 1) = "ve" (*..ver..*)
+ OR string (a pos minus 2, a pos minus 1) = "vo" (*..vor..*)
+ THEN SETZE a pos
+ ELIF string (a pos minus 2, a pos minus 1) = "te" (* ter *)
+ THEN IF dreisilber (a pos plus 1)
+ OR string (a pos plus 1, a pos plus 1) = "a" (*tera*)
+ OR string (a pos - 3, a pos minus 2) <> "zt" (*zter*)
+ THEN SETZE a pos
+ ELSE SETZE a pos minus 1
+ FI
+ ELIF (teilwort SUB a pos minus 1) = "e" (* er*)
+ AND silbenanfang nach (a pos)
+ AND string (a pos plus 1, a pos + 3) <> "ung" (*erung*)
+ AND string (a pos plus 1, a pos plus 2) <> "er" (*erer*)
+ THEN SETZE a pos
+ ELIF vorletzter buchstabe oderkeine trennung oder sperre gesetzt
+ (a pos)
+ THEN SETZE a pos minus 1
+ FI
+CASE8(*s*): IF string (a pos minus 2, a pos minus 1) = "de" (* des *)
+ OR string (a pos minus 2, a pos minus 1) = "xi" (* ..xis *)
+ THEN SETZE a pos
+ ELIF string (a pos minus 2, a pos minus 1) = "ni" (* nis *)
+ AND silbenanfang nach (a pos)
+ THEN SETZE a pos
+ ELIF vorletzter buchstabe oderkeine trennung oder sperre gesetzt
+ (a pos)
+ THEN SETZE apos minus 1
+ FI
+CASE9(*t*): IF string (a pos plus 1, a pos + 3) = "ion" (* tion *)
+ THEN SETZE a pos minus 1
+ ELIF string (a pos plus 1, a pos + 3) <> "ier" (* imitieren *)
+ AND (string (a pos minus 2, a pos minus 1) = "mi"(*...mit..*)
+ OR string (a pos minus 2, a pos minus 1) = "va"(*privat..*)
+ OR string (a pos minus 2, a pos minus 1) = "fi"(*profit..*)
+ OR string (a pos - 3, a pos minus 1) = "zei")(*..zeit..*)
+ THEN SETZE a pos
+ ELSE SETZE a pos minus 1
+ FI
+CASE10(*ß*): IF string (a pos, a pos plus 2) = "ßen"
+ OR vorletzter buchstabe (a pos)
+ THEN SETZE a pos minus 1
+ ELSE SETZE a pos
+ FI
+OTHERWISE: IF vorletzter buchstabe oderkeine trennung oder sperre gesetzt
+ (a pos)
+ THEN SETZE a pos minus 1
+ FI
+END SELECT.
+
+konsonant 2 :
+ kons gr := string (a pos, e pos);
+ IF a pos > 2 AND trennung oder sperre gesetzt (a pos minus 1)
+ THEN
+ ELIF ausnahme fuer zwei konsonanten
+ THEN SETZE a pos
+ ELIF kons gr = "ts"
+ THEN IF NOT trennung oder sperre gesetzt (a pos)
+ (* für <> Tatsache, tatsächlich *)
+ THEN SETZE e pos
+ FI
+ ELIF kons gr = "tz"
+ THEN IF (teilwort SUB a pos plus 2) = "e" (* ..tze.. *)
+ OR (teilwort SUB a pos plus 2) = "u" (* ..tzu.. *)
+ THEN SETZE a pos
+ ELSE SETZE a pos plus 1
+ FI
+ ELIF string (a pos, a pos plus 1) = "ch"(* ch zaehlt als 1 Buchstabe *)
+ THEN SETZE a pos plus 1 (* darum keine Abfrage mit kons gr *)
+ ELIF (kons gr = "dt" OR kons gr = "kt")
+ AND silbenanfang nach (e pos)
+ THEN SETZE e pos
+ ELIF kons gr = "ns" AND
+ (string (a pos - 2, a pos - 1) = "io" (* ..ions *)
+ OR (string (a pos minus 1, a pos) ="en" (*..ens..*)
+ AND (teilwort SUB a pos minus 2) <> "t")) (* aber nicht ..tensiv*)
+ THEN SETZE e pos
+ ELIF string (a pos minus 2, a pos plus 1) = "nach"
+ THEN IF (teilwort SUB a pos plus 2) <> "t"
+ THEN SETZE a pos plus 1
+ FI
+ ELIF string (e pos, e pos + 3) = "lich"
+ THEN IF string (a pos minus 2, a pos) = "mög"
+ THEN SETZE a pos
+ ELIF pos ("hg", teilwort SUB e pos minus 1) > 0
+ THEN SPERRE e pos minus 1
+ ELSE SETZE e pos minus 1
+ FI;
+ ELIF (reg (a pos) AND NOT trennung oder sperre gesetzt (a pos))
+ OR (kons gr = "sp" AND silbenanfang vor (a pos))
+ THEN SETZE a pos minus 1
+ ELIF string (a pos, a pos plus 2) = "sch"
+ THEN SETZE a pos plus 2
+ ELSE SETZE a pos
+ FI.
+
+ausnahme fuer zwei konsonanten:
+ string (a pos minus 2, a pos) = "nis" AND a pos > 1
+ (*..nis.., aber nicht nisten *)
+ OR string (a pos minus 2, a pos plus 1) = "rafr" (* strafrecht *)
+ OR string (a pos - 4, a pos) = "undes" (* Bundes *)
+ OR string (a pos minus 1, a pos + 3) = "unter"
+ OR silbenanfang vor (e pos).
+
+konsonant 3 :
+ code 1 := code (teilwort SUB a pos);
+ code 2 := code (teilwort SUB a pos plus 1);
+ code 3 := code (teilwort SUB a pos plus 2);
+ IF NOT (ausnahme 1 OR ausnahme 2 OR ausnahme 3 OR ausnahme 4)
+ THEN suche regelmaessige konsonantenverbindung
+ FI.
+
+ausnahme 1 :
+ ind := pos ("cfgklnprt", code (code 1));
+ SELECT ind OF
+CASE1(*c*): IF code 2 = cv k (* ck *)
+ THEN SETZE a pos plus 1
+ ELIF string (a pos, a pos + 3) = "chts"
+ (* Rechts.., Gesichts.., .. machts..*)
+ THEN SETZE (a pos + 3)
+ ELIF string (a pos plus 1, a pos + 5) = "hstag" (* Reichstag *)
+ OR (string (a pos, a pos plus 2) = "chs" AND (* ..chs.. *)
+ string (a pos plus 2, a pos +3) <> "st")
+ THEN SETZE a pos plus 2
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+CASE2(*f*): IF code 2 = cv f (*ff*)
+ THEN IF code 3 = cv s
+ THEN SETZE a pos plus 2 (* ffs *)
+ ELSE SETZE a pos plus 1
+ FI
+ ELIF string (a pos minus 1, a pos plus 1) = "aft" (*..aft..*)
+ THEN IF (teilwort SUB a pos plus 2) = "s"
+ THEN SETZE a pos plus 2
+ ELSE SETZE a pos plus 1
+ FI
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+CASE3(*g*): IF string (a pos minus 2, a pos minus 1) = "ag" (* ags *)
+ THEN SETZE a pos plus 1
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+CASE4(*k*): IF string (a pos, a pos plus 1) = "kt"
+ AND silbenanfang nach (a pos plus 1)
+ THEN SETZE a pos plus 1
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+CASE5(*l*): IF code 2 = cv d OR code 2 = cv g OR code 2 = cv k (*ld, lg, lk*)
+ THEN SETZE a pos plus 1
+ ELIF string (a pos, a pos + 4) = "ltspr" (* Anwaltsprogramm *)
+ THEN SETZE (a pos + 2)
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+CASE6(*n*): IF string (a pos - 2, a pos) = "ein"
+ THEN SETZE a pos
+ ELIF code 2 = cv d (* nd *)
+ THEN IF code 3 = cv s (* nds, wie in ...stands... *)
+ THEN SETZE a pos plus 2
+ ELSE SETZE a pos plus 1
+ FI
+ ELIF code 2 = cv g (* ng *)
+ THEN IF code 3 = cv s (* ..ngs.. *)
+ THEN SETZE a pos plus 2
+ ELIF code 3 = cv r (* ..ngr.. *)
+ THEN SETZE a pos
+ ELIF code 3 = cv l (* ungleich *)
+ THEN
+ ELSE SETZE a pos plus 1
+ FI
+ ELIF string (a pos - 3, a pos plus 1) = "trans"
+ OR string (a pos - 3, a pos plus 1) = "tions" (*tionsplan*)
+ THEN SETZE a pos plus 1
+ ELIF string (a pos plus 1, a pos + 6) = "ftsper" (*ftsperspek*)
+ THEN SETZE (a pos + 3)
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+CASE7(*p*): IF code 2 = cv p (* pp *)
+ OR (code 2 = cv f AND code 3 = cv t) (* pft *)
+ THEN SETZE a pos plus 1; TRUE
+ ELSE FALSE
+ FI
+CASE8(*r*): IF string (a pos plus 1, a pos + 4) = "tner" (* rtner *)
+ THEN SETZE a pos plus 1
+ ELIF trennung oder sperre gesetzt (a pos)
+ THEN
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+CASE9(*t*): IF string (a pos plus 1, a pos plus 2) = "st" (*tst*)
+ THEN SETZE a pos
+ ELIF string (a pos plus 1, a pos plus 2) = "zt"
+ (* letzt.. *)
+ THEN IF (teilwort SUB a pos + 3) = "e" (*letzte..*)
+ THEN SETZE a pos plus 1
+ ELSE SETZE a pos plus 2
+ FI
+ ELIF string (apos - 2, a pos plus 1) = "eits"
+ (* ..heits.., ..keits.., ..beits.. *)
+ OR string (a pos plus 1, a pos plus 1)= "z" (*tz*)
+ THEN SETZE a pos plus 1
+ ELSE LEAVE ausnahme 1 WITH FALSE
+ FI;
+ TRUE
+OTHERWISE: FALSE
+END SELECT.
+
+ausnahme 2 :
+ IF e pos - a pos = 2
+ THEN FALSE
+ ELIF code 2 = cv p AND string (a pos plus 2, a pos + 3) = "ft" (* pft *)
+ THEN SETZE a pos plus 2; TRUE
+ ELSE FALSE
+ FI .
+
+ausnahme 3 :
+ IF code 1 = cv s
+ THEN IF code 2 = cv t AND code 3 <> cv r (* st, aber nicht: str *)
+ AND pos (vokal string, teilwort SUB a pos plus 2) = 0
+ THEN SETZE a pos plus 1 ; TRUE
+ ELSE FALSE
+ FI
+ ELIF code 2 = cv s
+ THEN IF code 3 = cv t AND (teilwort SUB a pos + 3) <> "r"
+ AND pos (vokal string, teilwort SUB (a pos + 3)) = 0
+ THEN SETZE a pos plus 2; TRUE
+ ELSE FALSE
+ FI
+ ELSE FALSE
+ FI .
+
+ausnahme 4 :
+ IF string (e pos, e pos + 3) = "lich"
+ THEN IF pos ("hg", teilwort SUB e pos minus 1) > 0
+ THEN SPERRE e pos minus 1
+ ELSE SETZE e pos minus 1
+ FI;
+ TRUE
+ ELSE FALSE
+ FI .
+
+suche regelmaessige konsonantenverbindung :
+ FOR posit FROM a pos UPTO e pos minus 1 REP
+ IF reg (posit)
+ THEN SETZE (posit - 1); LEAVE konsonant 3
+ FI
+ END REP ;
+ IF (teilwort SUB e pos) <> "h" OR (teilwort SUB e pos minus 1) <> "c"
+ THEN SETZE e pos minus 1
+ ELIF (teilwort SUB e pos - 2) <> "s"
+ THEN SETZE (e pos - 2)
+ ELSE SETZE (e pos - 3)
+ FI
+END PROC erstelle trennvektor ;
+END PACKET silbentrennung;
+
diff --git a/system/multiuser/1.7.5/src/spool manager b/system/multiuser/1.7.5/src/spool manager
new file mode 100644
index 0000000..ac0295a
--- /dev/null
+++ b/system/multiuser/1.7.5/src/spool manager
@@ -0,0 +1,887 @@
+PACKET spool manager DEFINES (* Autor: J. Liedtke *)
+ (* R. Nolting *)
+ (* R. Ruland *)
+ (* Stand: 25.04.86 *)
+
+ spool manager ,
+
+ server channel ,
+ spool duty,
+ station only,
+ spool control task :
+
+LET que size = 101 ,
+
+ ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ message ack = 3 ,
+ question ack = 4 ,
+ second phase ack = 5 ,
+
+ fetch code = 11 ,
+ save code = 12 ,
+ file save code old = 13 ,
+ erase code = 14 ,
+ list code = 15 ,
+ all code = 17 ,
+ param fetch code = 21 ,
+ file save code = 22 ,
+ entry line code = 23 ,
+ killer code = 24 ,
+ first code = 25 ,
+ start code = 26 ,
+ stop code = 27 ,
+ halt code = 28 ,
+ wait for halt code = 29 ,
+
+ continue code = 100 ,
+
+ file type = 1003 ;
+
+LET begin char = ""0"",
+ end char = ""1"";
+
+LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station),
+ ENTRY = STRUCT (PARAMS ds params, TEXT entry line, DATASPACE space);
+
+ROW que size ENTRY VAR que ;
+
+PARAMS CONST empty params := PARAMS : ("", "", "", "", -1);
+
+PARAMS VAR save params, file save params;
+
+ENTRY VAR fetch entry;
+
+FILE VAR file;
+
+INT VAR order, last order, phase, reply, old heap size, first, last, list index,
+ begin pos, end pos, order task station, sp channel, counter;
+
+TEXT VAR order task name, buffer, sp duty, start time;
+
+BOOL VAR server is waiting, stop command pending, stat only, valid fetch entry;
+
+TASK VAR order task, last order task, server, calling parent, task in control;
+
+INITFLAG VAR in this task := FALSE;
+
+DATASPACE VAR ds;
+
+BOUND STRUCT (TEXT name, userid, password) VAR msg;
+BOUND STRUCT (TEXT entry line, INT index) VAR control msg;
+BOUND PARAMS VAR fetch msg;
+BOUND THESAURUS VAR all msg;
+BOUND TEXT VAR error msg ;
+
+
+. first entry : que (first)
+. list entry : que (list index)
+. last entry : que (last)
+
+. que is empty : first = last
+. que is full : first = next (last)
+.;
+
+sp channel := 0;
+sp duty := "";
+stat only := FALSE;
+task in control := myself;
+
+PROC server channel (INT CONST channel nr) :
+ IF channel nr <= 0 OR channel nr >= 33
+ THEN errorstop ("falsche Kanalangabe") FI;
+ sp channel := channel nr;
+END PROC server channel;
+
+INT PROC server channel :
+ sp channel
+END PROC server channel;
+
+
+PROC station only (BOOL CONST flag) :
+ stat only := flag
+END PROC station only;
+
+BOOL PROC station only :
+ stat only
+END PROC station only;
+
+
+PROC spool duty (TEXT CONST duty) :
+ sp duty := duty;
+END PROC spool duty;
+
+TEXT PROC spool duty :
+ sp duty
+END PROC spool duty;
+
+
+PROC spool control task (TASK CONST task id):
+ task in control := task id;
+END PROC spool control task;
+
+TASK PROC spool control task :
+ task in control
+END PROC spool control task;
+
+
+PROC spool manager (PROC server start) :
+
+ spool manager (PROC server start, TRUE)
+
+END PROC spool manager;
+
+
+PROC spool manager (PROC server start, BOOL CONST with start) :
+
+ set autonom ;
+ break ;
+ disable stop ;
+ initialize spool manager ;
+ REP forget (ds) ;
+ wait (ds, order, order task) ;
+ IF order <> second phase ack
+ THEN prepare first phase ;
+ spool (PROC server start);
+ ELIF order task = last order task
+ THEN prepare second phase ;
+ spool (PROC server start);
+ ELSE send nak
+ FI ;
+ send error if necessary ;
+ collect heap garbage if necessary
+ PER
+
+ . initialize spool manager :
+ initialize if necessary;
+ stop;
+ erase fetch entry;
+ IF with start THEN start (PROC server start) FI;
+
+ . initialize if necessary :
+ IF NOT initialized (in this task)
+ THEN FOR list index FROM 1 UPTO que size
+ REP list entry. space := nilspace PER;
+ fetch entry. space := nilspace;
+ ds := nilspace;
+ last order task := niltask;
+ server := niltask;
+ calling parent := niltask;
+ server is waiting := FALSE;
+ stop command pending := FALSE;
+ old heap size := 0;
+ clear spool;
+ FI;
+
+ . prepare first phase :
+ IF order = save code OR order = erase code OR order = stop code
+ THEN phase := 1 ;
+ last order := order ;
+ last order task := order task ;
+ FI;
+
+ . prepare second phase :
+ phase INCR 1 ;
+ order := last order
+
+ . send nak :
+ forget (ds) ;
+ ds := nilspace ;
+ send (order task, nak, ds);
+
+ . send error if necessary :
+ IF is error
+ THEN forget (ds) ;
+ ds := nilspace ;
+ error msg := ds ;
+ CONCR (error msg) := error message;
+ clear error;
+ send (order task, error nak, ds)
+ FI;
+
+ . collect heap garbage if necessary :
+ IF heap size > old heap size + 2
+ THEN collect heap garbage;
+ old heap size := heap size;
+ FI;
+
+END PROC spool manager;
+
+
+PROC spool (PROC server start):
+
+ command dialogue (FALSE);
+ enable stop;
+ IF station only CAND station (ordertask) <> station (myself)
+ THEN errorstop ("kein Zugriffsrecht auf Task " + text (station(myself))
+ + "/""" + name(myself) + """")
+ FI;
+
+ SELECT order OF
+
+ CASE fetch code : out of que
+ CASE param fetch code : send fetch params
+ CASE save code : new que entry
+ CASE file save code, file save code old :
+ new file que entry
+ CASE erase code : erase que entry
+ CASE list code : send spool list
+ CASE all code : send owners ds names
+
+ OTHERWISE :
+
+ IF order >= continue code AND order task = supervisor
+ THEN forget (ds);
+ spool command (PROC server start)
+
+ ELIF spool control allowed by order task
+ THEN SELECT order OF
+ CASE entry line code : send next entry line
+ CASE killer code : kill entry
+ CASE first code : make to first
+ CASE start code : start server
+ CASE stop code : stop server
+ CASE halt code : halt server
+ CASE wait for halt code : wait for halt
+ OTHERWISE : errorstop ("falscher Auftrag fuer Task """
+ + name(myself) + """")
+ END SELECT
+
+ ELSE errorstop ("falscher Auftrag fuer Task """
+ + name(myself) + """")
+ FI;
+ END SELECT;
+
+
+. spool control allowed by order task :
+ (order task = spool control task OR order task < spool control task
+ OR spool control task = supervisor)
+ AND station (order task) = station (myself)
+.
+ out of que :
+ IF NOT (order task = server)
+ THEN errorstop ("keine Servertask")
+ ELIF stop command pending
+ THEN forget (ds);
+ stop;
+ erase fetch entry;
+ ELIF que is empty
+ THEN forget (ds) ;
+ erase fetch entry;
+ server is waiting := TRUE;
+ ELSE send first entry;
+ FI;
+
+.
+ send fetch params :
+ IF order task = server
+ THEN send params
+ ELSE errorstop ("keine Servertask")
+ FI;
+
+ . send params :
+ forget(ds); ds := nilspace; fetch msg := ds;
+ fetch msg := fetch entry. ds params;
+ send (order task, ack, ds);
+
+.
+ new que entry :
+ IF phase = 1
+ THEN prepare into que
+ ELSE into que
+ FI;
+
+.
+ prepare into que :
+ msg := ds ;
+ save params. name := msg.name;
+ save params. userid := msg.userid;
+ save params. password := msg.password;
+ save params. sendername := name (order task);
+ save params. station := station (order task);
+ forget (ds); ds := nilspace;
+ send (order task, second phase ack, ds);
+
+.
+ new file que entry :
+ IF type (ds) <> file type
+ THEN errorstop ("Datenraum hat falschen Typ");
+ ELSE get file params;
+ into que;
+ FI;
+
+ . get file params :
+ file := sequential file (input, ds);
+ end pos := 0;
+ next headline information (file save params. name);
+ next headline information (file save params. userid);
+ next headline information (file save params. password);
+ next headline information (file save params. sendername);
+ next headline information (buffer);
+ file save params. station := int (buffer);
+ IF NOT last conversion ok
+ THEN file save params. station := station (order task) FI;
+ IF file save params. sendername = ""
+ THEN file save params. sendername := name (order task) FI;
+ IF file save params. name = ""
+ THEN IF headline (file) <> ""
+ THEN file save params. name := headline (file);
+ ELSE errorstop ("Name unzulaessig")
+ FI;
+ ELSE headline (file, file save params. name);
+ FI;
+
+.
+ erase que entry :
+ msg := ds ;
+ order task name := name (order task);
+ order task station := station (order task);
+ IF phase = 1
+ THEN ask for erase
+ ELSE erase entry from order task
+ FI;
+
+ . ask for erase :
+ to first que entry;
+ WHILE next que entry found
+ REP IF is entry from order task (msg. name)
+ THEN manager question ("""" + msg.name + """ loeschen");
+ LEAVE erase que entry
+ FI;
+ PER ;
+ manager message ("""" + msg.name + """ existiert nicht");
+
+ . erase entry from order task :
+ IF is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ ELSE to first que entry;
+ WHILE next que entry found
+ REP IF is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ FI ;
+ PER ;
+ manager message ("""" + msg.name + """ existiert nicht");
+ FI;
+
+ . delete que entry :
+ erase entry (list index) ;
+ send ack;
+
+.
+ send owners ds names:
+ order task name := name (order task);
+ order task station := station (order task);
+ forget (ds); ds := nilspace; all msg := ds;
+ all msg := empty thesaurus;
+ to first que entry;
+ WHILE next que entry found
+ REP IF is entry from order task ("")
+ THEN insert (all msg, list entry. ds params. name)
+ FI;
+ PER;
+ send (order task, ack, ds)
+
+.
+ send spool list :
+ list spool;
+ send (order task, ack, ds);
+
+.
+ send next entry line :
+ control msg := ds;
+ get next entry line (control msg. entry line, control msg. index);
+ send (order task, ack, ds);
+
+.
+ kill entry :
+ control msg := ds;
+ list index := control msg. index;
+ IF is valid que entry (list index)
+ THEN erase entry (list index)
+ FI;
+ send (order task, ack, ds);
+
+.
+ make to first :
+ control msg := ds;
+ list index := control msg. index;
+ IF is valid que entry (list index)
+ THEN new first (list entry);
+ erase entry (list index);
+ FI;
+ send (order task, ack, ds);
+
+.
+ start server :
+ IF exists (server) THEN errorstop ("Spool muß zuerst gestoppt werden") FI;
+ start (PROC server start);
+ IF server channel <= 0 OR server channel >= 33
+ THEN manager message ("WARNUNG : Serverkanal nicht eingestellt");
+ ELSE send ack
+ FI;
+
+.
+ stop server:
+ IF phase = 1
+ THEN stop;
+ IF valid fetch entry
+ THEN valid fetch entry := FALSE;
+ manager question (""13""10"" +
+ fetch entry. entry line + " neu eintragen");
+ ELSE erase fetch entry;
+ send ack;
+ FI;
+ ELSE IF fetch entry. entry line <> "" THEN new first (fetch entry) FI;
+ erase fetch entry;
+ send ack;
+ FI;
+
+.
+ halt server :
+ stop command pending := TRUE;
+ IF NOT exists (server) OR server is waiting
+ THEN stop;
+ erase fetch entry;
+ FI;
+ send ack;
+
+.
+ wait for halt :
+ IF exists (calling parent)
+ THEN errorstop ("Task """ + name (calling parent) + """ wartet schon auf halt")
+ ELSE calling parent := order task;
+ stop command pending := TRUE;
+ forget (ds);
+ IF NOT exists (server) OR server is waiting
+ THEN stop;
+ erase fetch entry;
+ FI;
+ FI;
+
+END PROC spool;
+
+
+PROC send first entry :
+
+ forget (ds); ds := first entry. space;
+ send (server, ack, ds, reply) ;
+ IF reply = ack
+ THEN server is waiting := FALSE;
+ start time := time of day;
+ start time CAT " am ";
+ start time CAT date;
+ erase fetch entry;
+ fetch entry := first entry;
+ erase entry (first);
+ valid fetch entry := TRUE;
+ ELSE forget (ds);
+ FI;
+
+END PROC send first entry;
+
+
+PROC into que :
+
+ IF que is full
+ THEN errorstop ("Spool ist voll")
+ ELSE make new entry;
+ send ack;
+ awake server if necessary
+ FI;
+
+ . make new entry :
+ IF order = save code
+ THEN last entry. ds params := save params;
+ save params := empty params;
+ ELSE last entry. ds params := file save params;
+ file save params := empty params;
+ FI;
+ last entry. space := ds;
+ counter INCR 1;
+ build entry line;
+ last := next (last) ;
+
+ . build entry line :
+ IF LENGTH last entry. ds params. sender name > 16
+ THEN buffer := subtext (last entry. ds params. sender name, 1, 13);
+ buffer CAT "...""";
+ ELSE buffer := last entry. ds params. sender name;
+ buffer CAT """";
+ buffer := text (buffer, 17);
+ FI;
+ last entry. entry line := text (last entry. ds params. station, 2);
+ last entry. entry line CAT "/""";
+ last entry. entry line CAT buffer;
+ last entry. entry line CAT " : """ ;
+ last entry. entry line CAT last entry. ds params. name;
+ last entry. entry line CAT """ (" ;
+ last entry. entry line CAT text (storage (last entry. space));
+ last entry. entry line CAT " K)";
+
+ . awake server if necessary :
+ IF server is waiting THEN send first entry FI;
+
+END PROC into que;
+
+
+PROC list spool :
+
+ forget (ds); ds := nilspace;
+ file := sequential file (output, ds) ;
+ max line length (file, 1000);
+ headline(file, text (station(myself)) + "/""" + name (myself) + """");
+ put spool duty;
+ put current job;
+ put spool que;
+
+ . put spool duty :
+ IF spool duty <> ""
+ THEN write (file, "Aufgabe: ");
+ write (file, spool duty );
+ line (file, 2);
+ FI;
+
+ . put current job :
+ IF valid fetch entry AND exists (server)
+ THEN write (file, "In Bearbeitung seit ");
+ write (file, start time);
+ write (file, ":");
+ line (file, 2);
+ putline (file, fetch entry. entry line);
+ IF stop command pending
+ THEN putline (file, "Spool wird nach diesem Auftrag deaktiviert");
+ FI;
+ line (file);
+ ELSE write (file, "kein Auftrag in Bearbeitung");
+ IF NOT exists (server)
+ THEN write (file, ", da Spool deaktiviert");
+ ELIF que is empty
+ THEN write (file, ", da Warteschlange leer");
+ LEAVE list spool;
+ FI;
+ line (file, 2);
+ FI;
+
+ . put spool que :
+ IF que is empty
+ THEN putline (file, "Warteschlange ist leer");
+ ELSE write (file, "Warteschlange (");
+ write (file, text (counter));
+ write (file, " Auftraege):");
+ line (file, 2);
+ to first que entry ;
+ WHILE next que entry found
+ REP putline (file, list entry. entry line) PER;
+ FI;
+
+END PROC list spool ;
+
+
+PROC clear spool :
+
+ first := 1;
+ last := 1;
+ counter := 0;
+ FOR list index FROM 1 UPTO que size
+ REP list entry. ds params := empty params;
+ list entry. entry line := "";
+ forget (list entry. space)
+ PER;
+
+END PROC clear spool;
+
+(*********************************************************************)
+(* Hilfsprozeduren zum Spoolmanager *)
+
+BOOL PROC is valid que entry (INT CONST index) :
+
+ que (index). entry line <> ""
+
+END PROC is valid que entry;
+
+
+INT PROC next (INT CONST index) :
+
+ IF index < que size
+ THEN index + 1
+ ELSE 1
+ FI
+
+END PROC next;
+
+
+PROC to first que entry :
+
+ list index := first - 1;
+
+ENDPROC to first que entry ;
+
+
+BOOL PROC next que entry found :
+
+ list index := next (list index);
+ WHILE is not last que entry
+ REP IF is valid que entry (list index)
+ THEN LEAVE next que entry found WITH TRUE FI;
+ list index := next (list index);
+ PER;
+ FALSE
+
+ . is not last que entry :
+ list index <> last
+
+ENDPROC next que entry found ;
+
+
+PROC get next entry line (TEXT VAR entry line, INT VAR index) :
+
+ IF index = 0
+ THEN list index := first - 1
+ ELSE list index := index
+ FI;
+ IF next que entry found
+ THEN entry line := list entry. entry line;
+ index := list index;
+ ELSE entry line := "";
+ index := 0;
+ FI;
+
+END PROC get next entry line;
+
+
+PROC new first (ENTRY VAR new first entry) :
+
+ IF que is full
+ THEN errorstop ("Spool ist voll")
+ ELSE first DECR 1 ;
+ IF first = 0 THEN first := que size FI;
+ first entry := new first entry;
+ counter INCR 1;
+ FI;
+
+END PROC new first;
+
+
+PROC erase entry (INT CONST index) :
+
+ entry. ds params := empty params;
+ entry. entry line := "";
+ forget (entry.space) ;
+ counter DECR 1;
+ IF index = first
+ THEN inc first
+ FI ;
+
+ . entry : que (index)
+
+ . inc first :
+ REP first := next (first)
+ UNTIL que is empty OR is valid que entry (first) PER
+
+END PROC erase entry;
+
+
+PROC erase fetch entry :
+
+ fetch entry. ds params := empty params;
+ fetch entry. entry line := "";
+ forget (fetch entry. space);
+ valid fetch entry := FALSE;
+
+END PROC erase fetch entry;
+
+
+BOOL PROC is entry from order task (TEXT CONST file name) :
+
+ correct order task CAND correct filename
+
+ . correct order task :
+ order task name = list entry. ds params. sendername
+ AND order task station = list entry. ds params. station
+
+ . correct file name :
+ file name = "" OR file name = list entry. ds params. name
+
+END PROC is entry from order task;
+
+
+PROC start (PROC server start):
+
+ begin (PROC server start, server);
+
+END PROC start;
+
+
+PROC stop :
+
+ stop server;
+ send calling parent reply if necessary;
+
+ . stop server:
+ IF exists (server) THEN end (server) FI;
+ server := niltask;
+ server is waiting := FALSE;
+ stop command pending := FALSE;
+
+ . send calling parent reply if necessary :
+ IF exists (calling parent)
+ THEN forget (ds); ds := nilspace;
+ send (calling parent, ack, ds);
+ calling parent := niltask;
+ FI;
+
+END PROC stop;
+
+
+PROC next headline information (TEXT VAR t):
+
+ begin pos := pos (headline (file), begin char, end pos + 1);
+ IF begin pos = 0
+ THEN begin pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE end pos := pos (headline (file), end char, begin pos + 1);
+ IF end pos = 0
+ THEN end pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE t := subtext (headline (file), begin pos+1, end pos-1)
+ FI
+ FI
+
+END PROC next headline information;
+
+
+PROC send ack :
+
+ forget (ds); ds := nilspace;
+ send (order task, ack, ds)
+
+END PROC send ack;
+
+
+PROC manager question (TEXT CONST question) :
+
+ forget (ds); ds := nilspace; error msg := ds ;
+ error msg := question ;
+ send (order task, question ack, ds)
+
+ENDPROC manager question ;
+
+
+PROC manager message (TEXT CONST message) :
+
+ forget (ds); ds := nilspace; error msg := ds ;
+ error msg := message ;
+ send (order task, message ack, ds)
+
+ENDPROC manager message ;
+
+(*********************************************************************)
+(* Spool - Kommandos *)
+
+INT VAR command index , params ;
+TEXT VAR command line, param 1, param 2 ;
+
+LET spool command list =
+"break:1.0start:2.01stop:4.0halt:5.0first:6.0killer:7.0listspool:8.0
+clearspool:9.0spoolcontrolby:10.1";
+
+PROC spool command (PROC server start) :
+
+ enable stop ;
+ continue (order - continue code) ;
+ disable stop ;
+ REP command dialogue (TRUE) ;
+ get command ("gib Spool-Kommando:", command line);
+ analyze command (spool command list, command line, 3, command index,
+ params, param1, param2);
+ execute command (PROC server start);
+ UNTIL NOT online PER;
+ command dialogue (FALSE);
+ break (quiet);
+ set autonom;
+
+END PROC spool command;
+
+
+PROC execute command (PROC server start) :
+
+ enable stop;
+ SELECT command index OF
+ CASE 1 : break
+ CASE 2 : start server
+ CASE 3 : start server with new channel
+ CASE 4 : stop server
+ CASE 5 : halt server
+ CASE 6 : first cmd
+ CASE 7 : killer cmd
+ CASE 8 : show spool list
+ CASE 9 : clear spool
+ CASE 10 : spool control task (task (param1))
+ OTHERWISE do (command line)
+ END SELECT;
+
+ . start server :
+ IF server channel <= 0 OR server channel >= 33
+ THEN line;
+ putline ("WARNUNG : Serverkanal nicht eingestellt");
+ FI;
+ stop server;
+ start (PROC server start);
+
+ . start server with new channel:
+ INT VAR i := int (param1);
+ IF last conversion ok
+ THEN server channel (i);
+ start server;
+ ELSE errorstop ("falsche Kanalangabe")
+ FI;
+
+ . stop server :
+ disable stop;
+ stop;
+ IF valid fetch entry CAND
+ yes (""13""10"" + fetch entry. entry line + " neu eintragen")
+ THEN new first (fetch entry) FI;
+ erase fetch entry;
+ enable stop;
+
+ . halt server :
+ stop command pending := TRUE;
+ IF NOT exists (server) OR server is waiting
+ THEN stop server;
+ erase fetch entry;
+ FI;
+
+ . first cmd :
+ line ;
+ to first que entry ;
+ WHILE next que entry found
+ REP say (list entry. entry line) ;
+ IF yes (" als erstes")
+ THEN new first (list entry);
+ erase entry (list index);
+ LEAVE first cmd
+ FI ;
+ PER;
+
+ . killer cmd :
+ line ;
+ to first que entry ;
+ WHILE next que entry found
+ REP say (list entry. entry line) ;
+ IF yes (" loeschen") THEN erase entry (list index) FI ;
+ PER;
+
+ . show spool list :
+ list spool;
+ disable stop;
+ show (file);
+ forget (ds);
+
+ENDPROC execute command ;
+
+ENDPACKET spool manager;
+
diff --git a/system/multiuser/1.7.5/src/supervisor b/system/multiuser/1.7.5/src/supervisor
new file mode 100644
index 0000000..00874b2
--- /dev/null
+++ b/system/multiuser/1.7.5/src/supervisor
@@ -0,0 +1,774 @@
+(* ------------------- VERSION 19 03.06.86 ------------------- *)
+PACKET supervisor : (* Autor: J.Liedtke *)
+
+
+
+
+LET ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+
+ system catalogue code = 3 ,
+ begin code = 4 ,
+ end code = 5 ,
+ break code = 6 ,
+ rename code = 7 ,
+ halt code = 8 ,
+ password code = 9 ,
+ family password code = 40 ,
+ set autonom code = 41 ,
+ reset autonom code = 42 ,
+ define canal code = 43 ,
+ go back to old canal code = 44 ,
+ task of channel code = 45 ,
+ canal of channel code = 46 ,
+ set automatic startup code = 47 ,
+ reset automatic startup code = 48 ,
+
+ continue code low = 100 ,
+ continue code high = 132 ,
+
+ system start code = 100 ,
+ define station code = 32000 ,
+ max station no = 127 ,
+
+ nil = 0 ,
+
+ number of tasks = 125 ,
+
+ number of channels = 32 ,
+ highest terminal channel = 16 ,
+ highest user channel = 24 ,
+ highest system channel = 32 ,
+ configurator channel = 32 ,
+
+ shutup and save code = 12 ,
+
+ channel field = 4 ,
+ fromid field = 11 ,
+ nilchannel = 0 ;
+
+
+
+TASK VAR order task ;
+INT VAR order code ,
+ channel nr ,
+ channel index ;
+
+DATASPACE VAR ds ;
+
+BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR msg ;
+BOUND TEXT VAR error msg ;
+
+REAL VAR last rename time := 0.0 ;
+
+
+TEXT VAR actual password, supply password ;
+
+
+ROW highest terminal channel TASK VAR canal ;
+
+ROW number of channels TASK VAR connected task ;
+
+FOR channel index FROM 1 UPTO highest terminal channel REP
+ canal (channel index) := niltask ;
+PER ;
+FOR channel index FROM 1 UPTO number of channels REP
+ connected task (channel index) := niltask
+PER ;
+
+
+ROW number of tasks BOOL VAR autonom flag ;
+ROW number of tasks BOOL VAR automatic startup flag ;
+ROW number of tasks TEXT VAR task password ;
+
+task password (1) := "-" ;
+task password (2) := "-" ;
+
+set clock (date ("09.06.86")) ;
+
+TASK VAR dummy task ;
+command dialogue (TRUE) ;
+
+ke ; (* maintenance ke *)
+
+create son (myself, "SYSUR", dummy task, proca (PROC sysur)) ;
+
+PROC sysur :
+
+ disable stop ;
+ begin ("ARCHIVE", PROC archive manager, dummy task) ;
+ begin ("OPERATOR", PROC monitor, dummy task) ;
+ begin ("conf", PROC configurator, dummy task) ;
+ system manager
+
+ENDPROC sysur ;
+
+PROC configurator :
+
+ page ;
+ REP UNTIL yes("Archiv 'dev' eingelegt") PER;
+ archive ("dev") ;
+ fetch all (archive) ;
+ release (archive) ;
+ REP UNTIL yes ("save system") PER ;
+ command dialogue (FALSE) ;
+ save system ;
+ command dialogue (TRUE) ;
+ rename myself ("configurator") ;
+ disable stop ;
+ REP
+ configuration manager ;
+ clear error
+ PER
+
+ENDPROC configurator ;
+
+
+erase last bootstrap source dataspace ;
+channel (myself, 1) ;
+command dialogue (TRUE) ;
+IF yes("Leere Floppy eingelegt")
+ THEN channel (myself, nilchannel) ;
+ command dialogue (FALSE) ;
+ sys op (shutup and save code)
+ ELSE channel (myself, nilchannel) ;
+ command dialogue (FALSE)
+FI ;
+supervisor ;
+
+
+PROC supervisor :
+
+ disable stop ;
+ INT VAR old session := session ;
+ REP
+ wait (ds, order code, order task) ;
+ IF is niltask (order task)
+ THEN interrupt
+ ELIF station (order task) = station (myself)
+ THEN order from task
+ FI
+ PER .
+
+interrupt :
+ IF order code = 0
+ THEN IF old session <> session
+ THEN disconnect all terminal tasks ;
+ old session := session
+ FI ;
+ system start interrupt
+ ELSE supervisor interrupt (canal (order code), order code,
+ connected task (order code))
+ FI .
+
+disconnect all terminal tasks :
+ INT VAR i ;
+ FOR i FROM 1 UPTO highest terminal channel REP
+ TASK VAR id := connected task (i) ;
+ IF NOT (is niltask (id) COR automatic startup flag (index (id))
+ COR is niltask (canal (i)))
+ THEN break task
+ FI
+ PER .
+
+break task :
+ IF task direct connected to channel
+ THEN channel (id, nilchannel) ;
+ connected task (i) := niltask
+ ELSE disconnect if at terminal but overloaded by canal
+ FI .
+
+task direct connected to channel :
+ pcb (id, channel field) <> nilchannel .
+
+disconnect if at terminal but overloaded by canal :
+ connected task (i) := niltask .
+
+order from task :
+ channel index := channel (order task) ;
+ IF is command analyzer task
+ THEN order from command analyzer (connected task (channel index))
+ ELSE order from user task
+ FI ;
+ IF is error
+ THEN send back error message
+ FI .
+
+is command analyzer task :
+ channel index <> nilchannel
+ CAND channel index <= highest terminal channel
+ CAND order task = canal (channel index) .
+
+send back error message :
+ forget (ds) ;
+ ds := nilspace ;
+ error msg := ds ;
+ CONCR (error msg) := error message ;
+ clear error ;
+ send (order task, error nak, ds) .
+
+ENDPROC supervisor ;
+
+PROC supervisor interrupt (TASK VAR command analyzer, INT CONST channel nr,
+ TASK VAR terminal task) :
+
+ IF NOT is niltask (terminal task)
+ THEN channel (terminal task, nilchannel)
+ FI ;
+ create command analyzer if necessary ;
+ IF already at terminal
+ THEN halt process (command analyzer)
+ ELSE send acknowledge
+ FI ;
+ channel (command analyzer, channel nr) ;
+ activate (command analyzer) .
+
+create command analyzer if necessary :
+ IF is niltask (command analyzer)
+ THEN create son (myself, "-", command analyzer, proca (PROC analyze supervisor command))
+ FI .
+
+send acknowledge :
+ forget (ds) ;
+ ds := nilspace ;
+ send (command analyzer, ack, ds) .
+
+already at terminal : channel (command analyzer) = channel nr .
+
+ENDPROC supervisor interrupt ;
+
+PROC order from command analyzer (TASK VAR terminal task) :
+
+enable stop ;
+IF is continue THEN sv cmd continue
+ELIF order code = system catalogue code THEN task info cmd
+ELIF order code = task of channel code THEN sv cmd task of channel
+ELSE SELECT order code OF CASE ack :
+ CASE end code : sv cmd end
+ CASE break code : sv cmd break
+ CASE halt code : sv cmd halt
+ OTHERWISE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""")
+ END SELECT ;
+ channel (command analyzer, nilchannel)
+FI ;
+
+forget (ds) ;
+IF NOT is niltask (terminal task) AND order code <> system catalogue code
+ THEN channel (order task, nilchannel) ;
+ channel (terminal task, channel index) ;
+ activate (terminal task)
+FI .
+
+sv cmd task of channel :
+ msg := ds ;
+ msg.task := terminal task ;
+ send (order task,ack, ds) ;
+ LEAVE order from command analyzer .
+
+sv cmd end :
+ IF NOT is niltask (terminal task)
+ THEN delete task (terminal task) ;
+ terminal task := niltask
+ FI .
+
+sv cmd break :
+ terminal task := niltask .
+
+sv cmd continue :
+ sv cmd break ;
+ continue cmd by canal .
+
+sv cmd halt :
+ IF is niltask (terminal task)
+ THEN errorstop ("keine Task angekoppelt")
+ ELSE halt process (terminal task)
+ FI .
+
+is continue :
+ order code > continue code low AND order code <= continue code high .
+
+command analyzer : canal (channel index) .
+
+ENDPROC order from command analyzer ;
+
+PROC order from user task :
+
+ enable stop ;
+ SELECT order code OF
+ CASE nak, error nak :
+ CASE system catalogue code : task info cmd
+ CASE begin code : user begin cmd
+ CASE end code : user end cmd
+ CASE break code : user break cmd
+ CASE rename code : user rename cmd
+ CASE password code : password cmd
+ CASE family password code : family password cmd
+ CASE set autonom code : set autonom cmd
+ CASE reset autonom code : reset autonom cmd
+ CASE define canal code : define new canal
+ CASE go back to old canal code : go back to old canal
+ CASE task of channel code : task of channel
+ CASE canal of channel code : canal of channel
+ CASE set automatic startup code : set automatic startup cmd
+ CASE reset automatic startup code : reset automatic startup cmd
+ OTHERWISE IF is continue
+ THEN user continue cmd
+ ELIF is define station
+ THEN define new station
+ ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""")
+ FI
+ ENDSELECT .
+
+user begin cmd :
+ msg := ds ;
+ create son (order task, new task name, new task, new start proc) ;
+ send (order task, ack, ds) .
+
+user end cmd :
+ msg := ds ;
+ TASK VAR to be erased := CONCR (msg).task ;
+ IF task end permitted
+ THEN delete task (to be erased)
+ ELSE errorstop ("'end' unzulaessig")
+ FI ;
+ IF exists (order task)
+ THEN send (order task, ack, ds)
+ ELSE forget (ds)
+ FI .
+
+task end permitted :
+ ( (task is dead AND system catalogue contains entry) OR exists (to be erased))
+ CAND ( to be erased = order task
+ COR to be erased < order task
+ COR (order task < myself AND NOT (order task < to be erased)) ) .
+
+task is dead :
+ status (to be erased) > 6 .
+
+system catalogue contains entry :
+ task in catalogue (to be erased, index (to be erased)) .
+
+user rename cmd :
+ IF last rename was long ago
+ THEN msg := ds ;
+ name (order task, CONCR (msg).tname) ;
+ update entry in connected task array ;
+ send (order task, ack, ds) ;
+ remember rename time
+ ELSE send (order task, nak, ds)
+ FI .
+
+update entry in connected task array :
+ IF channel (order task) <> nilchannel
+ THEN connected task (channel (order task)) := order task
+ FI .
+
+remember rename time :
+ last rename time := clock (1) .
+
+last rename was long ago : abs (clock (1) - last rename time) > 20.0 .
+
+user break cmd :
+ break order task ;
+ send (order task, ack, ds) .
+
+break order task :
+ IF task direct connected to channel
+ THEN channel (order task, nilchannel) ;
+ terminal task := niltask
+ ELSE disconnect if at terminal but overloaded by canal
+ FI .
+
+task direct connected to channel : channel index <> nilchannel .
+
+terminal task : connected task (channel index) .
+
+disconnect if at terminal but overloaded by canal :
+ INT VAR i ;
+ FOR i FROM 1 UPTO highest terminal channel REP
+ IF connected task (i) = order task
+ THEN connected task (i) := niltask ;
+ LEAVE disconnect if at terminal but overloaded by canal
+ FI
+ PER .
+
+user continue cmd :
+ INT CONST dest channel := order code - continue code low ;
+ IF dest channel <= highest user channel OR order task < myself
+ THEN IF NOT channel really existing
+ THEN errorstop ("kein Kanal")
+ ELIF dest channel is free OR task is already at dest channel
+ THEN break order task ;
+ continue (order task, dest channel) ;
+ autonom flag (index (order task)) := FALSE ;
+ send (order task, ack, ds)
+ ELSE errorstop ("Kanal belegt")
+ FI
+ ELSE errorstop ("ungueltiger Kanal")
+ FI .
+
+channel really existing :
+ channel type (dest channel) <> 0 OR dest channel = configurator channel .
+
+dest channel is free :
+ (is niltask (connected task (dest channel)) OR channel (connected task (dest channel)) = nilchannel)
+ AND no canal active .
+
+no canal active :
+ dest channel > highest terminal channel COR
+ is niltask (canal (dest channel)) COR
+ channel (canal (dest channel)) = nilchannel .
+
+task is already at dest channel :
+ channel index = dest channel .
+
+
+password cmd :
+ msg := ds ;
+ task password (index (order task)) := new task password ;
+ forget (ds) ;
+ ds := nilspace ;
+ send (order task, ack, ds) .
+
+family password cmd :
+ msg := ds ;
+ actual password := new task password ;
+ supply password := task password (index (order task)) ;
+ change pw of all sons where necessary (son (order task)) ;
+ task password (index (order task)) := actual password ;
+ forget (ds) ;
+ ds := nilspace ;
+ send (order task, ack, ds) .
+
+set autonom cmd :
+ autonom flag (index (order task)) := TRUE ;
+ send (order task, ack, ds) .
+
+reset autonom cmd :
+ autonom flag (index (order task)) := FALSE ;
+ send (order task, ack, ds) .
+
+define new canal :
+ IF order task < myself AND
+ channel index > 0 AND channel index <= highest terminal channel CAND
+ is niltask (canal (channel index))
+ THEN canal (channel index) := order task ;
+ connected task (channel index) := niltask ;
+ send (order task, ack, ds)
+ ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""")
+ FI .
+
+go back to old canal :
+ IF order task < myself AND
+ channel index > 0 AND channel index <= highest terminal channel
+ THEN IF NOT is niltask (canal (channel index))
+ THEN delete task (canal (channel index))
+ FI ;
+ send (order task, ack, ds)
+ ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""")
+ FI .
+
+task of channel :
+ msg := ds ;
+ channel nr := int (msg.tname) ;
+ msg.task := channel task ;
+ send (order task, ack, ds).
+
+channel task :
+ IF channel nr <= highest terminal channel
+ THEN IF no command analyzer active
+ THEN connected task (channel nr)
+ ELSE canal (channel nr)
+ FI
+ ELSE connected task (channel nr)
+ FI .
+
+no command analyzer active :
+ channel (canal (channel nr)) = nilchannel .
+
+canal of channel :
+ msg := ds ;
+ channel nr := int (msg.tname) ;
+ msg.task := canal (channel nr) ;
+ send (order task, ack, ds).
+
+set automatic startup cmd :
+ automatic startup flag (index (order task)) := TRUE ;
+ send (order task, ack, ds) .
+
+reset automatic startup cmd :
+ automatic startup flag (index (order task)) := FALSE ;
+ send (order task, ack, ds) .
+
+is continue :
+ order code > continue code low AND order code <= continue code high .
+
+new task name : CONCR (msg).tname .
+
+new task : CONCR (msg).task .
+
+new task password : subtext (CONCR (msg).tpass, 1, 100) .
+
+new start proc : CONCR (msg).start proc .
+
+is define station :
+ order code >= define station code AND order task < myself AND
+ order code <= define station code + max station no .
+
+ENDPROC order from user task ;
+
+PROC continue cmd by canal :
+
+ access task name and password ;
+ check password if necessary ;
+ continue or send continue request ;
+ channel (order task, nilchannel) .
+
+access task name and password :
+ msg := ds ;
+ TASK CONST user task := task (CONCR (msg).tname) ;
+ INT CONST task index := index (user task) ;
+ actual password := task password (task index) ;
+ supply password := CONCR (msg).tpass .
+
+check password if necessary :
+ IF actual password <> ""
+ THEN IF supply password = ""
+ THEN ask for password ;
+ LEAVE continue cmd by canal
+ ELIF actual password <> supply password OR actual password = "-"
+ THEN errorstop ("Passwort falsch")
+ FI
+ FI .
+ask for password :
+ send (order task, password code, ds) .
+
+continue or send continue request :
+ IF autonom flag (task index)
+ THEN send continue request to user task
+ ELSE continue (user task, order code - continue code low)
+ FI .
+
+send continue request to user task :
+ INT VAR request count , quit ;
+ FOR request count FROM 1 UPTO 10 REP
+ send (user task, order code, ds, quit) ;
+ IF quit = ack
+ THEN LEAVE send continue request to user task
+ FI ;
+ pause (3)
+ PER ;
+ errorstop ("Task antwortet nicht") .
+
+ENDPROC continue cmd by canal ;
+
+PROC continue (TASK CONST id, INT CONST channel nr) :
+
+ IF NOT is niltask (id) CAND channel (id) <> channel nr
+ THEN check whether not linked to another channel ;
+ channel (id, channel nr) ;
+ connected task (channel nr) := id ;
+ prio (id, 0) ;
+ activate (id)
+ FI .
+
+check whether not linked to another channel :
+ INT VAR i ;
+ FOR i FROM 1 UPTO number of channels REP
+ IF connected task (i) = id
+ THEN errorstop ("bereits an Kanal " + text (i) ) ;
+ LEAVE continue
+ FI
+ PER .
+
+ENDPROC continue ;
+
+PROC task info cmd :
+
+ forget (ds) ;
+ ds := sys cat ;
+ send (order task, ack, ds) .
+
+ENDPROC task info cmd ;
+
+PROC delete task (TASK CONST superfluous) :
+
+ delete all sons of superfluous ;
+ delete superfluous itself .
+
+delete superfluous itself :
+ update cpu time of father ;
+ erase process (superfluous) ;
+ delete (superfluous) ;
+ erase terminal connection remark .
+
+update cpu time of father :
+ TASK CONST father task := father (superfluous) ;
+ IF NOT is niltask (father task)
+ THEN disable stop ;
+ REAL CONST father time := clock (father task) + clock (superfluous);
+ IF is error
+ THEN clear error
+ ELSE set clock (father task, father time)
+ FI ;
+ enable stop
+ FI .
+
+erase terminal connection remark :
+ INT VAR i ;
+ FOR i FROM 1 UPTO number of channels REP
+ IF connected task (i) = superfluous
+ THEN connected task (i) := niltask ;
+ LEAVE erase terminal connection remark
+ FI
+ PER ;
+ FOR i FROM 1 UPTO highest terminal channel REP
+ IF canal (i) = superfluous
+ THEN canal (i) := niltask ;
+ LEAVE erase terminal connection remark
+ FI
+ PER .
+
+delete all sons of superfluous :
+ TASK VAR son task ;
+ REP
+ son task := son (superfluous) ;
+ IF is niltask (son task)
+ THEN LEAVE delete all sons of superfluous
+ FI ;
+ delete task (son task)
+ PER .
+
+ENDPROC delete task ;
+
+PROC create son (TASK CONST father, TEXT CONST task name, TASK VAR new task, PROCA CONST start) :
+
+ entry (father, task name, new task) ;
+ autonom flag (index (new task)) := FALSE ;
+ automatic startup flag (index (new task)) := TRUE ;
+ task password (index (new task)) := "" ;
+ create (father, new task, privilege, start) .
+
+privilege :
+ IF new task < myself
+ THEN 1
+ ELSE 0
+ FI .
+
+ENDPROC create son ;
+
+
+PROC system start interrupt :
+
+ IF exists task ("configurator")
+ THEN send system start message
+ FI .
+
+send system start message :
+ ds := nilspace ;
+ INT VAR request count, quit ;
+ FOR request count FROM 1 UPTO 10 REP
+ send (task ("configurator"), system start code, ds, quit) ;
+ IF quit = ack
+ THEN LEAVE send system start message
+ FI ;
+ pause (3)
+ PER ;
+ forget (ds) .
+
+ENDPROC system start interrupt ;
+
+PROC define new station :
+
+ INT CONST station := order code - define station code ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO highest terminal channel REP
+ IF NOT is niltask (canal (i))
+ THEN delete task (canal (i))
+ FI
+ PER ;
+ define station (station) ;
+ FOR i FROM 1 UPTO number of channels REP
+ update (connected task (i))
+ PER ;
+ forget (ds) .
+
+ENDPROC define new station ;
+
+PROC change pw of all sons where necessary (TASK CONST first son) :
+
+ TASK VAR actual task := first son ;
+ WHILE NOT is niltask (actual task) REP
+ change pw ;
+ change pw of all sons where necessary (son (actual task));
+ actual task := brother (actual task)
+ PER.
+
+ change pw :
+ IF task password (index (actual task)) = supply password
+ OR
+ task password (index (actual task)) = ""
+ THEN task password (index (actual task)) := actual password
+ FI.
+
+END PROC change pw of all sons where necessary ;
+
+(******************* basic supervisor operations **********************)
+
+
+PROC channel (TASK CONST id, INT CONST channel nr) :
+ pcb (id, channel field, channel nr)
+ENDPROC channel ;
+
+INT PROC channel type (INT CONST channel nr) :
+ disable stop ;
+ channel (myself, channel nr) ;
+ INT VAR type ;
+ control (1, 0, 0, type) ;
+ channel (myself, nilchannel) ;
+ type
+ENDPROC channel type ;
+
+PROC erase last bootstrap source dataspace :
+
+ disable stop ;
+ errorstop ("") ;
+ clear error
+
+ENDPROC erase last bootstrap source dataspace ;
+
+PROC set clock (TASK CONST id, REAL CONST clock value) :
+ EXTERNAL 82
+ENDPROC set clock ;
+
+PROC sys op (INT CONST code) :
+ EXTERNAL 90
+END PROC sys op ;
+
+PROC create (TASK CONST father, son, INT CONST priv, PROCA CONST start) :
+ EXTERNAL 95
+ENDPROC create ;
+
+PROC pcb (TASK CONST id, INT CONST field, value) :
+ EXTERNAL 105
+ENDPROC pcb ;
+
+PROC activate (TASK CONST id) :
+ EXTERNAL 108
+ENDPROC activate ;
+
+PROC deactivate (TASK CONST id) :
+ EXTERNAL 109
+ENDPROC deactivate ;
+
+PROC halt process (TASK CONST id) :
+ EXTERNAL 110
+ENDPROC halt process ;
+
+PROC erase process (TASK CONST id) :
+ EXTERNAL 112
+ENDPROC erase process ;
+
+ENDPACKET supervisor ;
+
diff --git a/system/multiuser/1.7.5/src/sysgen off b/system/multiuser/1.7.5/src/sysgen off
new file mode 100644
index 0000000..9cb999b
--- /dev/null
+++ b/system/multiuser/1.7.5/src/sysgen off
@@ -0,0 +1,9 @@
+ke ; (* maintenance ke *)
+
+PROC sysgen off (INT CONST mode, INT VAR a,b,c,d,e,f,g,h,i,j,k) :
+ EXTERNAL 256
+ENDPROC sysgen off ;
+
+INT VAR x := 0 ;
+sysgen off (3,x,x,x,x,x,x,x,x,x,x,x) ;
+
diff --git a/system/multiuser/1.7.5/src/system info b/system/multiuser/1.7.5/src/system info
new file mode 100644
index 0000000..c29dfc2
--- /dev/null
+++ b/system/multiuser/1.7.5/src/system info
@@ -0,0 +1,342 @@
+
+PACKET system info DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 10.09.84 *)
+ task info ,
+ task status ,
+ storage info ,
+ help :
+
+
+LET supervisor mode = 0 ,
+ simple mode = 1 ,
+ status mode = 2 ,
+ storage mode = 3 ,
+
+ ack = 0 ,
+
+ channel field = 4 ,
+ prio field = 6 ,
+
+ cr lf = ""13""10"" ,
+ cr = ""13"" ,
+ page = ""1""4"" ,
+ begin mark= ""15"" ,
+ end mark = ""14"" ,
+ bell = ""7"" ,
+ esc = ""27"" ;
+
+
+
+TEXT VAR task name , record ;
+DATASPACE VAR ds := nilspace ;
+
+
+PROC task info :
+
+ task info (simple mode)
+
+ENDPROC task info ;
+
+PROC task info (INT CONST mode) :
+
+ open list file ;
+ task info (mode, list file) ;
+ show task info .
+
+open list file :
+ forget (ds) ;
+ ds := nilspace ;
+ FILE VAR list file := sequential file (output, ds) .
+
+show task info :
+ IF mode <> supervisor mode
+ THEN show (list file)
+ ELSE open editor (list file, FALSE) ;
+ edit (groesster editor, "q", PROC (TEXT CONST) no orders)
+ FI .
+
+ENDPROC task info ;
+
+PROC task info (INT CONST mode, FILE VAR list file) :
+
+ access catalogue ;
+ IF mode > simple mode
+ THEN generate head
+ FI ;
+ list tree (list file, supervisor,0, mode) .
+
+generate head :
+ put (list file, date) ;
+ put (list file, " ") ;
+ put (list file, time of day) ;
+ put (list file, " ") ;
+ IF mode = storage mode
+ THEN put (list file, "K ")
+ FI ;
+ put (list file, " CPU PRIO CHAN STATUS") ;
+ line (list file) .
+
+ENDPROC task info ;
+
+PROC task info (INT CONST level, fremdstation):
+ IF fremdstation = station (myself)
+ THEN task info (level)
+ ELSE
+ disable stop;
+ DATASPACE VAR x:= nilspace;
+ BOUND INT VAR l := x; l := level;
+ call (collector, 256+fremdstation, x, rtn);
+ INT VAR rtn;
+ IF rtn = ack
+ THEN FILE VAR ti:= sequential file (modify, x) ;
+ show (ti)
+ ELSE forget (x) ;
+ errorstop ("Station " + text (fremdstation) + " antwortet nicht")
+ FI ;
+ forget (x)
+ FI
+END PROC task info;
+
+PROC no orders (TEXT CONST ed kommando taste) :
+
+ IF ed kommando taste = "q"
+ THEN quit
+ ELSE out (""7"")
+ FI
+
+ENDPROC no orders ;
+
+PROC list tree (FILE VAR list file,
+ TASK CONST first son, INT CONST depth, mode) :
+
+ enable stop ;
+ TASK VAR actual task := first son ;
+ WHILE NOT is niltask (actual task) REP
+ list actual task ;
+ list tree (list file, son (actual task), depth+1, mode) ;
+ actual task := brother (actual task)
+ PER .
+
+list actual task :
+ record := "" ;
+ generate layout and task name ;
+ IF mode > simple mode
+ THEN tab to info position ;
+ show storage if wanted ;
+ record CAT cpu time of (actual task) ;
+ record CAT prio of actual task ;
+ record CAT channel of actual task ;
+ record CAT " " ;
+ record CAT status of (actual task)
+ FI ;
+ putline (list file, record) .
+
+generate layout and task name :
+ INT VAR i ;
+ FOR i FROM 1 UPTO depth REP
+ record CAT " "
+ PER ;
+ task name := name (actual task) ;
+ record CAT task name .
+
+tab to info position :
+ record := subtext (record, 1, 40) ;
+ FOR i FROM LENGTH record + 1 UPTO 40 REP
+ record CAT "."
+ PER ;
+ record CAT " " .
+
+show storage if wanted :
+ IF mode = storage mode
+ THEN record CAT text (storage (actual task), 5) ;
+ record CAT " "
+ FI .
+
+prio of actual task :
+ text (pcb (actual task, prio field),4) .
+
+channel of actual task :
+ INT CONST channel := pcb (actual task, channel field) ;
+ IF channel = 0
+ THEN " -"
+ ELSE text (channel,4)
+ FI .
+
+ENDPROC list tree ;
+
+TEXT PROC cpu time of (TASK CONST actual task) :
+
+ disable stop ;
+ TEXT VAR result := subtext (time (clock (actual task), 12), 1, 10) ;
+ IF is error
+ THEN clear error ;
+ result := 10 * "*"
+ FI ;
+ result
+
+ENDPROC cpu time of ;
+
+TEXT PROC status of (TASK CONST actual task) :
+
+ SELECT status (actual task) OF
+ CASE 0 : "-busy-"
+ CASE 1 : "i/o"
+ CASE 2 : "wait"
+ CASE 4 : "busy-blocked"
+ CASE 5 : "i/o -blocked"
+ CASE 6 : "wait-blocked"
+ OTHERWISE "--dead--"
+ END SELECT .
+
+ENDPROC status of ;
+
+PROC task status :
+
+ task status (myself)
+
+ENDPROC task status ;
+
+PROC task status (TEXT CONST task name) :
+
+ task status (task (task name))
+
+ENDPROC task status ;
+
+PROC task status (TASK CONST actual task) :
+
+ IF exists (actual task)
+ THEN put status of task
+ ELSE errorstop ("Task nicht vorhanden")
+ FI .
+
+put status of task :
+ line ;
+ put (date); put (time of day) ;
+ put (" TASK:") ;
+ put (name (actual task)) ;
+ line (2) ;
+ put ("Speicher:"); put (storage (actual task)); putline ("K");
+ put ("CPU-Zeit:"); put (cpu time of (actual task)) ; line;
+ put ("Zustand :"); write (status of (actual task));
+ put (", (prio");
+ write (text (pcb (actual task, prio field)));
+ put ("), Kanal") ;
+ IF channel (actual task) = 0
+ THEN put ("-")
+ ELSE put (channel (actual task))
+ FI ;
+ line .
+
+ENDPROC task status ;
+
+PROC storage info :
+
+ INT VAR size, used ;
+ storage (size, used) ;
+ out (""13""10" ") ;
+ put (used) ;
+ put ("K von") ;
+ put (size plus reserve) ;
+ putline ("K sind belegt!") .
+
+size plus reserve :
+ int (real (size + 24) * 64.0 / 63.0 ) .
+
+ENDPROC storage info ;
+
+
+PROC help :
+
+ IF NOT exists ("help")
+ THEN get help file
+ FI ;
+ FILE VAR f := sequential file (modify, "help") ;
+ help (f) .
+
+get help file :
+ TEXT VAR old std param := std ;
+ IF exists ("help", father)
+ THEN fetch ("help")
+ ELSE fetch ("help", public)
+ FI ;
+ last param (old std param) .
+
+ENDPROC help ;
+
+PROC help (FILE VAR help file) :
+
+ initialize help command ;
+ REP
+ out (page) ;
+ to paragraph ;
+ show paragraph ;
+ get show command
+ UNTIL is quit command PER .
+
+initialize help command :
+ TEXT VAR
+ help command := getcharety ;
+ IF help command = ""
+ THEN help command := "0"
+ FI .
+
+to paragraph :
+ col (help file, 1) ;
+ to line (help file, 1) ;
+ downety (help file, "#" + help command + "#") ;
+ IF eof (help file)
+ THEN to line (help file, 1) ;
+ out (bell)
+ FI .
+
+show paragraph :
+ show headline ;
+ WHILE NOT end of help subfile REP
+ show help line
+ PER ;
+ show bottom line .
+
+show headline :
+ out (begin mark) ;
+ INT CONST dots := (x size - len (help file) - 5) DIV 2 ;
+ dots TIMESOUT "." ;
+ exec (PROC show line, help file, 4) ;
+ dots TIMESOUT "." ;
+ out (end mark) ;
+ down (help file) .
+
+show help line :
+ out (cr lf) ;
+ exec (PROC show line, help file, 1) ;
+ down (help file) .
+
+show bottom line :
+ cursor (5, y size) ;
+ exec (PROC show line, help file, 3) ;
+ out (cr) .
+
+get show command :
+ TEXT VAR char ;
+ get char (char) ;
+ IF char = esc
+ THEN get char (char)
+ FI ;
+ IF char >= " "
+ THEN help command := char
+ ELSE out (bell)
+ FI .
+
+end of help subfile : pos (help file,"##",1) <> 0 OR eof (help file) .
+
+is quit command : help command = "q" OR help command = "Q" .
+
+ENDPROC help ;
+
+PROC show line (TEXT CONST line, INT CONST from) :
+
+ outsubtext (line, from, x size - from)
+
+ENDPROC show line ;
+
+ENDPACKET system info ;
+
diff --git a/system/multiuser/1.7.5/src/system manager b/system/multiuser/1.7.5/src/system manager
new file mode 100644
index 0000000..5406ff0
--- /dev/null
+++ b/system/multiuser/1.7.5/src/system manager
@@ -0,0 +1,117 @@
+(* ------------------- VERSION 4 vom 31.01.86 ------------------- *)
+PACKET system manager DEFINES (* F. Klapper *)
+ system manager ,
+ generate shutup manager ,
+ put log :
+
+LET ack = 0 ,
+ error nak = 2 ,
+ fetch code = 11 ,
+ list code = 15 ,
+ all code = 17 ,
+ log code = 21 ,
+ eszet = ""251"" ,
+ log file name = "logbuch";
+
+DATASPACE VAR ds;
+
+BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ;
+BOUND TEXT VAR log message,
+ error msg;
+
+INT VAR reply;
+
+TEXT VAR xname;
+
+FILE VAR log file;
+
+PROC system manager:
+ lernsequenz auf taste legen ("s", eszet) ;
+ global manager
+ (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) sys manager)
+
+END PROC system manager;
+
+PROC sys manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task):
+ enable stop;
+ SELECT order OF
+ CASE log code : y put log
+ CASE list code : y list
+ CASE all code : y all
+ CASE fetch code : y fetch
+ OTHERWISE std manager (ds, order, phase, order task)
+ END SELECT.
+
+y fetch :
+ msg := ds;
+ xname := msg.name;
+ IF read permission (xname, msg.read pass)
+ THEN forget (ds) ;
+ ds := old (xname) ;
+ send (order task, ack, ds)
+ ELSE errorstop ("Passwort falsch")
+ FI .
+
+y list :
+ forget (ds) ;
+ ds := nilspace ;
+ FILE VAR list file := sequential file (output, ds) ;
+ list (list file) ;
+ send (order task, ack, ds) .
+
+y all :
+ forget (ds);
+ ds := nilspace;
+ BOUND THESAURUS VAR all names := ds ;
+ all names := all ;
+ send (order task, ack, ds) .
+
+y put log :
+ log file := sequential file (output, log file name) ;
+ IF lines (log file) < 4000
+ THEN max line length (log file,1000);
+ put (log file, date) ;
+ put (log file, time of day) ;
+ put (log file, text (name (order task), 8));
+ log message := ds ;
+ put (log file, CONCR (log message)) ;
+ FI ;
+ send (order task, ack, ds) .
+
+END PROC sys manager;
+
+PROC put log (TEXT CONST message) :
+ enable stop;
+ forget (ds) ;
+ ds := nilspace ;
+ log message := ds ;
+ CONCR (log message) := message ;
+ call (task("SYSUR"), log code, ds, reply) .
+
+ENDPROC put log ;
+
+PROC generate shutup manager :
+
+ TASK VAR son ;
+ begin ("shutup", PROC shutup manager, son)
+
+ENDPROC generate shutup manager ;
+
+PROC shutup manager :
+ disable stop ;
+ task password ("") ;
+ command dialogue (TRUE) ;
+ REP
+ break ;
+ line ;
+ IF yes ("shutup")
+ THEN clear error ;
+ shutup
+ FI
+ PER
+
+ENDPROC shutup manager ;
+
+ENDPACKET system manager ;
+
diff --git a/system/multiuser/1.7.5/src/tasks b/system/multiuser/1.7.5/src/tasks
new file mode 100644
index 0000000..276011e
--- /dev/null
+++ b/system/multiuser/1.7.5/src/tasks
@@ -0,0 +1,978 @@
+(* ------------------- VERSION 9 vom 09.06.86 ------------------- *)
+PACKET tasks DEFINES (* Autor: J.Liedtke *)
+
+ TASK ,
+ PROCA ,
+ := ,
+ = ,
+ < ,
+ / ,
+ niltask ,
+ is niltask ,
+ exists ,
+ exists task ,
+ supervisor ,
+ myself ,
+ public ,
+ proca ,
+ collector ,
+ access ,
+ name ,
+ task ,
+ canal ,
+ dataspaces ,
+ index ,
+ station ,
+ update ,
+ father ,
+ son ,
+ brother ,
+ next active ,
+ access catalogue ,
+ family password ,
+ task in catalogue ,
+ entry ,
+ delete ,
+ define station ,
+
+ pcb ,
+ status ,
+ channel ,
+ clock ,
+ storage ,
+ callee ,
+
+ send ,
+ wait ,
+ call ,
+ pingpong ,
+ collected destination ,
+
+ begin ,
+ end ,
+ break ,
+ continue ,
+ rename myself ,
+ task password ,
+ set autonom ,
+ reset autonom ,
+ set automatic startup ,
+ reset automatic startup ,
+
+ sys cat :
+
+
+
+LET nil = 0 ,
+
+ max version = 30000 ,
+ max task = 125 ,
+ max station no = 127 ,
+ sv no = 1 ,
+
+ hex ff = 255 ,
+ hex 7f00 = 32512 ,
+
+ collected dest field 1 = 2 ,
+ collected dest field 2 = 3 ,
+ channel field = 4 ,
+ myself no field = 9 ,
+ myself version field = 10 ,
+ callee no field = 11 ,
+ callee version field = 12 ,
+
+ highest terminal channel = 16 ,
+ number of channels = 32 ,
+
+ wait state = 2 ,
+
+ ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ system catalogue code = 3 ,
+ begin code = 4 ,
+ end code = 5 ,
+ break code = 6 ,
+ rename code = 7 ,
+ password code = 9 ,
+ family password code = 40 ,
+ set autonom code = 41 ,
+ reset autonom code = 42 ,
+ task of channel code = 45 ,
+ canal of channel code = 46 ,
+ set automatic startup code = 47 ,
+ reset automatic startup code = 48 ,
+
+ continue code = 100,
+ define station code = 32000,
+
+ lowest ds number = 4 ,
+ highest ds number = 255 ;
+
+
+TYPE TASK = STRUCT (INT no, version) ,
+ PROCA = STRUCT (INT a, b) ;
+
+OP := (PROCA VAR right, PROCA CONST left) :
+ CONCR (right) := CONCR (left)
+ENDOP := ;
+
+PROCA PROC proca (PROC p) :
+
+ push (0, PROC p) ;
+ pop
+
+ENDPROC proca ;
+
+PROC push (INT CONST dummy, PROC p) : ENDPROC push ;
+
+PROCA PROC pop :
+ PROCA VAR res;
+ res
+ENDPROC pop ;
+
+TASK CONST niltask := TASK: (0,0) ,
+ collector := TASK: (-1,0) ;
+
+TASK PROC supervisor :
+
+ TASK: (my station id + sv no, 0) .
+
+my station id : pcb (myself no field) AND hex 7f00 .
+
+ENDPROC supervisor ;
+
+TASK VAR father task ;
+
+INITFLAG VAR catalogue known := FALSE , father known := FALSE ;
+
+
+
+LET TASKVECTOR = STRUCT (INT version, father, son, brother) ;
+
+
+DATASPACE VAR catalogue space , sv space ;
+
+BOUND STRUCT (THESAURUS dir,
+ ROW max task TASKVECTOR link) VAR system catalogue ;
+ initialize catalogue ;
+
+BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg ;
+
+
+PROC initialize catalogue :
+
+ catalogue space := nilspace ;
+ system catalogue := catalogue space ;
+ system catalogue.dir := empty thesaurus ;
+
+ insert (system catalogue.dir, "SUPERVISOR") ;
+ insert (system catalogue.dir, "UR") ;
+ system catalogue.link (1) := TASKVECTOR:(0,0,0,2) ;
+ system catalogue.link (2) := TASKVECTOR:(0,0,0,0) .
+
+ENDPROC initialize catalogue ;
+
+DATASPACE PROC sys cat :
+ catalogue space
+ENDPROC sys cat ;
+
+
+TASK PROC myself :
+
+ TASK: (pcb (myself no field), pcb (myself version field))
+
+ENDPROC myself ;
+
+
+OP := (TASK VAR dest, TASK CONST source):
+
+ CONCR (dest) := CONCR (source)
+
+ENDOP := ;
+
+BOOL OP = (TASK CONST left, right) :
+
+ left.no = right.no AND left.version = right.version
+
+ENDOP = ;
+
+BOOL PROC is niltask (TASK CONST t) :
+
+ t.no = 0
+
+ENDPROC is niltask ;
+
+BOOL OP < (TASK CONST left, right) :
+
+ IF both of my station
+ THEN access (left) ;
+ access (right) ;
+ ( index (left) > 0 CAND index (left) <= max task )
+ CAND
+ ( father (left) = right COR father (left) < right )
+ ELSE FALSE
+ FI .
+
+both of my station :
+ station (left) = station (right) AND station (right) = station (myself) .
+
+ENDOP < ;
+
+BOOL PROC exists (TASK CONST task) :
+
+ EXTERNAL 123
+
+ENDPROC exists ;
+
+BOOL PROC exists task (TEXT CONST name) :
+
+ task id (name).no <> 0
+
+ENDPROC exists task ;
+
+TEXT PROC name (TASK CONST task) :
+
+ IF is task of other station
+ THEN external name (task)
+ ELSE
+ access (task) ;
+ INT CONST task no := index (task) ;
+ IF task in catalogue (task ,task no)
+ THEN name (system catalogue.dir, task no)
+ ELSE ""
+ FI
+ FI.
+
+is task of other station :
+ (task.no AND hex 7f00) <> (pcb (myself no field) AND hex 7f00) .
+
+ENDPROC name ;
+
+BOOL PROC task in catalogue (TASK CONST task, INT CONST task no) :
+
+ access catalogue ;
+ task no >= 1 CAND task no <= max task CAND
+ task.version = system catalogue.link (task no).version .
+
+ENDPROC task in catalogue ;
+
+PROC access (TASK CONST task) :
+
+ INT CONST task no := task.no AND hex ff ;
+ IF task no < 1 OR task no > max task
+ THEN
+ ELIF is task of other station
+ THEN errorstop ("TASK anderer Station")
+ ELIF actual task id not in catalogue COR NOT exists (task)
+ THEN access catalogue
+ FI .
+
+actual task id not in catalogue :
+ NOT initialized (catalogue known) COR
+ ( task no > 0 CAND catalogue version <> task.version ) .
+
+catalogue version : system catalogue.link (task no).version .
+
+is task of other station :
+ (task.no AND hex 7f00) <> (pcb (myself no field) AND hex 7f00) .
+
+ENDPROC access ;
+
+TASK PROC task (TEXT CONST task name) :
+
+ TASK CONST id := task id (task name) ;
+ IF id.no = 0
+ THEN errorstop (""""+task name+""" gibt es nicht")
+ FI ;
+ id
+
+ENDPROC task ;
+
+TASK PROC task id (TEXT CONST task name) :
+
+ IF task name = "-" OR task name = ""
+ THEN errorstop ("Taskname unzulaessig")
+ FI ;
+ IF NOT initialized (catalogue known)
+ THEN access catalogue
+ FI ;
+
+ TASK VAR
+ id := task id (link (system catalogue.dir, task name)) ;
+ IF NOT exists (id)
+ THEN access catalogue ;
+ id := task id (link (system catalogue.dir, task name)) ;
+ FI ;
+ id .
+
+ENDPROC task id ;
+
+TASK OP / (TEXT CONST task name) :
+
+ task (task name)
+
+ENDOP / ;
+
+INT PROC index (TASK CONST task) :
+
+ IF NOT initialized (catalogue known)
+ THEN access catalogue
+ FI ;
+ task.no AND hex ff
+
+ENDPROC index ;
+
+INT PROC station (TASK CONST task) :
+
+ task.no DIV 256
+
+ENDPROC station ;
+
+PROC update (TASK VAR task) :
+
+ IF task.no <> nil
+ THEN task.no := (task.no AND hex ff) + new station number
+ FI .
+
+new station number : (pcb (myself no field) AND hex 7f00) .
+
+ENDPROC update ;
+
+
+TASK PROC public :
+
+ task ("PUBLIC")
+
+ENDPROC public ;
+
+TASK PROC father :
+
+ IF NOT initialized (father known) COR station or rename changed father id
+ THEN access catalogue ;
+ father task := father (myself)
+ FI ;
+ father task .
+
+station or rename changed father id :
+ NOT exists (father task) .
+
+ENDPROC father ;
+
+INT VAR task no ;
+
+TASK PROC father (TASK CONST task) :
+
+ task no := index (task) ;
+ task id (system catalogue.link (task no).father) .
+
+ENDPROC father ;
+
+TASK PROC son (TASK CONST task) :
+
+ task no := index (task) ;
+ IF task no = nil
+ THEN supervisor
+ ELSE task id (system catalogue.link (task no).son)
+ FI .
+
+ENDPROC son ;
+
+TASK PROC brother (TASK CONST task) :
+
+ task no := index (task) ;
+ task id (system catalogue.link (task no).brother) .
+
+ENDPROC brother ;
+
+PROC next active (TASK VAR task) :
+
+ next active task index (task.no) ;
+ IF task.no > 0
+ THEN task.version := pcb (task, myself version field)
+ ELSE task.version := 0
+ FI
+
+ENDPROC next active ;
+
+PROC next active task index (INT CONST no) :
+
+ EXTERNAL 118
+
+ENDPROC next active task index ;
+
+TASK PROC task id (INT CONST task nr) :
+
+ INT VAR task index := task nr AND hex ff ;
+ TASK VAR result ;
+ result.no := task index ;
+ IF task index = nil
+ THEN result.version := 0
+ ELSE result.version := system catalogue.link (task index).version ;
+ result.no INCR my station id
+ FI ;
+ result .
+
+my station id : pcb (myself no field) AND hex 7f00 .
+
+ENDPROC task id ;
+
+PROC access catalogue :
+
+ IF this is not supervisor
+ THEN get catalogue from supervisor
+ FI .
+
+this is not supervisor :
+ (pcb (myself no field) AND hex ff) <> sv no .
+
+get catalogue from supervisor :
+ INT VAR dummy reply ;
+ forget (catalogue space) ;
+ catalogue space := nilspace ;
+ call (supervisor, system catalogue code, catalogue space, dummy reply) ;
+ system catalogue := catalogue space .
+
+ENDPROC access catalogue ;
+
+
+PROC entry (TASK CONST father task, TEXT CONST task name,
+ TASK VAR son task) :
+
+ IF task name <> "-" CAND (system catalogue.dir CONTAINS task name)
+ THEN errorstop (""""+task name+""" existiert bereits")
+ ELIF is niltask (father task)
+ THEN errorstop ("Vatertask existiert nicht")
+ ELSE entry task
+ FI .
+
+entry task :
+ INT VAR son task nr ;
+ INT CONST father task nr := index (father task) ;
+ insert (system catalogue.dir, task name, son task nr) ;
+ IF son task nr = nil OR son task nr > max task
+ THEN delete (system catalogue.dir, son task nr) ;
+ son task := niltask ;
+ errorstop ("zu viele Tasks")
+ ELSE insert task (father task, father vec, son task, son vec, son tasknr)
+ FI .
+
+father vec : system catalogue.link (father task nr) .
+
+son vec : system catalogue.link (son task nr) .
+
+ENDPROC entry ;
+
+PROC insert task (TASK CONST father task, TASKVECTOR VAR father vec,
+ TASK VAR son task, TASKVECTOR VAR son vec, INT CONST nr) :
+
+ initialize version number if son vec is first time used ;
+ increment version (son vec) ;
+ son task.no := my station id + nr ;
+ son task.version := son vec.version ;
+ link into task tree .
+
+initialize version number if son vec is first time used :
+ IF son vec.version < 0
+ THEN son vec.version := 0
+ FI .
+
+link into task tree :
+ son vec.son := nil ;
+ son vec.brother := father vec.son ;
+ son vec.father := index (father task) ;
+ father vec.son := son task.no .
+
+my station id : pcb (myself no field) AND hex 7f00 .
+
+END PROC insert task ;
+
+
+PROC delete (TASK CONST superfluous) :
+
+ INT CONST superfluous nr := index (superfluous) ;
+ delete (system catalogue.dir, superfluous nr) ;
+ delete superfluous task ;
+ increment version (superfluous vec) .
+
+delete superfluous task :
+ INT CONST successor of superfluous := superfluous vec.brother ;
+ TASK VAR
+ last := father (superfluous) ,
+ actual := son (last) ;
+ IF actual = superfluous
+ THEN delete first son of last
+ ELSE search previous brother of superfluous ;
+ delete from brother chain
+ FI .
+
+delete first son of last :
+ last vec.son := successor of superfluous .
+
+search previous brother of superfluous :
+ REP
+ last := actual ;
+ actual := brother (actual)
+ UNTIL actual = superfluous PER .
+
+delete from brother chain :
+ last vec.brother := successor of superfluous .
+
+last vec : system catalogue.link (index (last)) .
+
+superfluous vec : system catalogue.link (superfluous nr) .
+
+ENDPROC delete ;
+
+
+PROC name (TASK VAR task, TEXT CONST new name) :
+
+ INT CONST task no := index (task) ;
+ IF (system catalogue.dir CONTAINS new name) AND (new name <> "-")
+ AND (name (task) <> new name)
+ THEN errorstop (""""+new name+""" existiert bereits")
+ ELSE rename (system catalogue.dir, task no, new name) ;
+ increment version (system catalogue.link (task no)) ;
+ IF this is supervisor
+ THEN update task version in pcb and task variable
+ FI
+ FI .
+
+this is supervisor : (pcb (myself no field) AND hex ff) = sv no .
+
+update task version in pcb and task variable :
+ INT CONST new version := system catalogue.link (task no).version ;
+ write pcb (task, myself version field, new version) ;
+ task.version := new version .
+
+ENDPROC name ;
+
+
+PROC increment version (TASKVECTOR VAR task vec) :
+
+ task vec.version := task vec.version MOD max version + 1
+
+ENDPROC increment version ;
+
+
+INT PROC pcb (TASK CONST id, INT CONST field) :
+
+ EXTERNAL 104
+
+ENDPROC pcb ;
+
+INT PROC status (TASK CONST id) :
+
+ EXTERNAL 107
+
+ENDPROC status ;
+
+INT PROC channel (TASK CONST id) :
+
+ pcb (id, channel field)
+
+ENDPROC channel ;
+
+REAL PROC clock (TASK CONST id) :
+
+ EXTERNAL 106
+
+ENDPROC clock ;
+
+INT PROC storage (TASK CONST id) :
+
+ INT VAR ds number, storage sum := 0, ds size;
+ FOR ds number FROM lowest ds number UPTO highest ds number REP
+ ds size := pages (ds number, id) ;
+ IF ds size > 0
+ THEN storage sum INCR ((ds size + 1) DIV 2)
+ FI
+ PER ;
+ storage sum
+
+ENDPROC storage ;
+
+INT PROC pages (INT CONST ds number, TASK CONST id) :
+
+ EXTERNAL 88
+
+ENDPROC pages ;
+
+TASK PROC callee (TASK CONST from) :
+
+ IF status (from) = wait state
+ THEN TASK:(pcb (from, callee no field), pcb (from, callee version field))
+ ELSE niltask
+ FI
+
+ENDPROC callee ;
+
+
+PROC send (TASK CONST dest, INT CONST send code, DATASPACE VAR ds,
+ INT VAR quit) :
+ EXTERNAL 113
+
+ENDPROC send ;
+
+PROC send (TASK CONST dest, INT CONST send code, DATASPACE VAR ds) :
+
+ INT VAR dummy quit ;
+ send (dest, send code, ds, dummy quit) ;
+ forget (ds)
+
+ENDPROC send ;
+
+PROC wait (DATASPACE VAR ds, INT VAR receive code, TASK VAR source) :
+
+ EXTERNAL 114
+
+ENDPROC wait ;
+
+PROC call (TASK CONST dest, INT CONST order code, DATASPACE VAR ds,
+ INT VAR reply code) :
+ EXTERNAL 115
+
+ENDPROC call ;
+
+PROC pingpong (TASK CONST dest, INT CONST order code, DATASPACE VAR ds,
+ INT VAR reply code) :
+ EXTERNAL 122
+
+ENDPROC pingpong ;
+
+TASK PROC collected destination :
+
+ TASK: (pcb (collected dest field 1), pcb (collected dest field 2))
+
+ENDPROC collected destination ;
+
+
+PROC begin (PROC start, TASK VAR new task) :
+
+ begin ("-", PROC start, new task)
+
+ENDPROC begin ;
+
+PROC begin (TEXT CONST son name, PROC start, TASK VAR new task) :
+
+ enable stop ;
+ forget (sv space) ;
+ sv space := nilspace ;
+ sv msg := sv space ;
+ CONCR (sv msg).tname := son name ;
+ CONCR (sv msg).start proc := proca (PROC start) ;
+ supervisor call (begin code) ;
+ sv msg := sv space ;
+ new task := CONCR (sv msg).task .
+
+ENDPROC begin ;
+
+PROC begin (DATASPACE VAR ds, PROC start, INT VAR reply) :
+
+ sv msg := ds ;
+ sv msg.start proc := proca (PROC start) ;
+ call (supervisor, begin code, ds, reply)
+
+ENDPROC begin ;
+
+PROC end :
+
+ command dialogue (TRUE) ;
+ say ("task """) ;
+ say (name (myself)) ;
+ IF yes (""" loeschen")
+ THEN eumel must advertise ;
+ end (myself)
+ FI
+
+ENDPROC end ;
+
+PROC end (TASK CONST id) :
+
+ forget (sv space) ;
+ sv space := nilspace ;
+ sv msg := sv space ;
+ CONCR (sv msg).task := id ;
+ supervisor call (end code)
+
+ENDPROC end ;
+
+PROC break (QUIET CONST quiet) :
+
+ simple supervisor call (break code)
+
+ENDPROC break ;
+
+PROC break :
+
+ eumel must advertise ;
+ simple supervisor call (break code)
+
+ENDPROC break ;
+
+PROC continue (INT CONST channel nr) :
+
+ simple supervisor call (continue code + channel nr)
+
+ENDPROC continue ;
+
+PROC rename myself (TEXT CONST new name) :
+
+ forget (sv space) ;
+ sv space := nilspace ;
+ sv msg := sv space ;
+ CONCR (sv msg).tname := new name ;
+ supervisor call (rename code) .
+
+ENDPROC rename myself ;
+
+
+PROC simple supervisor call (INT CONST code) :
+
+ forget (sv space) ;
+ sv space := nilspace ;
+ supervisor call (code)
+
+ENDPROC simple supervisor call ;
+
+PROC supervisor call (INT CONST code) :
+
+ INT VAR answer ;
+ call (supervisor, code, sv space, answer) ;
+ WHILE answer = nak REP
+ pause (20) ;
+ call (supervisor, code, sv space, answer)
+ PER ;
+ IF answer = error nak
+ THEN BOUND TEXT VAR error message := sv space ;
+ errorstop (CONCR (error message))
+ FI
+
+ENDPROC supervisor call ;
+
+PROC task password (TEXT CONST password) :
+
+ IF online
+ THEN say (""3""5""10"")
+ FI ;
+ forget (sv space) ;
+ sv space := nilspace ;
+ sv msg := sv space ;
+ CONCR (sv msg).tpass := password ;
+ supervisor call (password code) ;
+ cover tracks .
+
+ENDPROC task password ;
+
+PROC set autonom :
+
+ simple supervisor call (set autonom code)
+
+ENDPROC set autonom ;
+
+PROC reset autonom :
+
+ simple supervisor call (reset autonom code)
+
+ENDPROC reset autonom ;
+
+PROC set automatic startup :
+ simple supervisor call (set automatic startup code)
+ENDPROC set automatic startup ;
+
+PROC reset automatic startup :
+ simple supervisor call (reset automatic startup code)
+ENDPROC reset automatic startup ;
+
+PROC define station (INT CONST station number) :
+
+ IF this is supervisor
+ THEN update all tasks
+ ELIF i am privileged
+ THEN IF station number is valid
+ THEN send define station message
+ ELSE errorstop ("ungueltige Stationsnummer (0 - 127)")
+ FI
+ ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""")
+ FI .
+
+update all tasks :
+ start at supervisor ;
+ REP
+ get next task ;
+ IF no more task found
+ THEN update station number of supervisor ;
+ LEAVE update all tasks
+ FI ;
+ update station number of actual task
+ PER .
+
+i am privileged :
+ myself < supervisor .
+
+station number is valid :
+ station number >= 0 AND station number <= max station no .
+
+start at supervisor :
+ TEXT VAR name ;
+ INT VAR index := sv no .
+
+get next task :
+ get (system catalogue.dir, name, index) .
+
+no more task found : index = 0 .
+
+update station number of actual task :
+ write pcb (task id (index), myself no field, station number * 256 + index).
+
+update station number of supervisor :
+ write pcb (supervisor, myself no field, station number * 256 + sv no) .
+
+send define station message :
+ forget (sv space) ;
+ sv space := nilspace ;
+ INT VAR receipt ;
+ REP
+ send (supervisor, define station code+station number, sv space, receipt)
+ UNTIL receipt = ack PER .
+
+this is supervisor :
+ (pcb (myself no field) AND hex ff) = sv no .
+
+ENDPROC define station ;
+
+
+TASK OP / (INT CONST station number, TEXT CONST task name) :
+
+ IF station number = station (myself)
+ THEN task (task name)
+ ELSE get task id from other station
+ FI .
+
+get task id from other station :
+ enable stop ;
+ forget (sv space) ;
+ sv space := nilspace ;
+ BOUND TEXT VAR name message := sv space ;
+ name message := task name ;
+ INT VAR reply ;
+ call (collector, station number, sv space, reply) ;
+ IF reply = ack
+ THEN BOUND TASK VAR result := sv space ;
+ CONCR (result)
+ ELIF reply = error nak
+ THEN name message := sv space;
+ disable stop;
+ errorstop (name message) ;
+ forget (sv space) ;
+ niltask
+ ELSE forget (sv space);
+ errorstop ("Collector-Task fehlt") ;
+ niltask
+ FI
+
+ENDOP / ;
+
+
+TASK OP / (INT CONST station number, TASK CONST tsk):
+
+ station number / name (tsk)
+
+END OP / ;
+
+
+TEXT PROC external name (TASK CONST tsk):
+
+ IF tsk = nil task
+ THEN
+ ""
+ ELIF tsk = collector
+ THEN
+ "** collector **"
+ ELSE
+ name via net
+ FI.
+
+name via net:
+ enable stop ;
+ forget (sv space);
+ sv space := nil space;
+ BOUND TASK VAR task message := sv space;
+ task message := tsk;
+ INT VAR reply;
+ call (collector, 256, sv space, reply);
+ BOUND TEXT VAR result := sv space;
+ CONCR (result).
+
+END PROC external name;
+
+PROC write pcb (TASK CONST task, INT CONST field, value) :
+ EXTERNAL 105
+ENDPROC write pcb ;
+
+TASK PROC task (INT CONST channel number) :
+
+ IF channel number < 1 OR channel number > 32
+ THEN errorstop ("ungueltige Kanalnummer")
+ FI ;
+ forget (sv space) ;
+ sv space := nilspace ;
+ sv msg := sv space ;
+ sv msg.tname := text (channel number) ;
+ supervisor call (task of channel code) ;
+ sv msg := sv space ;
+ sv msg.task
+
+END PROC task;
+
+TASK PROC canal (INT CONST channel number) :
+
+ IF channel number < 1 OR channel number > highest terminal channel
+ THEN errorstop ("ungueltige Kanalnummer")
+ FI ;
+ forget (sv space);
+ sv space := nilspace ;
+ sv msg := sv space ;
+ sv msg.tname := text (channel number) ;
+ supervisor call (canal of channel code) ;
+ sv msg := sv space ;
+ sv msg.task
+
+END PROC canal ;
+
+PROC family password (TEXT CONST password) :
+
+ IF online
+ THEN say (""3""5""10"")
+ FI ;
+ forget (sv space) ;
+ sv space := nilspace ;
+ sv msg := sv space ;
+ sv msg.tpass := password ;
+ supervisor call (family password code) ;
+ cover tracks .
+
+ENDPROC family password ;
+
+INT PROC dataspaces (TASK CONST task) :
+
+ INT VAR ds number, spaces := 0 ;
+ FOR ds number FROM lowest ds number UPTO highest ds number REP
+ IF pages (ds number, index (task)) >= 0
+ THEN spaces INCR 1
+ FI
+ PER ;
+ spaces
+
+ENDPROC dataspaces ;
+
+INT PROC dataspaces :
+ dataspaces (myself)
+ENDPROC dataspaces ;
+
+INT PROC pages (INT CONST ds number, INT CONST task no) :
+ EXTERNAL 88
+ENDPROC pages ;
+
+ENDPACKET tasks ;
+
diff --git a/system/multiuser/1.7.5/src/ur start b/system/multiuser/1.7.5/src/ur start
new file mode 100644
index 0000000..efbf8c1
--- /dev/null
+++ b/system/multiuser/1.7.5/src/ur start
@@ -0,0 +1,40 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PROC begin process (TASK CONST father, son, INT CONST priv, PROCA CONST start) :
+ EXTERNAL 95
+ENDPROC begin process ;
+
+PROC ur :
+ TASK VAR dummy ;
+ begin ("PUBLIC", PROC public manager, dummy) ;
+ global manager (PROC ur manager)
+ENDPROC ur ;
+
+PROC public manager :
+
+ page ;
+ REP UNTIL yes("Archiv 'help' eingelegt") PER;
+ archive ("help") ;
+ fetch ("help", archive) ;
+ release (archive) ;
+ free global manager
+
+ENDPROC public manager ;
+
+PROC ur manager (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+
+ LET begin code = 4 ;
+ enable stop ;
+ IF order = begin code
+ THEN std manager (ds, order, phase, order task)
+ ELSE errorstop ("falscher Auftrag fuer Task ""UR""")
+ FI
+
+ENDPROC ur manager ;
+
+check on ;
+command dialogue (TRUE) ;
+begin process (supervisor, task ("UR"), 0, proca (PROC ur)) ;
+command dialogue (FALSE) ;
+check off;
+
diff --git a/system/net/1.7.5/doc/EUMEL Netz b/system/net/1.7.5/doc/EUMEL Netz
new file mode 100644
index 0000000..ad39db3
--- /dev/null
+++ b/system/net/1.7.5/doc/EUMEL Netz
@@ -0,0 +1,832 @@
+#type ("trium8")##limit (11.0)#
+#start(2.5,1.5)##pagelength (17.4)#
+#block#
+#headeven#
+
+% EUMEL-Netzbeschreibung
+
+
+#end#
+#headodd#
+
+#center#Inhalt#right#%
+
+
+#end#
+
+#type ("triumb12")#
+1. Einleitung
+
+
+Teil 1: Netz einrichten und benutzen
+#type ("trium8")#
+
+1. Benutzung des Netzes
+
+2. Hardwarevoraussetzungen
+
+3. Einrichten des Netzes
+
+4. Informationsmglichkeiten
+
+5. Eingriffsmglichkeiten
+
+6. Fehlerbehebung im Netz
+
+#type ("triumb12")#
+
+Teil 2: Arbeitsweise der Netzsoftware
+#type ("trium8")#
+
+1. Die Netztask
+
+2. Protokollebenen
+
+3. Stand der Netzsoftware
+
+#page#
+#headodd#
+
+#center#Einleitung#right#%
+
+
+#end#
+
+#type("triumb12")#
+1. Einleitung #type("trium8")#
+
+
+Das EUMEL-Netz dient dazu mehrere EUMEL-Rechner (sog. Stationen) mit-
+einander zu koppeln. Diese Kopplung wird von Betriebsystem dazu benutzt, das
+Sendungskonzept (siehe Systemhandbuch 1.7, Intertaskkommunikation) so auszu-
+dehnen, da Tasks verschiedener Stationen einander Datenrume zusenden
+knnen. Auf dem Sendungskonzept aufbauende Konzepte nutzen daher automa-
+tisch das Netz aus: So ist es z.B. mglich
+
+- von einer Station aus auf einer anderen zu Drucken,
+
+- in PUBLIC einer anderen Station Dateien zu sichern (save), vorausgesetzt, da
+ PUBLIC dort ein free global manager ist,
+
+- auf einer anderen Station zu archivieren (z.B. wenn das eigene Archivlaufwerk
+ defekt ist oder ein anderes Format hat).
+
+Das Netz kann ab EUMEL-Version 1.7.3 eingesetzt werden.
+
+
+#type("triumb12")#
+Teil 1: Netz einrichten und benutzen
+
+1. Benutzung des Netzes #type("trium8")#
+#headodd#
+
+#center#Teil 1: Netz einrichten und benutzen#right#%
+
+
+#end#
+
+ Zur Benutzung des Netzes stehen folgende Operatoren und Prozeduren zur
+ Verfgung:
+
+
+1.1
+
+ TASK OP / (INT CONST station, TEXT CONST taskname)
+
+ liefert die Task #on("bold")#taskname#off("bold")# von der Station #on("bold")#station#off("bold")#.
+
+ Wenn die Station #on("bold")#station#off("bold")# nicht am Netz ist oder nicht eingeschaltet ist, wird
+ solange gewartet, bis das der Fall ist.
+
+ Fehlerflle:
+
+ - task "..." gibt es nicht
+
+ Die angeforderte Task gibt es in der Zielstation nicht.
+
+ - Collectortask fehlt
+
+ Das Kommando #on("bold")#define collector#off("bold")# wurde nicht gegeben (siehe 4.2).
+
+ - Station x antwortet nicht
+
+ Eine nicht vorhandene oder abgeschaltete Station wurde angesprochen.
+ Hinweis: Dieser Fehler wird angenommen, wenn eine berwachungszeit
+ von ca. 30 Sekunden verschrichen ist, ohne da Station x die
+ Taskidentifikation angeliefert hat.
+
+ Beispiel:
+
+ list (5/"PUBLIC")
+
+ Dateiliste von PUBLIC auf Station 5 wird angefordert.
+
+1.2
+
+ TASK OP / (INT CONST station, TASK CONST task)
+
+ liefert
+
+ station / name (task) .
+
+
+ Beispiel:
+
+ list (4/archive)
+
+
+1.3
+
+ INT PROC station (TASK CONST task)
+
+ liefert die Stationsnummer der Task #on("bold")#task#off("bold")#.
+
+ Beispiel:
+
+ put (station (myself))
+
+ gibt die eigene Stationsnummer aus.
+
+
+1.4
+
+ PROC archive (TEXT CONST archivename, INT CONST station)
+
+ dient dazu das Archiv auf der Station #on("bold")#station#off("bold")# anzumelden.
+
+ Beispiel:
+
+ archive ("std", 4); list (4/archive)
+
+ gibt das Inhaltsverzeichnis der Archivfloppy im Laufwerk der Station 4 aus.
+ Hinweis: Vergessen Sie bei solchen Querarchivierungen nicht die Stations-
+ angabe bei jedem einzelnen Archivkommando (z.B fetch ("xxx", #on("bold")#4/#off("bold")#
+ archive).
+ Hinweis: Querarchivieren ist langsam. Verwenden Sie es nur, wenn Sie Flop-
+ pyformate umsetzen wollen.
+
+
+1.5
+
+ PROC free global manager
+
+ dient dazu, die eigene Task ber das Netz ansprechbar zu machen. Jede
+ andere Task im Netz kann dann die blichen Manageraufrufe ('save', 'fetch',
+ u.s.w.) an die eigene Task machen, sofern diese nicht an ein Terminal gekop-
+ pelt ist.
+
+ Die Task wird (wie bei 'break') abgekoppelt und meldet sich in Zukunft mit
+ 'maintenance' statt mit 'gib kommando'.
+
+ Beispiel:
+
+ An Station 4 ruft man in der Task 'hugo' das Kommando #on("bold")#free global manager#off("bold")#
+ auf. Anschlieend kann man von jeder Station aus z.B. 'list (4/"hugo")' u.s.w.
+ machen.
+
+
+1.6
+
+ TEXT PROC name (TASK CONST t)
+
+ Diese (schon immer vorhandene) Prozedur wurde dahingehend erweitert, da der
+ Name einer Task einer anderen Station ber Netz angefordert wird.
+
+ Fehlerfall:
+
+ Station x antwortet nicht
+
+
+
+
+#type("triumb12")#2. Hardwarevoraussetzungen#type("trium8")#
+
+2.1 Zwei Stationen
+
+ Sie knnen zwei Stationen miteinander Vernetzen, wenn Sie dafr an jeder
+ Station eine V24-Schnittstelle zur Verfgung stellen.
+
+ Diese beiden Schnittstellen verbinden Sie mit einem Kabel zur Rechner-
+ kopplung (siehe Systemhandbuch 1.7 Teil 2).
+
+2.2 Mehrere Stationen
+
+ Wenn Sie mehr als zwei Stationen vernetzen wollen, brauchen neben je
+ einer V24 an jeder Station noch je eine Netzanschlubox.
+
+ Jede Box besitzt eine V24-Schnittstelle zum Anschlu an die V24-
+ Schnittstelle der zugeorneten Station und eine weitere Schnittstelle zur
+ Verbindung der Boxen untereinander.
+
+
+#type("triumb12")#3. Einrichten des Netzes #type("trium8")#
+
+Hinweis: Dieses Kapitel ist nur fr Systembetreuer wichtig.
+
+3.1 Legen Sie Stationsnummern fr die am Netz beteiligten Rechner fest (von 1 an
+ aufsteigend).
+
+ Die Boxen haben ebenfalls Stationsnummern. Die Stationsnummern der Box
+ und des zugeordneten Rechners mssen bereinstimmen.
+
+
+3.2 Holen Sie an jeder Station die Task #on("bold")#configurator#off("bold")# an ein Terminal und geben Sie
+ das Kommando #on("bold")#define collector ("net port")#off("bold")#. Geben Sie auerdem das
+ Kommando #on("bold")#define station (x)#off("bold")#, wobei #on("bold")#x#off("bold")# die gewhlte Stationsnummer ist.
+
+ Hinweis: Taskkommunikationen, die zu dem Zeitpunkt laufen, fhren zu feh-
+ lerhaften Verhalten. Dies liegt daran, da durch #on("bold")#define station#off("bold")# alle
+ Task-Id's gendert werden mssen, weil eine Task-Id u.a. die
+ Stationsnummer der eigenen Station enthlt (siehe 2.3). TASK-
+ Variable, die noch Task-Id's mit keiner oder falscher Stationsnum-
+ mer enthalten, knnen nicht mehr zum Ansprechen einer Task
+ verwendet werden.
+
+ Beispiel: Der Spoolmanager (siehe Benutzerhandbuch 1.7 Teil 12) richtet
+ beim Kommando #on("bold")#start#off("bold")# einen Worker ein und merkt sich dessen
+ Task-Id in einer TASK-Variablen, um sicherzustellen, da nur der
+ Worker Dateien zum Drucken abholt. Wird jetzt das Kommando #on("bold")#
+ define station#off("bold")# gegeben, kann der Spoolmanager seinen Worker
+ nicht mehr identifizieren, weil der Worker eine neue Task-Id er-
+ halten hat. Man mu daher den Worker lschen und mit dem
+ Kommando #on("bold")#start#off("bold")# im Spoolmanager wieder neu einrichten.
+
+
+ Sinnvollerweise gibt man #on("bold")#define station#off("bold")# sofort nach den Laden eines
+ frischen Systems von Archiv.
+
+ Konfigurieren Sie mit dem Kommando #on("bold")#configurate#off("bold")# den fr das Netz vorgese-
+ henen Kanal auf
+
+ - transparent
+ - 9600 Baud (Standardeinstellung der Boxen)
+ - RTS/CTS-Protokoll
+ - groen Puffer
+ - 8 bit
+ - even parity
+ - 1 stopbit.
+
+ Falls diese Einstellungen nicht alle angeboten werden, klren Sie mit Ihrem
+ Rechnerlieferanten, ob und wie diese Einstellungen erreicht werden knnen.
+ Hinweis: Notfalls kann auf das RTS/CTS-Protokoll verzichtet werden, wenn
+ der Eingabepuffer der Station gro genug ist. Die Anzahl simultan
+ laufender Netzkommunikationen ist dann auf
+
+ puffergre DIV 150
+
+ begrenzt (bei Z80, 8086: 3; bei M20: 10).
+ Hinweis: Es knnen auch andere Baudraten (2400, 4800, 19200) an der Box
+ eingestellt werden.
+
+3.3 Achten Sie bei der Verbindung von der Station zur Netzbox (bzw. zur Gegen-
+ station bei einem Zweistationennetz ohne Boxen) darauf, da neben den
+ Empfangs- und Sendeleitungen auch die Leitungen RTS und CTS verdrahtet
+ werden, also ein 5 poliges Kabel verwendet wird (siehe Systemhandbuch 1.7
+ Teil 2). Die Pin-Belegung der Boxen entspricht den dortigen Angaben.
+
+ Beispiel:
+
+ Verbindung eines CSK-Systems mit der Box:
+
+ Stecker Stecker
+ Pin Pin
+
+ 2 <---------> 3
+ 3 <---------> 2
+ 4 <---------> 5
+ 5 <---------> 4
+ 7 <---------> 7
+
+
+3.4 Richten Sie eine Task #on("bold")#net#off("bold")# unter #on("bold")#SYSUR#off("bold")# ein und insertieren Sie dort die Datei-
+en
+
+ net report/M
+ basic net
+ net manager/M.
+
+ Beantworten Sie die Frage nach dem Kanal fr das Netz und nach der Flu-
+ kontrolle (RTS/CTS).
+
+
+#type("triumb12")#4. Informationsmglichkeiten #type("trium8")#
+
+ In der Task #on("bold")#net#off("bold")# wird eine Datei #on("bold")#report#off("bold")# gefhrt in der Fehlersituationen des
+ Netzes verzeichnet werden. Diese Datei kann in jeder anderen Task mit #on("bold")#list
+ (/"net")#off("bold")# angezeigt werden.
+
+ In jeder Task kann durch das Kommando #on("bold")#list (/"net port")#off("bold")# eine bersicht ber
+ die momentan laufenden Netzbertragungen der eigenen Station erhalten
+ werden.
+
+
+#type("triumb12")#5. Eingriffsmglichkeiten #type("trium8")#
+#headodd#
+
+#center#Eingriffsmglichkeiten#right#%
+
+
+#end#
+
+5.1 Jede Task kann Sende- und Empfangsstrme, die bei #on("bold")#list (/"net port")#off("bold")# gemel-
+ det worden sind und die eigene Task betreffen, abbrechen. Hierzu ist das
+ Kommando #on("bold")#erase ("x",/"net port")#off ("bold")# zu geben, wobei x die Stromnummer (aus
+ dem 'list') ist.
+
+ Unberechtigte Lschversuche werden abgewiesen.
+
+ Von der Task 'net' aus knnen jedoch damit beliebige Strme abgebrochen
+ werden.
+
+5.2 Durch das Kommando #on("bold")#start#off("bold")# kann von der Task 'net' aus das Netz neu gestartet
+ werden. Dabei werden alle augenblicklichen Netzkommunikationen gelscht.
+ Die Tasks 'net port' und 'net timer' werden dabei gelscht und neu eingerich-
+ tet.
+
+ #on("bold")#start (kanal, quit)#off("bold")# wirkt wie #on("bold")#start#off("bold")#. Zustzlich wird als Netzkanal 'kanal' eingestellt
+ und maximal 'quit' Empfangsstrme zugelassen. 'quit' ist auf 3 zu setzen,
+ wenn der Kanal ohne RTS/CTS angeschlossen ist (siehe 3.2).
+
+
+#type("triumb12")#6. Fehlersuche im Netz #type("trium8")#
+
+ Fehler im Netz knnen sich verschiedenartig auswirken. Im Folgenden wird auf
+ einige Beispiele eingegangen:
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Station 4 antwortet nicht'.
+
+ Fehlermglichkeiten:
+
+ - Station 4 gibt es nicht am Netz.
+ Abhilfe: Richtige Station angeben.
+
+ - Station 4 ist nicht eingeschaltet.
+ Abhilfe: Station 4 einschalten. Kommando erneut geben.
+
+ - Netztask an Station 4 ist nicht arbeitsfhig.
+ Abhilfe: Kommando 'start' in der Task 'net'.
+
+ - Stationsnummern und Boxnummern stimmen nicht berein.
+ Abhilfe: Mit 'define station' Stationsnummern korrigieren (siehe 3.2).
+
+ - Verbindung Rechner/Box am eigenen Rechner oder an Station 4 fehlt.
+ Abhilfe: Verbindungen berprfen. Durch Ansprechen einer dritten Station
+ kann oft schnell geklrt werden, welche Rechner/Box-Verbindung
+ defekt sein mu.
+
+ - Verbindung der Boxen untereinander defekt.
+ Abhilfe: Fehlende Verbindung, Masseschlu und Dreher (keine 1:1 Ver-
+ bindung) berprfen und beheben.
+ Hinweis: Liegt z.B. ein Masseschlu vor, so kann es durchaus sein, da
+ Boxen, die nicht in der Nhe des Masseschlu stehen noch mitei-
+ nander arbeiten knnen. Man kann aus der Tatsache, da zwei
+ Boxen miteinander arbeiten knnen, also nicht schlieen, da man
+ nicht nach diesem Fehler suchen mu.
+
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt keine Reaktion.
+
+
+ - Station 4 ist whrend dieser Sendung zusammengebrochen.
+ Abhilfe: Station 4 wieder starten. Die Bearbeitung des 'list'-Kommandos
+ wird automatisch wieder aufgenommen.
+
+ - PUBLIC auf Station 4 ist nicht im Managerzustand.
+ Abhilfe: PUBLIC in den Managerzustand versetzen.
+
+
+ Hinweis: Das Netz hat nocht nicht die volle Sendungslogik des EUMEL. So
+ wird nur ca. 10 Minuten lang versucht, eine Sendung zuzustellen.
+ Danach wird die Sendung gelscht. Ist dies eingetreten, so mu
+ das list-Kommando erneut gegeben werden.
+
+ - Fehler in der Netzhardware.
+ berprfen Sie, ob
+
+ - die Boxen eingeschaltet sind,
+ - die Bereitlampe blinkt (wenn nicht: RESET an der Box)
+ - die V24-Kabel richtig stecken,
+ - die Boxen untereinander verbunden sind (1 zu 1 Verbindungen der 5
+ poligen Diodenbuchsen).
+
+
+ - Die Netzsoftware ist auf einen nicht vorhergesehenen Fehler gelaufen.
+ Dieser wird im Report vermerkt.
+ Abhilfe: Geben Sie in der Task #on("bold")#net#off("bold")# das Kommando #on("bold")#start#off("bold")#. Dadurch wird die
+ Netzsoftware neu gestartet. Alle Netzkommunikationen dieser
+ Station gehen verloren.
+
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Collectortask fehlt'.
+
+ - In der Task 'configurator' wurde das Kommando 'define collector' (siehe 3.2)
+ nicht gegeben.
+
+ - Die Task 'net port' existiert nicht mehr.
+ Abhilfe: Kommando 'start' in der Task 'net'.
+
+
+ Beispiel:
+
+ Nach #on("bold")#fetch ("hugo",4/public)#off("bold")# sind Teile von der Datei "hugo" verflscht.
+
+ - Die V24-Verbindung zur Box ist nicht in Ordnung.
+ Abhilfe: Abstand zwischen Rechner und Box verkrzen; Baudrate ernie-
+ drigen; Durch Wechseln der V24-Schnittstelle feststellen, ob
+ diese defekt ist.
+ Hinweis: Die Verbindung zwischen den Boxen ist durch Prfsummen abge-
+ sichert (Hardware).
+
+#headodd#
+
+#center#Teil 2: Arbeitsweise der Netzsoftware#right#%
+
+
+#end#
+#page#
+#type("triumb12")#
+
+Teil 2: Arbeitsweise der Netzsoftware
+
+
+1. Die Netztask #type ("trium8")#
+
+In diesem Kapitel wird beschrieben, wie eine Netztask in das System
+eingebettet ist und welche Aufgaben sie hat. Unter Einhaltung dieser
+Konzepte kann die ausgelieferte Netztask so gendert werden, da sie
+beliebige andere Netzhardware untersttzt. Z.Zt. ist die Netzsoftware noch
+nicht so gegliedert, da nur eine hardwareabhngige Komponente ausgetauscht
+werden mu.
+
+Die Kommunikation zwischen Tasks im EUMEL-Betriebssystem basiert auf einem
+Rendevouskonzept: Die Zieltask einer Sendung mu empfangsbereit sein, wenn die
+Quelltask sendet.
+
+Die Kommunikationsprozeduren auf der niedrigsten Ebene sind 'send' (Senden)
+und 'wait' (Warten auf Empfang). Bei der Kommunikation werden eine Integer
+'code' und ein Datenraum 'dr' bergeben. 'code' mu >= 0 sein, da negative
+Codes systemintern verwandt werden. Ist die empfangende Task an einen Kanal
+gekoppelt ('continue'), so fhrt eine Zeicheneingabe auf diesem Kanal dazu,
+da eine
+Sendung mit dem Code -4 ankommt. Die Eingabedaten mssen mit den blichen
+Eingabeprozeduren ('inchar' u.s.w.) abgeholt werden. Der bermittelte Datenraum
+und die Absendertask sind dabei ohne Bedeutung und drfen nicht interpretiert
+werden.
+
+Die Prozedur 'send' hat einen Rckmeldeparameter, der besagt, ob die Sendung
+bermittelt wurde. Gibt es die Zieltask nicht oder steht sie nicht im 'wait', so kann
+die Sendung nicht bermittelt werden.
+
+
+Ein Entwicklungskriterium fr das EUMEL-Netz war es, mglichst wenig Unter-
+sttzung von der virtuellen EUMEL-Maschine (EUMEL0) zu fordern, damit weit-
+gehend in ELAN programmiert werden kann. Dadurch ist es mglich eine (privili-
+gierte) Task mit der Netzabwicklung zu betrauen.
+
+Zunchst wird auf die EUMEL0-Untersttzung eingegangen:
+
+1.1. Es gibt die Prozedur 'define collector', mit der die fr das Netz verantwort-
+ liche Task der EUMEL0-Maschine bekannt gemacht wird. Diese Task wird im
+ folgenden Collector genannt.
+
+1.2. Es gibt die Prozedur 'define station', die fr den Rechner eine Stationsnum-
+ mer einstellt. Anhand dieser Nummer werden die Rechner eines Netzes un-
+ terschieden. Das Einstellen bewirkt, da fr alle Tasks die Stationsnummer in
+ ihre Task-Id eingetragen wird (Task-Id's sind die Werte, die der Typ TASK
+ annehmen kann).
+
+1.3. Der Befehl 'station (task)' liefert die Stationsnummer der 'task'. So liefert z.B.
+ 'station (myself)' die Stationsnummer des eigenen Rechners.
+
+1.4. Eine Sendung, deren Zieltask in einem anderen Rechner liegt (also station
+ (ziel) <> station (myself)), wird auf die Collectortask geleitet.
+
+1.5. Es gibt eine Prozedur 'collected destination', die es dem Collector erlaubt, die
+ eigentliche Zieltask einer auf ihn geleiteten Sendung zu erfahren.
+
+1.6. Es gibt eine Variante der Prozedur 'send', die es dem Collector gestattet, der
+ Zieltask eine beliebige andere Task als Absender vorzumachen.
+
+1.7. Es gibt eine spezielle Task-Id 'collector', durch die der augenblicklich ein-
+ gestellte Collector erreicht wird. Diese wird als Zieltask beim Aufruf der Ver-
+ mittlungsdienste angegeben (siehe 2.5). Eine Sendung an 'collector' wird von
+ EUMEL0 an den derzeitigen Collector geschickt.
+
+Ein Collector kann also auf drei Wegen von den brigen Tasks desselben Rechners
+Sendungen erhalten:
+
+ 1. ber ein normales Send (z.B. bei 'list (/"net port")', wenn "net port" der der-
+ zeitige Collector ist),
+
+ 2. ber ein Send an die Task 'collector' (s.u.) und
+
+ 3. als umgeleitete Sendung (z.B. bei 'list' an eine Task auf einem anderen
+ Rechner).
+
+Der Collector kann diese Flle anhand von 'collected destination' unterscheiden.
+
+Die Punkte 1.4...1.6 dienen dazu, den Collector fr ber Netz kommunizierende
+Task unsichtbar zu machen: Der Collector taucht nicht als Ziel oder Quelle von
+Sendungen auf. Das ist notwendig, damit normale Tasks sich nicht darum kmmern
+mssen, ob eine Sendung bers Netz geht oder im eigenen Rechner bleibt.
+
+Wenn ein Datenraum an einen anderen Rechner geschickt wird, mu der gesamte
+Inhalt (z. Zt. max. 1 MB) bertragen werden. Dies macht bei der blichen Netz-
+hardware eine Zerlegung in Packete ntig (siehe Systemhandbuch 173, Teil 4,
+Punkt 5). Fr Netze ber V24-Kanle stehen spezielle Blockbefehle zur verf-
+gung:
+
+1.8. blockin / blockout (dr,seite,512+abstand,anzahl,rest)
+
+ Es werden maximal 'anzahl' Bytes transferiert. In 'rest' wird zurckgemeldet,
+ wieviel Bytes nicht bearbeitet wurden (z.B. weil der Kanal nichts anliefert).
+ Bearbeitet werden die Bytes
+
+ 'seite' * 512 + 'abstand'
+
+ bis maximal
+
+ 'seite' * 512 + 'abstand' + 'anzahl' - 1
+
+ Der Kanal, an den die Task gekoppelt ist, wird dabei ber Stream-IO (d.h.
+ 'incharety' bei 'blockin' bzw. 'out' bei 'blockout') angesprochen.
+
+ Hinweis: Die Anforderung darf nicht ber Seitengrenze gehen, d.h.
+
+ 'abstand' + 'anzahl' <= 512
+
+ mu erfllt sein.
+
+
+Eine Netzsendung luft wie folgt ab:
+
+Die Task q auf Rechner rq mache ein 'send' an die Task z auf Rechner rz.
+
+1. Die Prozedur send ist ein EUMEL0-Befehl. Die EUMEL0-Ebene erkennt, da
+ die Sendung an die Station rz geht, da die Stationsnummer in der Task-Id
+ enthalten ist. Daher wird die Sendung zum Collector, den EUMEL0 wegen 'de-
+ fine collector' kennt, umgeleitet.
+
+2. Die Task Collector empfngt ber 'wait' den Datenraum, den Sendecode und
+ die Absendertask q. Die Zieltask z erfhrt sie durch 'collected destination'.
+
+3. Der Collector nimmt Kontakt mit dem Collector des Rechner rz, dessen Sta-
+ tionsnummer ja 'station(z)' ist, auf und bermittelt diesem Sendecode, Quelltask
+ (q), eigentliche Zieltask (z) und den Datenraum. Da die Collectoren in ELAN
+ geschrieben sind, knnen sie an beliebige Netzhardware und Protokolle ange-
+ pat werden.
+
+4. Der Collector auf Rechner rz verwendet das spezielle 'send', um der Zieltask die
+ Sendung zuzustellen. Dadurch erscheint nicht der Collector sondern die Task q
+ als Absender der Sendung.
+
+Zur Abwicklung der Vermittlungsebene (Teil 1: 2.4) mu der Collector noch
+spezielle Funktionen beherrschen. Diese sind
+
+ der /-Operator (Taskname in Task-Id wandeln) und
+ die name-Prozedur (Task-Id in Namen wandeln).
+
+Der /-Operator macht eine Sendung an den 'collector', wobei im Datenraum der
+Name der Task steht und der Sendecode gleich der Stationsnummer ist (siehe
+Quellcode 173, Packet tasks). Der Collector setzt sich mit dem Collector dieser Sta-
+tion in Verbindung, damit dieser die Task-Id ermittelt und zurckschickt. Der
+eigene Collector schickt dann dem /-Operator als Antwort einen Datenraum, der
+die Task-Id enthlt.
+
+Umgekehrt luft 'name' ab: Wenn die Task-Id von einer fremden Station ist,
+schickt 'name' eine Sendung an den 'collector', wobei im Datenraum die Task-Id
+steht und Sendecode = 256 ist. Der Collector entnimmt die Stationnummer der
+Task aus der Task-Id und lt sich vom entsprechenden Collector den Tasknamen
+geben. Dieser wird der 'name'-Prozedur im Antwortdatenraum bergeben.
+
+#type ("triumb12")#2. Ebenen #type("trium8")#
+
+In diesem Kapitel werden die Protokollebenen fr das Netz beschrieben, wie
+sie die ausgelieferte Netzsoftware benutzt und erwartet. Bei anderer
+Netzhardware mssen die Ebenen 1 bis 3 ausgetauscht werden. Unter Einhaltung
+der im vorigen Kapitel beschriebenen Randbedingungen knnen auch die hheren
+Ebenen gendert werden.
+
+
+2.1 Physikalische Ebene
+
+ 2.1.1 Station <--> Box
+
+ V24-Schnittstelle mit RTS/CTS-Handshake. Vollduplex.
+
+ 2.1.2 Box <--> Box
+
+ RS422 ber 2 verdrillte Leitungspaare (Takt und Daten).
+
+2.2 Verbindungsebene
+
+ 2.2.1 Station <--> Box
+
+ Asynchron
+ 8 Bit
+ Even Parity
+ 2400/4800/9600/19200 Baud (einstellbar ber Ltbrcken)
+
+ 2.2.2 Box <--> Box
+
+ SDLC
+ 400 KBaud
+
+2.3 Netzebene
+
+ 2.3.1 Station <--> Box
+
+ Telegrammformat: STX, <n>, <ziel>, <quelle>, <(n-4) byte>
+
+ <n> ist Lngenangabe ( 8 <= n <= 160)
+ <ziel>, <quelle> sind Stationsnummern. Diese mssen an den je-
+ weiligen Boxen ber Ltbrcken eingestellt sein.
+
+ Box --> Station:
+
+ Ein Telegramm kommt nur bei der Station an, bei deren Box die
+ Nummer <ziel> eingestellt ist. Dadurch ist ein Mithren fremder
+ bertragungen nicht mglich (Datenschutz).
+
+ Zwischen Telegrammen knnen Fehlermeldungen der Box (Klartext)
+ bermittelt werden (z.B. 'skipped x', wenn ein STX von der Box er-
+ wartet wurde, aber 'x' von der Station ankommt).
+
+ Station --> Box:
+
+ Ein Telegramm wird nur abgeschickt, wenn <quelle> mit der einge-
+ stellten Nummer bereinstimmt (Datenschutz: Man kann nicht eine
+ beliebige Station zu sein vorschwindeln, es sei denn man hat physi-
+ schen Zugriff zur Box und stellt dort die Stationsnummer um).
+
+ 2.3.2 Box <--> Box
+
+ Telegrammformat: FRAME, <ziel>, <quelle>, <daten> ,
+ <CRC-Code>
+
+ Eine Lngenangabe ist nicht ntig, da SDLC eine Rekonstruktion der
+ Lnge erlaubt.
+
+ Telegramme mit falschen CRC-Code werden vernichtet. Auf hheren
+ Ebenen mu dies durch Zeitberwachung erkannt und behandelt
+ werden.
+
+
+2.4 Transportebene
+
+ Diese Ebene wickelt das Rendevous zwischen einer Task, die 'send' macht,
+ und einer Task, die im 'wait' steht, ab (siehe: EUMEL-Systemhandbuch).
+
+ Der im 'send' angegebene Datenraum wird als Folge von Seiten (im
+ EUMEL-Sinne: Pagingeinheit und Allokiereinheit) bermittelt, wobei jede Seite
+ noch in 64 Byte groe Stcke zerlegt wird. Es werden nur echt allokierte Seiten
+ bermittelt. Um nicht jedes Telegramm voll qualifizieren zu mssen, wird
+ zunchst eine Art virtuelle Verbindung durch ein OPEN-Telegramm erffnet.
+ Danach folgen variable viele DATA-Telegramme. Beide Sorten werden durch
+ QUIT-Telegramme quittiert, um folgende Funktionen zu ermglichen:
+
+ Flukontrolle (z.B. Zielrechner langsam)
+ Wiederaufsetzen (verlorene Telegramme)
+ Abbruch (z.B. weil Zieltask inzwischen beendet).
+
+ Ein CLOSE-Telegramm ist nicht ntig, da das letzte DATA-Telegramm als
+ solches erkannt werden kann (siehe unten).
+
+ 2.4.1 OPEN-Telegramm
+
+ STX, 20, <ziel>, <quelle>, <strom>, <sequenz>, <seite>,
+ <quelltask>, <zieltask>, <code>
+
+ <ziel>, <quelle> siehe 2.3.1
+
+ <strom> Die Stromnummer identifiziert die virtuelle Verbindung.
+ Sie mu in den QUIT-Telegrammen angegeben wer-
+ den.
+
+ <sequenz> -1 (Kennzeichen fr OPEN)
+
+ <seite> Nummer der ersten echt allokierten Seite des Datenra-
+ ums (=-1, falls Nilspace)
+
+ <quelltask> Taskid der sendenden Task
+
+ <zieltask> Taskid der empfangenden Task
+
+ <code> Wert des im 'send' angegebenen Codes.
+
+ 2.4.2 DATA-Telegramm
+
+ STX, 74, <ziel>, <quelle>, <sequenz>, <seite>, <64 byte>
+
+ <sequenz> wird von Telegramm zu Telegramm hochgezhlt. Dient
+ der berwachung gegen verlorengegangene Telegramme
+ bzw. durch Zeitberwachung verdoppelter Telegramme.
+
+ <seite> Nummer der x.ten echt allokierten Seite des Datenra-
+ ums. (x = (<sequenz>+16) DIV 8).
+
+ <64 byte> Nutzinformation. Diese gehrt zur Adresse a des Daten-
+ raums.
+
+ a = N (<sequenz> DIV 8 + 1) * 512
+ + (<sequenz> MOD 8) * 64
+
+ wobei N (x) die Nummer der x.ten Seite ist.
+
+ Aus den Formeln ergibt sich, da diese Nummer schon in
+ einem vorhergehenden DATA/OPEN-Telegramm ber-
+ mittelt wurde (im Feld <seite>).
+
+ 2.4.3 QUIT-Telegramm
+
+ STX, 8, <ziel>, <quelle>, <strom>, <quit>
+
+ <strom> mu die Stromnummer sein, die in dem OPEN/DATA-
+ Telegramm stand, das quittiert wird.
+
+ <quit> 0 : ok. Nchstes Telegramm schicken.
+
+ -1: bertragung neu starten (mit OPEN), weil die
+ Empfangsstation das OPEN nicht erhalten hat.
+
+ -2: bertragung ca. 20 Telegramme zurcksetzen.
+
+ -3: bertragung abbrechen.
+
+
+2.5 Vermittlungsebene
+
+ Diese Ebene ist dafr zustndig, Tasknamen von Task auf anderen Stationen
+ in Taskids (Werte des Typs TASK) zu wandeln und umgekehrt. Hierzu wird im
+ entsprechenden OPEN-Telegramm der Code -6 (bzw. -7) als <code>
+ eingetragen. Die Netzempfangstask erkennt diese Codes und wickelt die
+ Aufgaben selbst ab, soda es dabei nicht ntig ist, irgendeine Taskid der
+ Zielstation zu kennen.
+
+ Dieses Verfahren ist mglich, weil im 'send' nur positive Codes erlaubt sind.
+
+2.6 Hhere Ebenen
+
+ Hhere Ebenen sind nicht mehr netzspezifisch. Sie basieren alle auf dem
+ Send/Wait-Konzept des EUMEL. So gibt es z.B. den 'global manager', der
+ Aufbewahrung und Zugriff von Dateien in einer Task regelt. Dabei darf diese
+ Task (bei der Variante 'free global manager') auf einer beliebigen Station im
+ Netz liegen. Wegen des Rendevous-Konzepts knnen beliebige Sicherheit-
+ strategien benutzt werden (z.B.: Keine Dateien an Station 11 ausliefern). Von
+ groen Wert ist z.B., da man ohne weiteres das Archiv (Floppylaufwerk) einen
+ anderen Station anmelden und benuzten kann, wodurch eine einfache Kon-
+ vertierung von Floppyformaten mglich ist. Dies ist mglich, weil auch die Ar-
+ chiv-Task der Stationen sich an das Globalmanagerprotokoll halten.
+
+
+#type("triumb12")#
+Bemerkungen#type("trium8")#
+
+Fehlerbehandlung besteht bis Ebene 3 darin, fehlerhafte Telegramme einfach zu
+entfernen. Die Ebene 4 berwacht den Netzverkehr sowieso ber Timeouts, die
+eine Wiederhohlung eines Telegrammes bewirken, wenn die Quittung ausbleibt.
+
+Da bei der sendenden Station der ganze Datenraum zur Verfgung steht, ist eine
+Fenstertechnik (wie bei HDLC) nicht ntig. Es kann zu jedem Zeitpunkt um beliebig
+viele Telegramme zurckgesetzt werden.
+
+Da im EUMEL eine Textdatei ein Datenraum mit sehr komplexer Struktur ist (wegen
+der Insert/Delete-Mglichkeiten, ohne den Rest der Datei zu schieben), ist es ein
+hoher Aufwand, von einem fremden Betriebssytem her Textdateien ins EUMEL-
+Netz zu senden. Fr solche Zwecke mu noch eine einfachere Dateistruktur defi-
+niert werden und entsprechende Dateikonverter erstellt werden.
+
+
+
+#type("triumb12")#3. Stand der Netzsoftware #type("trium8")#
+
+Das EUMEL-System wickelt die Prozedur #on("bold")#send#off("bold")# ber das Netz ab, wenn die
+Stationsnummer der Zieltask ungleich der eigenen Stationsnummer ist. Umge-
+kehrt kann man der von der Prozedur #on("bold")#wait#off("bold")# gelieferten Absendertask die Absen-
+derstation entnehmen (siehe Prozedur #on("bold")#station#off("bold")# in Abschnitt 3).
+
+Nicht untersttzt wird z.Zt. die Logik der Prozeduren #on("bold")#call#off("bold")# und #on("bold")#pingpong#off("bold")#. Diese
+funktionieren nur in der gewohnten Weise, wenn die Zieltask in #on("bold")#wait#off("bold")# steht. Ist
+die Zieltask lnger als ca. 10 Minuten #on("bold")#busy#off("bold")# oder nicht mehr vorhanden, geht die
+Sendung einfach verloren (Gefordert ist: bei #on("bold")#call#off("bold")#: immer wieder versuchen; bei #on("bold")#
+pingpong#off("bold")#: Rckmeldung -2).
+
+Wegen dieser Einschrnkung kann man z.B. ein sicheres Drucken von Station a
+auf einen Drucker der Station b nur durch einen eigenen Spoolmanager auf
+Station a verwirklichen. Die Einrichtung eines solchen Managers ist allerdings
+sowieso sinnvoll, damit man
+
+- das normale 'print'-Kommando verwenden kann (statt z.B. save ("xxx",
+4/printer);) und
+- nicht zu warten braucht, bis die Datei bers Netz gesendet ist.
+
+
+
+
+
diff --git a/system/net/1.7.5/src/basic net b/system/net/1.7.5/src/basic net
new file mode 100644
index 0000000..41c8402
--- /dev/null
+++ b/system/net/1.7.5/src/basic net
@@ -0,0 +1,840 @@
+PACKET basic net DEFINES (* D. Heinrichs *)
+ (* 02.10.85 *)
+ nam,
+ max verbindungsnummer,
+ neuer start,
+ packet eingang,
+ neue sendung,
+ zeitueberwachung,
+ verbindung,
+ loesche verbindung:
+
+TEXT PROC nam (TASK CONST t):
+ IF t = collector THEN name (t)
+ ELIF station (t) <> station (myself)
+ THEN "** fremd **"
+ ELSE name (t)
+ FI
+END PROC nam;
+
+INT PROC tasknr (TASK CONST t):
+ IF t = collector THEN maxtasks
+ ELSE index (t)
+ FI
+END PROC tasknr;
+
+LET
+ maxtasks = 127,
+ max strom = 20,
+ max strom 1 = 21,
+ stx = ""2"",
+ code stx = 2,
+ ack = 0,
+ nak = 1,
+ error nak = 2,
+ zeichen eingang = 4,
+ list code = 15,
+ fetch code = 11,
+ inspect code = 30,
+ continue code = 100,
+ erase code = 14,
+ report code = 99,
+ seiten groesse = 512,
+ dr verwaltungslaenge = 8,
+ dr verwaltungslaenge2=10,
+ nutzlaenge = 64,
+ openlaenge = 20,
+ vorspannlaenge = 10,
+ neue ack laenge = 10,
+ ack laenge = 8,
+
+ (* Typen von Kommunikationsstrmen *)
+
+ send wait = 0,
+ zustellung = 1,
+ call pingpong = 2,
+ call im wait = 3,
+ call im abbruch = 4,
+ call in zustellung = 5,
+
+ (*quittungscodes*)
+
+ ok = 0,
+ von vorne = 1,
+ wiederhole = 2,
+ loesche = 3,
+ beende = 4;
+
+LET STEUER =
+ STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ sequenz,
+ seitennummer,
+ TASK quelle,ziel,
+ INT sende code);
+
+BOUND STEUER VAR open block;
+
+BOUND STRUCT (STEUER steuer, INT typ) VAR info block;
+
+BOUND STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ sequenz,
+ seitennummer) VAR vorspann ;
+
+BOUND STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ code) VAR ack packet ;
+
+INT CONST max verbindungsnummer := max strom;
+
+BOOL PROC blockin (DATASPACE VAR ds, INT CONST seite, abstand, laenge):
+ INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512;
+ REAL VAR time out := clock (1) + 10.0;
+ REP
+ blockin (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge);
+ UNTIL hilfslaenge = 0 OR clock (1) > time out PER ;
+ hilfslaenge = 0
+END PROC blockin;
+
+PROC blockout (DATASPACE CONST ds, INT CONST seite, abstand, laenge):
+ INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512;
+ REP
+ blockout (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge);
+ UNTIL hilfslaenge = 0 PER
+END PROC blockout;
+
+
+
+
+DATASPACE VAR work space;
+
+
+INT CONST packete pro seite:= seitengroesse DIV nutzlaenge,
+ packete pro seite minus 1 := packete pro seite -1,
+ datenpacketlaenge := vorspannlaenge + nutzlaenge;
+
+INT VAR err,strom;
+
+INT VAR own:=station (myself) ,
+ quit max := 3,
+ quit zaehler := 3,
+ own256 := 256*own;
+INT CONST stx open := code stx+256*openlaenge,
+ stx quit := code stx+256*acklaenge;
+
+ ROW maxstrom1 STEUER VAR verbindungen;
+ ROW maxstrom1 DATASPACE VAR netz dr;
+ ROW maxstrom1 INT VAR zeit, typ;
+ FOR strom FROM 1 UPTO maxstrom1 REP vdr := nilspace; forget (vdr) PER;
+ ROW maxstrom INT VAR dr page ;
+ ROW maxtasks INT VAR alter call;
+ STEUER VAR opti;
+
+.vx : verbindungen (strom).
+
+vdr: netz dr (strom).
+
+falsche stromnummer: strom < 1 OR strom > maxstrom.
+
+call aufruf: typ(strom) >= call pingpong.
+
+alles raus: vx.seitennummer = -1 AND letztes packet der seite .
+
+letztes packet der seite :
+(vx.sequenz AND packete pro seite minus 1) = packete pro seite minus 1.
+
+PROC neuer start (INT CONST empfangsstroeme):
+ workspace := nilspace;
+ open block := workspace;
+ info block := workspace;
+ vorspann := workspace;
+ ack packet := workspace;
+ FOR strom FROM 1 UPTO maxstrom1 REP
+ vx.strom := 0; forget (vdr)
+ PER;
+ INT VAR i;
+ FOR i FROM 1 UPTO maxtasks REP alter call (i) := 0 PER;
+ quitmax := empfangsstroeme;
+ own:=station (myself);
+ quit zaehler := quit max;
+ own256 := 256*own;
+ reset box.
+
+reset box:
+ out (90*""4"");
+ REP UNTIL incharety (1) = "" PER.
+
+END PROC neuer start;
+
+DATASPACE PROC verbindung (INT CONST nr):
+ infoblock.steuer := verbindungen (nr);
+ infoblock.typ := typ (nr);
+ workspace
+END PROC verbindung;
+
+PROC neue sendung (TASK CONST q,z, INT CONST cod, DATASPACE CONST dr):
+
+ naechste verbindung vorbereiten;
+ forget (vdr); vdr := dr;
+ IF z = collector
+ THEN
+ verbindungsebene
+ ELSE
+ sendung starten (q,z,cod)
+ FI.
+
+verbindungsebene:
+ IF cod = 256 THEN name von fremdstation
+ ELIF cod > 256
+ THEN
+ taskinfo fremd
+ ELSE
+ task id von fremd
+ FI.
+
+taskinfo fremd: sendung starten (q, collector, cod-256, -8).
+
+task id von fremd: sendung starten (q,collector, zielstation,-6) .
+
+name von fremdstation:
+ BOUND TASK VAR tsk := vdr;
+ TASK VAR tsk1 := tsk;
+ forget (vdr);
+ vdr := nilspace;
+ sendung starten (q, tsk1, -7).
+
+zielstation: cod.
+
+END PROC neue sendung;
+
+PROC zeitueberwachung
+ (INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr):
+ snr INCR 1;
+ FOR strom FROM snr UPTO maxstrom REP zeitkontrolle PER;
+ snr := 0.
+
+zeitkontrolle:
+ IF vx.strom <> 0 AND zeit(strom) > 0
+ THEN
+ zeit(strom) DECR 1;
+ IF sendung noch nicht zugestellt
+ THEN
+ IF zeit(strom) = 0 THEN
+ report ("Nicht zustellbar. """+nam (vx.ziel)+""". "+
+ text (vx.rechnernummernDIV256));
+ loesche verbindung (strom)
+ ELSE
+ snr := strom;
+ q := vx.quelle;
+ z := vx.ziel;
+ ant := vx.sendecode;
+ dr := vdr;
+ LEAVE zeitueberwachung
+ FI
+ ELIF zeit(strom) = 0 THEN wiederholen FI
+ FI.
+
+sendung noch nicht zugestellt:
+ typ (strom) = zustellung.
+
+wiederholen:
+ IF sendeeintrag
+ THEN
+ sendung wiederholen
+ ELSE
+ empfangseintrag freigeben
+ FI.
+
+sendeeintrag : vx.rechnernummern DIV 256 = own .
+
+sendung wiederholen:
+ IF wiederholung noch sinnvoll
+ THEN
+ IF frisch
+ THEN
+ time out bei open
+ ELSE
+ datenteil wiederholen
+ FI
+ ELSE
+ sendung loeschen
+ FI.
+
+wiederholung noch sinnvoll:
+ task noch da AND bei call noch im call.
+
+task noch da: vx.quelle = collector OR exists (vx.quelle).
+
+bei call noch im call:
+ IF call aufruf
+ THEN
+ callee (vx.quelle) = vx.ziel
+ ELSE
+ TRUE
+ FI.
+
+frisch: vx.sequenz = -1.
+
+time out bei open:
+ IF vx.sendecode > -4 THEN open wiederholen ELSE nak an quelle senden FI.
+
+nak an quelle senden:
+ forget (vdr); vdr := nilspace;
+ BOUND TEXT VAR erm := vdr;
+ erm := "Station "+text(vx.rechnernummernMOD256)+" antwortet nicht";
+ snr := strom;
+ q := collector;
+ z := vx.quelle;
+ ant := error nak;
+ dr := vdr;
+ sendung loeschen;
+ LEAVE zeitueberwachung .
+
+open wiederholen:
+ sendereport ("wdh open");
+ zeit(strom) := 20;
+ openblock := vx;
+ openblock.head := stx open;
+ ab die post.
+
+datenteil wiederholen:
+ sendereport ("wdh data. sqnr "+text (vx.sequenz));
+ senden .
+
+empfangseintrag freigeben:
+ IF antwort auf call
+ THEN
+ weiter warten
+ ELSE
+ empfangsreport ("Empfangseintrag freigegeben");
+ empfang loeschen
+ FI.
+antwort auf call: callee (vx.ziel) = vx.quelle.
+
+weiter warten: zeit (strom) := 200.
+
+END PROC zeitueberwachung;
+
+PROC sendereport (TEXT CONST txt):
+ report (text (strom)+":"+txt+". Absender: """+nam (vx.quelle)+
+ """. Ziel "+text(vx.rechnernummernMOD256));
+END PROC sendereport;
+
+PROC empfangsreport (TEXT CONST txt):
+ report (text (strom)+":"+txt+". Empfnger: """
+ +nam (vx.ziel)+""". Quelle "+text (vx.rechnernummernDIV256));
+END PROC empfangsreport ;
+
+PROC sendung loeschen:
+ IF callaufruf CAND alter call (tasknr (vx.quelle)) = strom
+ THEN
+ alter call (tasknr (vx.quelle)) := 0
+ FI;
+ vx.strom := 0;
+ forget (vdr)
+END PROC sendung loeschen;
+
+PROC empfang loeschen:
+ quit zaehler INCR 1;
+ IF callaufruf AND alter call (tasknr (vx.ziel)) = strom
+ THEN
+ alter call (tasknr (vx.ziel)) := 0
+ FI;
+ forget (vdr);
+ vx.strom := 0
+END PROC empfang loeschen;
+
+PROC loesche verbindung (INT CONST nr):
+ strom := nr;
+ IF sendeeintrag
+ THEN
+ sendung loeschen
+ ELSE
+ gegenstelle zum loeschen auffordern;
+ empfang loeschen
+ FI.
+
+gegenstelle zum loeschen auffordern:
+ IF verbindung aktiv THEN quittieren (-loesche) FI.
+
+verbindung aktiv: vx.strom > 0.
+
+sendeeintrag: vx.rechnernummern DIV 256 = own .
+
+END PROC loesche verbindung;
+
+PROC weiter senden:
+ IF NOT alles raus
+ THEN
+ sequenz zaehlung;
+ IF neue seite THEN seitennummer eintragen FI;
+ senden
+ FI.
+
+sequenz zaehlung:
+ vx.sequenz INCR 1.
+
+neue seite:
+ (vx.sequenz AND packete pro seite minus 1) = 0.
+
+seitennummer eintragen:
+ dr page (strom) := vx.seiten nummer;
+ vx.seitennummer := next ds page (vdr, dr page (strom)).
+
+
+END PROC weiter senden;
+
+PROC senden:
+ zeit(strom) := 3;
+ vorspann senden;
+ daten senden.
+
+vorspann senden:
+ openblock := vx;
+ blockout (workspace, 1, dr verwaltungslaenge, vorspannlaenge).
+
+daten senden:
+ blockout (vdr,dr page (strom),distanz,nutzlaenge).
+
+distanz: nutzlaenge* (vx.sequenz AND (packete pro seite minus 1)).
+
+END PROC senden;
+
+PROC naechste verbindung vorbereiten:
+ FOR strom FROM 1 UPTO maxstrom REP
+ UNTIL vx.strom = 0 PER;
+ IF vx.strom <> 0 THEN errorstop ("Verbindungsengpass") FI.
+END PROC naechste verbindung vorbereiten;
+
+PROC sendung starten (TASK CONST quelle, ziel, INT CONST code):
+ sendung starten (quelle,ziel, station(ziel), code)
+END PROC sendung starten;
+
+PROC sendung starten (TASK CONST quelle, ziel, INT CONST ziel station,code):
+ IF ziel station = own
+ THEN
+ report ("Irrlufer: Sendung an eigene Station. Absender:"""+
+ nam (quelle)+""".");
+ vx.strom := 0;
+ forget (vdr)
+ ELSE
+ openblock.ziel := ziel;
+ openblock.quelle :=quelle;
+ openblock.sendecode := code;
+ openblock.rechnernummern:= ziel station + own256;
+ alten call loeschen (quelle);
+ IF call oder ping pong
+ THEN typ (strom) := call pingpong; call merken
+ ELSE typ (strom) := send wait FI;
+ sendung neu starten
+ FI.
+
+call oder pingpong: openblock.ziel = callee (openblock.quelle).
+
+call merken: alter call (tasknr (quelle)) := strom.
+
+END PROC sendung starten;
+
+PROC sendung neu starten:
+ openblock.head:= stx open;
+ openblock.sequenz := -1;
+ openblock.seitennummer:= next ds page (vdr,-1);
+ openblock.strom := strom;
+ vx := open block;
+ zeit(strom) := 3;
+ ab die post;
+ vx.head:=code stx+256*(vorspannlaenge+nutzlaenge).
+
+END PROC sendung neu starten; .
+
+ab die post:
+ block out (work space,1, dr verwaltungslaenge,open laenge).
+
+PROC alten call loeschen (TASK CONST quelle):
+ IF alter call aktiv
+ THEN
+ INT VAR lstrom := strom;
+ vx:=openblock;
+ strom := alter call (tasknr (quelle));
+ IF in ausfuehrungsphase
+ THEN
+ sendereport ("Call-Lschung vorgemerkt");
+ loeschung vormerken
+ ELSE
+ report ("Call gelscht."""+nam(quelle)+""". Strom "+text(strom));
+ loesche verbindung (strom)
+ FI;
+ strom := lstrom;
+ openblock := vx
+ FI.
+
+in ausfuehrungsphase:
+ typ(strom) = call im wait OR typ (strom) = call in zustellung.
+
+loeschung vormerken:
+ typ(strom) := call im abbruch;
+ alter call (tasknr (quelle)) := 0.
+
+
+ alter call aktiv:
+ alter call (tasknr (quelle)) > 0.
+
+END PROC alten call loeschen;
+
+PROC packet eingang
+ (TEXT CONST ft, INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr):
+ snr := 0;
+ vorspann holen;
+ IF NOT ring logik THEN daten teil FI.
+
+ring logik: FALSE.
+# IF selbst quelle THEN daten aus puffer entfernen ; TRUE
+ ELIF NOT selbst ziel THEN weitergeben; TRUE
+ ELSE FALSE
+ FI.
+
+selbst quelle: openblock.rechnernummern DIV 256 = station (myself).
+
+selbst ziel: (openblock.rechnernummern AND 255) = own.
+#
+daten aus puffer entfernen:
+ IF code (t) > nutzlaenge
+ THEN
+ BOOL VAR dummy :=blockin (workspace, 1, drverwaltungslaenge, nutzlaenge)
+ FI.
+#
+weitergeben:
+ IF code (t) > nutzlaenge
+ THEN
+ IF NOT blockin (workspace, 2, 0, nutzlaenge)
+ THEN LEAVE test auf packeteingang FI;
+ FI;
+ out (stx+t);
+ blockout (workspace, 1, drverwaltungslaenge2, blocklaenge);
+ IF code (t) > nutzlaenge
+ THEN
+ blockout (workspace, 2, 0, nutzlaenge)
+ FI.
+#
+vorspann holen:
+ sync;
+ IF NOT blockin (workspace, 1, dr verwaltungslaenge2, block laenge)
+ THEN LEAVE packeteingang
+ FI.
+
+
+blocklaenge: IF code t > nutzlaenge
+ THEN
+ vorspannlaenge-2
+ ELSE
+ code t -2
+ FI.
+
+sync:
+ TEXT VAR skipped:=ft , t :="";
+ REP
+ skipped CAT t;
+ t := incharety (1);
+ IF t = "" THEN
+ report ("skipped",skipped);
+ LEAVE packet eingang
+ FI ;
+ INT VAR codet := code (t);
+ UNTIL blockanfang PER;
+ IF skipped <> stx THEN report ("skipped bei sync:", skipped) FI.
+
+blockanfang:
+ (skipped SUB length(skipped)) = stx
+ AND
+ (codet = datenpacketlaenge
+ OR codet = ack laenge OR codet = neue ack laenge OR code t = openlaenge).
+
+daten teil:
+ IF neue verbindung
+ THEN
+ verbindung bereitstellen
+ ELIF quittung
+ THEN
+ strom := ack packet.strom;
+ IF falsche stromnummer THEN report ("Strom falsch in Quittung");
+ LEAVE datenteil FI;
+ IF vx.strom = 0 THEN LEAVE datenteil FI;
+ IF ackpacket.code >= ok THEN weiter senden
+ ELIF ackpacket.code = -von vorne THEN
+ sendereport ("Neustart");
+ openblock := vx;
+ sendung neu starten
+ ELIF ackpacket.code = -wiederhole THEN back 16
+ ELIF ackpacket.code = -loesche THEN fremdloeschung
+ ELIF ackpacket.code = -beende AND alles raus THEN strom abschliessen
+ FI
+ ELIF verbindung festgestellt
+ THEN
+ zeit(strom) := 200;
+ opti := vx;
+ datenpacket
+ ELSE
+ strom := maxstrom1;
+ vx:=openblock;
+ report ("Daten ohne Eroeffnung von " +text(vx.rechnernummernDIV256)
+ +" Sequenznr "+text(openblock.sequenz));
+ daten aus puffer entfernen;
+ IF alles raus THEN quittieren (-beende) ELSE quittieren(-von vorne) FI
+ FI.
+
+verbindung bereitstellen:
+ IF openblock.ziel = collector OR station (openblock.ziel) = own
+ THEN
+ freie verbindungsnummer;
+ vdr := nilspace;
+ vx := open block;
+ zeit(strom) := 10;
+ quittieren falls genug pufferplatz;
+ vx.sequenz := 0 ;
+ IF loeschung vorgemerkt
+ THEN
+ loesche verbindung (strom)
+ ELSE
+ opti := vx;
+ abschluss testen
+ FI;
+ FI.
+
+loeschung vorgemerkt: typ(strom) = call im abbruch.
+
+strom abschliessen:
+ IF call aufruf THEN zeit(strom) := 80; ausfuehrungsphase merken
+ ELSE
+ vx.strom := 0;
+ forget (vdr)
+ FI.
+
+ausfuehrungsphase merken: typ(strom) := call in zustellung.
+
+back16:
+ datenraum etwas rueckspulen;
+ nicht sofort senden (* wegen vagabundierender Quittungen *).
+
+nicht sofort senden: zeit(strom) := 2.
+
+datenraum etwas rueckspulen:
+ sendereport ("etwas rueckgespult");
+ INT VAR sk , vs :=-1;
+ dr page (strom) := -1;
+ INT VAR i;
+ FOR i FROM 1 UPTO vx.sequenz DIV packete pro seite - etwas REP
+ vs INCR packete pro seite;
+ dr page (strom) := next ds page (vdr, dr page (strom))
+ PER;
+ vx.seiten nummer := next ds page (vdr, dr page (strom)) ;
+ vx.sequenz := vs.
+
+etwas: 3.
+
+fremdloeschung:
+ IF fremdrechner ok und sendung
+ THEN
+ IF typ (strom) = call in zustellung
+ THEN
+ typ (strom) := call im wait
+ ELSE
+ sendereport ("Sendung von Gegenstelle geloescht");
+ sendung loeschen
+ FI
+ FI.
+
+fremdrechner ok und sendung:
+ (ackpacket.rechnernummern DIV 256) = (vx.rechnernummern AND 255).
+
+
+quittieren falls genug pufferplatz:
+ IF quit zaehler > 0 THEN
+ quit zaehler DECR 1;
+ open quittieren;
+ block vorab quittieren
+ FI.
+
+open quittieren: quittieren (ok).
+block vorab quittieren: quittieren (ok).
+
+quittung: code t <= neue ack laenge.
+
+neue verbindung: code t = open laenge.
+
+verbindung festgestellt:
+ FOR strom FROM maxstrom DOWNTO 1 REP
+ IF bekannter strom
+ THEN LEAVE verbindung festgestellt WITH TRUE FI
+ PER;
+ FALSE.
+
+bekannter strom:
+ vx.strom = vorspann.strom AND vom selben rechner.
+
+vom selben rechner:
+ vx.rechnernummern = vorspann.rechnernummern.
+
+daten:
+ IF NOT blockin (vdr, opti.seiten nummer, distanz, nutzlaenge)
+ THEN quittieren (-wiederhole); LEAVE packeteingang
+ FI;
+ sequenz zaehlung;
+ IF neue seite kommt
+ THEN
+ vx.seiten nummer := vorspann.seiten nummer
+ FI.
+
+datenpacket:
+ IF sendung wartet auf zustellung THEN auffrischen ELSE daten holen FI.
+
+sendung wartet auf zustellung: typ (strom) = zustellung.
+
+auffrischen: zeit (strom) := 100; daten aus puffer entfernen.
+
+daten holen:
+ IF opti.sequenz >= vorspann.sequenz AND opti.sequenz < vorspann.sequenz+100
+ THEN
+ IF opti.sequenz <> vorspann.sequenz
+ THEN empfangsreport ("Sequenzreset von "+text(opti.sequenz)+" auf "+
+ text (vorspann.sequenz));
+ vx.sequenz := vorspann.sequenz;
+ vorabquittung regenerieren
+ FI;
+ quittieren(ok);
+ daten ;
+ abschluss testen
+ ELSE
+ empfangsreport ("Sequenzfehler: soll "+text(vx.sequenz)+" ist "+
+ text(vorspann.sequenz));
+ quittieren (-wiederhole);
+ daten aus puffer entfernen
+ FI.
+
+vorabquittung regenerieren: quittieren (ok).
+
+distanz: (opti.sequenz AND packete pro seite minus 1 ) * nutzlaenge.
+
+sequenz zaehlung:
+ vx.sequenz INCR 1.
+
+neue seite kommt:
+(vx.sequenz AND packete pro seite minus1) = 0.
+
+freie verbindungsnummer:
+ INT VAR h strom :=0;
+ FOR strom FROM 1 UPTO maxstrom REP
+ IF vx.strom = 0 THEN h strom := strom
+ ELIF bekannter strom
+ THEN empfangsreport ("Reopen");
+ quit zaehler INCR 1;
+ forget (vdr);
+ LEAVE freie verbindungsnummer
+ ELIF antwort auf call
+ THEN
+ typ (strom) := call pingpong;
+ forget (vdr);
+ LEAVE freie verbindungsnummer
+ FI
+ PER;
+ strom := h strom;
+ IF strom = 0 THEN
+ error stop ("Zuviele simulatane Verbindungen")
+ FI;
+ typ(strom) := send wait.
+
+antwort auf call:
+ openblock.sendecode >= 0 AND
+ call aufruf AND vx.quelle = openblock.ziel AND vx.ziel = openblock.quelle.
+
+abschluss testen:
+ IF neue seite kommt AND vx.seiten nummer = -1
+ THEN
+ quittieren (-beende);
+ an ziel weitergeben
+ FI.
+
+an ziel weitergeben:
+ IF tasknummerfrage THEN taskfrage beantworten ;pufferplatz freigeben;
+ ELIF tasknamenfrage THEN name senden ;pufferplatz freigeben;
+ ELIF taskinfofrage THEN task info senden;pufferplatz freigeben;
+ ELSE senden
+ FI.
+
+pufferplatz freigeben: quitzaehler INCR 1.
+
+senden:
+ max 100 versuche;
+ snr := strom;
+ IF NOT callaufruf THEN typ (strom) := zustellung FI;
+ q := vx.quelle;
+ z := vx.ziel;
+ ant := vx.sendecode;
+ dr := vdr;
+ LEAVE packet eingang.
+
+tasknummerfrage:opti.sendecode = -6.
+
+tasknamenfrage: opti.sendecode = -7.
+
+taskinfofrage: opti.sendecode = -8.
+
+max 100 versuche: zeit(strom) := 100.
+
+taskfrage beantworten:
+ BOUND TEXT VAR tsk := vdr;
+ TEXT VAR save tsk := tsk;
+ forget (vdr); vdr := nilspace;
+ BOUND TASK VAR task id := vdr;
+ disable stop;
+ task id := task(save tsk);
+ IF is error THEN
+ clear error; enable stop;
+ forget (vdr); vdr := nilspace;
+ BOUND TEXT VAR errtxt := vdr;
+ errtxt := text(station(myself))+"/"""+save tsk+""" gibt es nicht";
+ sendung starten (collector, opti.quelle, 2)
+ ELSE
+ enable stop;
+ sendung starten (collector, opti.quelle, 0)
+ FI.
+
+name senden:
+ forget (vdr); vdr := nilspace;
+ tsk := vdr;
+ disable stop;
+ tsk := nam (opti.ziel);
+ clear error; enable stop;
+ sendung starten (collector, opti.quelle, 0).
+
+task info senden:
+ BOUND INT VAR ti code := vdr;
+ INT VAR ti cd := ti code;
+ forget (vdr); vdr := nilspace;
+ FILE VAR task inf := sequential file (output,vdr);
+ head line (task inf,"Station "+text(own));
+ task info (ti cd, task inf);
+ sendung starten (collector,opti.quelle,0).
+
+END PROC packet eingang;
+
+PROC quittieren(INT CONST code) :
+ quellrechner wird zielrechner;
+ ackpacket.code := code;
+ ackpacket.head := stx quit;
+ ackpacket.strom := vx.strom;
+ blockout (workspace,1,dr verwaltungslaenge, ack laenge).
+
+quellrechner wird zielrechner:
+ ack packet.rechnernummern := vx.rechnernummern DIV 256
+ + own256.
+
+END PROC quittieren;
+
+END PACKET basic net;
diff --git a/system/net/1.7.5/src/callee b/system/net/1.7.5/src/callee
new file mode 100644
index 0000000..42d80da
--- /dev/null
+++ b/system/net/1.7.5/src/callee
@@ -0,0 +1,14 @@
+PACKET callee DEFINES callee:
+
+TASK PROC callee (TASK CONST t):
+ IF im wait THEN trick 1 (t); trick 2 ELSE niltask FI.
+im wait: (status(t) AND 3) = 2.
+END PROC callee;
+
+PROC trick 1 (TASK CONST t):
+ INT VAR x := pcb(t,11), y:=pcb(t,12);
+END PROC trick1;
+
+TASK PROC trick 2: TASK VAR calle; calle END PROC trick2;
+
+END PACKET callee;
diff --git a/system/net/1.7.5/src/net inserter b/system/net/1.7.5/src/net inserter
new file mode 100644
index 0000000..8cccedd
--- /dev/null
+++ b/system/net/1.7.5/src/net inserter
@@ -0,0 +1,50 @@
+
+{ Inserter fr EUMEL - Netz - Software; 04.12.83
+ bercksichtigt EUMEL - Versionen 1.7.3 und 1.7.5, sowie Multi / Single }
+
+
+INT VAR version :: id (0), cy :: 4;
+IF online THEN head FI;
+
+IF ich bin multi THEN insert multi net
+ ELSE meldung an single
+FI.
+
+ich bin multi : (pcb (9) AND 255) > 1.
+
+insert multi net :
+ IF version >= 173 THEN IF version < 175 THEN insert and say ("callee") FI;
+ insert and say ("net report/M");
+ insert and say ("basic net");
+ insert and say ("net manager/M")
+ ELSE versionsnummer zu klein
+ FI.
+
+meldung an single :
+ cursor (1, cy);
+ putline
+ ("Das EUMEL - Netz ist zur Zeit nur auf Multi - User - Versionen");
+ putline ("installierbar !").
+
+head :
+ page;
+ putline (" E U M E L - Netz - Inserter");
+ put ("---------------------------------").
+
+versionsnummer zu klein :
+ cursor (1, cy);
+ putline ("Netzsoftware erst ab Version 1.7.3 insertierbar !").
+
+PROC insert and say (TEXT CONST name of packet):
+ IF online THEN cl eop (1, cy);
+ put ("Paket '" + name of packet + "' wird insertiert");
+ line (2);
+ cy INCR 1
+ FI;
+ insert (name of packet);
+END PROC insert and say;
+
+PROC cl eop (INT CONST cx, cy) :
+ cursor (cx, cy);
+ out (""4"")
+END PROC cl eop;
diff --git a/system/net/1.7.5/src/net manager-M b/system/net/1.7.5/src/net manager-M
new file mode 100644
index 0000000..0383211
--- /dev/null
+++ b/system/net/1.7.5/src/net manager-M
@@ -0,0 +1,302 @@
+PACKET net manager DEFINES start,stop,net manager,frei:
+TEXT VAR stand := "Netzsoftware vom 02.09.85";
+ (*Heinrichs *)
+
+LET
+ ack = 0,
+ nak = 1,
+ error nak = 2,
+ zeichen eingang = 4,
+ list code = 15,
+ fetch code = 11,
+ freigabecode = 29,
+ continue code = 100,
+ erase code = 14,
+ report code = 99,
+
+ (* Typen von Kommunikationsstrmen *)
+
+ send wait = 0,
+ zustellung = 1,
+ call pingpong = 2,
+ call im wait = 3,
+ call im abbruch = 4,
+ call in zustellung = 5;
+
+LET STEUER =
+ STRUCT (
+ INT head,
+ rechner nummern,
+ strom,
+ INT sequenz,
+ seiten nummer,
+ TASK quelle,ziel,
+ INT sende code);
+
+LET INFO = STRUCT (STEUER steuer, INT typ);
+
+TASK VAR sohn;
+INT VAR strom,c.
+
+vx: v.steuer.
+
+PROC frei (INT CONST stat,lvl):
+ DATASPACE VAR ds := nilspace;
+ BOUND STRUCT (INT x,y) VAR msg := ds;
+ msg.x := stat; msg.y := lvl;
+ INT VAR return;
+ call (/"net port", freigabecode, ds, return) ;
+ forget (ds)
+END PROC frei;
+
+PROC net manager (DATASPACE VAR ds, INT CONST order, phase, TASK CONST
+ ordertask):
+
+ IF order = report code
+ THEN
+ forget ("report",quiet);
+ copy (ds,"report");
+ forget (ds)
+ ELSE
+ IF ordertask < myself
+ OR order = list code
+ OR order > continue code
+ THEN
+ IF order = list code
+ THEN
+ enable stop;
+ forget (ds); ds := old ("report");
+ FILE VAR ff := sequential file (output,ds);
+ putline (ff,stand);
+ putline (ff,"Rechner "+text(station(myself))+" um "+time of day);
+ send (ordertask, ack, ds)
+ ELSE
+ free manager (ds,order,phase,order task)
+ FI
+ ELSE
+ errorstop ("nur 'list' ist erlaubt")
+ FI
+ FI
+END PROC net manager;
+
+TASK VAR cd,stask;
+ROW 255 INT VAR erlaubt;
+INT VAR i;
+FOR i FROM 1 UPTO 255 REP erlaubt (i) := 0 PER;
+
+PROC communicate:
+ enable stop;
+ INT VAR scode;
+ DATASPACE VAR dr := nilspace;
+ neuer start (quit max);
+REP
+ forget (dr);
+ wait (dr, scode, stask);
+ cd := collected destination;
+ IF zeichen da OR zeit abgelaufen
+ THEN
+ packet
+ ELIF cd = myself
+ THEN
+ netz info und steuerung
+ ELSE
+ neue sendung (stask, cd, scode, dr)
+ FI
+PER.
+
+zeichen da: scode < 0 .
+
+zeit abgelaufen: scode = ack AND cd = myself.
+
+packet:
+ TEXT VAR t := incharety;
+ INT VAR snr, ant,err;
+ TASK VAR quelle, ziel;
+ snr := 0;
+ REP
+ IF t = ""
+ THEN
+ zeitueberwachung (snr, quelle, ziel, ant, dr);
+ ELSE
+ packet eingang (t, snr, quelle, ziel, ant, dr);
+ FI;
+ IF snr > 0
+ THEN
+ IF ant > 5 AND erlaubt(station (quelle)) < 0
+ THEN unerlaubt
+ ELSE
+ send (quelle,ziel,ant,dr,err);
+ fehlerbehandlung ;
+ FI
+ FI
+ UNTIL snr = 0 OR zeichen da PER.
+
+fehlerbehandlung:
+ IF ok oder ziel nicht da THEN loesche verbindung (snr) FI.
+
+ok oder ziel nicht da: err=0 OR err=-1.
+
+netz info und steuerung:
+ IF scode = list code THEN list status
+ ELIF scode = erase code THEN strom beenden
+ ELIF scode = freigabe code AND stask = father THEN freigabelevel
+ ELSE forget (dr); ablehnen ("nicht mglich")
+ FI.
+
+freigabelevel:
+ BOUND STRUCT (INT stat,lvl) VAR lv := dr;
+ IF lv.stat > 0 AND lv.stat < 256 THEN erlaubt (lv.stat) := lv.lvl FI;
+ send (stask,ack,dr).
+
+unerlaubt:
+ report ("Fremdzugriff von "+text(station (quelle))+" auf "+nam(ziel)
+ +" code "+text(ant));
+ loesche verbindung (snr).
+
+strom beenden:
+ BOUND TEXT VAR stromtext := dr;
+ INT VAR erase strom := int (stromtext);
+ forget (dr);
+ strom := erase strom;
+ IF falsche stromnummer THEN ablehnen ("Strom gibt es nicht")
+ ELSE
+ BOUND INFO VAR v := verbindung (strom);
+ IF
+ stask = father OR stask = vx.quelle OR stask = vx.ziel
+ THEN
+ loeschen
+ ELSE ablehnen ("Nur Empfnger/Absender darf lschen")
+ FI
+ FI.
+
+loeschen:
+ IF sendeeintrag THEN
+ IF callee (vx.quelle) = vx.ziel THEN absender warnen FI;
+ loesche verbindung (strom)
+ ELSE
+ IF callee (vx.ziel) = vx.quelle THEN warnen FI;
+ loesche verbindung (strom)
+ FI;
+ dr := nilspace;
+ send (stask,ack,dr).
+
+absender warnen:
+ dr := nilspace;
+ send(vx.ziel,vx.quelle,1,dr,err) .
+
+warnen:
+ dr := nilspace;
+BOUND TEXT VAR errtxt := dr; errtxt:= "Station antwortet nicht";
+send (vx.quelle,vx.ziel,error nak, dr, err).
+
+falsche stromnummer: strom < 1 OR strom > max verbindungsnummer.
+sendeeintrag: vx.rechnernummern DIV256 = station (myself).
+END PROC communicate;
+
+PROC ablehnen (TEXT CONST t):
+ DATASPACE VAR vdr := nilspace;
+ BOUND TEXT VAR errtxt := vdr;
+ errtxt := t;
+ send (stask, error nak, vdr).
+END PROC ablehnen;
+
+PROC stop:
+ disable stop;
+ end (task ("net port"));
+ end (task ("net timer"));
+ clear error;
+END PROC stop;
+
+PROC list status:
+
+ DATASPACE VAR ds := nilspace;
+ FILE VAR f:=sequential file (output, ds);
+ FOR strom FROM 1 UPTO max verbindungsnummer REP
+ BOUND INFO VAR v := verbindung (strom);
+ IF vx.strom <> 0 THEN info FI
+ PER;
+ send (stask, ack, ds).
+
+info:
+ put (f,"Strom "+text(strom)+" (sqnr"+text(vx.sequenz)+")");
+ IF sendeeintrag THEN sendeinfo ELSE empfangsinfo FI;
+ line (f).
+
+sendeeintrag: vx.rechnernummern DIV 256 = station(myself) .
+
+sendeinfo:
+ IF v.typ = call im wait THEN put (f,"erwartet Antwort von")
+ ELIF v.typ = call in zustellung THEN put (f,"Ziel busy. Zielstation:")
+ ELIF v.typ = call im abbruch THEN put (f,"wird gelscht bei Antwort von")
+ ELSE put (f,"sendet an")
+ FI;
+ put (f,vx.rechnernummernMOD256);
+ put (f,". Absender ist """+nam (vx.quelle)+""".").
+
+empfangsinfo:
+ IF v.typ = zustellung THEN
+ put (f,"Sendung noch nicht zustellbar")
+ ELSE
+ put (f,"empfngt von");
+ put (f,vx.rechnernummernDIV256);
+ FI;
+ put (f,". Empfaenger ist """+nam (vx.ziel)+""".").
+END PROC list status;
+
+
+PROC start (INT CONST chan):
+ c:=chan;
+ start
+END PROC start;
+INT VAR quitmax := 3;
+PROC start (INT CONST chan,quit):
+ quitmax := quit;
+ c:=chan;
+ start
+END PROC start;
+
+PROC start:
+stop;
+IF exists ("report") THEN forget ("report") FI;
+FILE VAR s := sequential file (output,"report");
+putline (s," N e u e r S t a r t "+time of day);
+begin ("net port",PROC net io, sohn);
+TASK VAR dummy;
+begin ("net timer",PROC timer,dummy);
+define collector (sohn)
+END PROC start;
+
+PROC timer:
+ disable stop;
+ REP
+ clear error;
+ DATASPACE VAR ds := nilspace;
+ pause (100);
+ send (sohn, ack, ds)
+ PER;
+END PROC timer;
+
+PROC net io:
+ disable stop;
+ fetch ("report");
+ commanddialogue (FALSE);
+ continue (c);
+ communicate;
+ TEXT VAR emsg := "++++++ "+error message +" Zeile "+text(errorline);
+ clear error;
+ report (emsg);
+ save ("report");
+ end (myself)
+END PROC net io;
+
+put ("Netzkanalnummer:"); get (c);line;
+IF yes ("Ist der Netzkanal mit Flukontrolle verdrahtet") THEN
+ quit max := 10
+ELSE
+ quit max := 3
+FI;
+END PACKET net manager;
+
+
+start; global manager (PROC (DATASPACE VAR,INT CONST,INT CONST, TASK
+CONST) net manager )
diff --git a/system/net/1.7.5/src/net report-M b/system/net/1.7.5/src/net report-M
new file mode 100644
index 0000000..3ce67ff
--- /dev/null
+++ b/system/net/1.7.5/src/net report-M
@@ -0,0 +1,29 @@
+PACKET net report DEFINES report:
+
+LET reportcode = 99;
+
+PROC report (TEXT CONST x):
+ report(x,"")
+END PROC report;
+
+PROC report (TEXT CONST txt, info):
+ IF storage (old("report")) > 20 THEN forget ("report",quiet) FI;
+ reportfile := sequential file (output, "report");
+ put (reportfile, date);
+ put (reportfile, time of day);
+ put (reportfile, txt);
+ INT VAR i;
+ FOR i FROM 1 UPTO length (info) REP
+ INT VAR z := code (infoSUBi) ;
+ IF z < 32 OR z > 126
+ THEN put (reportfile,"%"+text(z))
+ ELSE put (reportfile,infoSUBi)
+ FI
+ PER;
+ line (reportfile);
+ DATASPACE VAR net report := old ("report");
+ send (father, report code , net report)
+END PROC report;
+FILE VAR reportfile;
+
+END PACKET net report;
diff --git a/system/net/1.8.7/doc/netzhandbuch b/system/net/1.8.7/doc/netzhandbuch
new file mode 100644
index 0000000..7083462
--- /dev/null
+++ b/system/net/1.8.7/doc/netzhandbuch
@@ -0,0 +1,2045 @@
+____________________________________________________________________________
+
+
+#on("b")##on ("u")#
+#center#Betriebssystem E U M E L
+#off ("u")#
+
+
+#center#Netzsoftware
+
+
+
+
+#off("b")#
+#center#Lizenzfreie Software der
+#on ("b")#
+
+#center#Gesellschaft für Mathematik und Datenverarbeitung mbH,
+#center#5205 Sankt Augustin
+
+
+#off("b")#
+#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für
+#center#nichtkommerzielle Zwecke gestattet.
+
+#center#Gewährleistung und Haftung werden ausgeschlossen
+
+
+____________________________________________________________________________
+#page#
+#pagenr ("%",1)##setcount(1)##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#Inhalt
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right# GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+
+#center#Inhalt
+
+#clear pos##lpos(1.0)##rpos(9.5)#
+#table#
+
+1. Einleitung #topage("0")#
+
+Teil 1: Netz einrichten und benutzen #topage("1")#
+
+
+1.1. Hardwarevoraussetzungen #topage("1.1")#
+1.2. Einrichten des Netzes #topage("1.2")#
+1.3. Benutzung des Netzes #topage("1.3")#
+1.4. Informationsmöglichkeiten #topage("1.4")#
+1.5. Eingriffsmöglichkeiten #topage("1.5")#
+1.6. Fehlerbehebung im Netz #topage("1.6")#
+1.7. Sicherheit im Netz #topage("1.7")#
+
+
+
+Teil 2: Arbeitsweise der Netzsoftware #topage("2")#
+
+
+2.1. Die Netztask #topage("2.1")#
+2.2. Protokollebenen #topage("2.2")#
+2.3. Stand der Netzsoftware #topage("2.3")#
+
+
+
+Teil 3: Netz-Hardware-Interface #topage("3")#
+
+
+3.1. Einführung #topage("3.1")#
+3.2. Arbeitsweise des Netz-Hardware-Interfaces #topage("3.2")#
+3.3. Netztreiber #topage("3.3")#
+3.4. Prozedurschnittstelle des EUMEL-Netzes #topage("3.4")#
+
+
+
+Anhang #topage("A")#
+
+
+1. Fehlermeldungen #topage("A.1")#
+2. Literaturhinweise #topage("A.2")#
+3. Index #topage("A.3")#
+
+#table end#
+#clear pos#
+
+#page#
+#pagenr ("%", 2)##setcount (1)##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#Einleitung
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right#GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+
+1. Einleitung
+
+#goalpage("0")#
+Das EUMEL-Netz dient dazu, mehrere EUMEL-Rechner (sog. #ib#Station#ie#en) miteinan­
+der zu koppeln. Diese Kopplung wird vom Betriebssystem dazu benutzt, das Sen­
+dungskonzept [1] so auszudehnen, daß Tasks verschiedener Stationen einander
+Datenräume zusenden können. Auf dem #ib#Sendungskonzept#ie# aufbauende Konzepte
+nutzen daher automatisch das Netz aus: So ist es z.B. möglich
+
+- von einer Station aus auf einer anderen zu drucken,
+
+- in die Task PUBLIC einer anderen Station #ib#Datei#ie#en zu sichern (save), vorausge­
+ setzt, daß PUBLIC dort ein #on("b")#free global manager#off("b")# ist,
+
+- auf einer anderen Station zu archivieren (z.B. wenn das eigene Archivlaufwerk
+ defekt ist oder ein anderes Format hat).
+
+Diese #ib#Netzversion#ie# kann ab EUMEL-Version 1.8.1 eingesetzt werden.
+
+Diese Netzbeschreibung besteht aus drei Teilen. In Teil 1 wird beschrieben, wie das
+EUMEL-Netz benutzt und eingerichtet wird. Als Benutzer eines EUMEL-
+Rechners, der vernetzt ist, ist nur dieser Teil der Netzbeschreibung für Sie wichtig.
+Teil 2 erklärt die Funktionsweise der #ib#Netzsoftware#ie#, im dritten Teil wird die Schnitt­
+stelle für die Anpassung anderer #ib#Netzhardware#ie# definiert.
+
+Hinweis:
+
+Zur erstmaligen #ib#Installation#ie# des EUMEL-Netzes ist außer dieser Beschreibung noch
+die Netzsoftware (auf Floppy) und die EUMEL-Netz-#ib#Installationsanleitung#ie#, die mit
+der Software geliefert wird, notwendig.
+
+In der vorliegenden Netzbeschreibung wird das EUMEL-Netz möglichst "hardware
+unabhängig" beschrieben. Wenn hardwareabhängige Beispiele gegeben werden, so
+ist die dort beschriebene Hardware stets die #ib#Datenbox#ie#.
+#pagenr ("%", 3)##setcount (1)##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#cneter#____________________________________________________________
+
+#end#
+#headodd#
+#center#Teil 1 : Netz einrichten und benutzen
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right#GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+#page#
+
+Teil 1: Netz einrichten und benutzen
+#goalpage("1")#
+
+
+
+1.1. Hardwarevoraussetzungen
+#goalpage("1.1")#
+
+
+Zwei Stationen
+
+Sie können zwei #ib#Station#ie# miteinander vernetzen, wenn Sie dafür an jeder Station eine
+#ib#V.24#ie#-#ib#Schnittstelle#ie# zur Verfügung stellen.
+
+Diese beiden Schnittstellen verbinden Sie mit einem Kabel zur #ib#Rechnerkopplung#ie# [2].
+
+
+Mehrere Stationen
+
+Wenn Sie mehr als zwei Stationen vernetzen wollen, stehen Ihnen zwei Konzepte zur
+Verfügung: das Anlegen von #ib#Netzknoten#ie# bzw. das Verwenden eines #ib#Strang#ie#es. Die
+Konzepte können gemischt eingesetzt werden.
+
+Ein Strang besteht aus einer Anzahl von #ib#Netzbox#ie#en (z.B. KHW-Box oder Ethernet­
+anschluß).
+
+Jede Box besitzt eine #ib#Schnittstelle#ie# (z.B. #ib#V.24#ie#) zum Anschluß an einen der Kanäle
+1...15 der zugeordneten #ib#Station#ie# und eine weitere Schnittstelle zur #ib#Verbindung#ie# der
+Boxen untereinander.
+
+Ein #ib#Knoten#ie# ist eine Station, bei der der Netzbetrieb über mehrere Kanäle läuft.
+
+Da die #ib#Netzsoftware#ie# pro #ib#Kanal#ie# eines Knotens eine Task generiert, ist das Knoten­
+konzept dem Strangkonzept hinsichtlich des #ib#Durchsatz#ie#es unterlegen. Preisgünstiger
+ist jedoch das #ib#Knotenkonzept#ie#, weil dabei #ib#Netzbox#ie#en überflüssig werden.
+
+Beim Knotenkonzept wird eine #ib#Vermaschung#ie# nicht zur Optimierung benutzt (Ver­
+maschung heißt, daß eine #ib#Zielstation#ie# über verschiedene Knoten erreichbar ist). Daher
+sollte man keine Vermaschung vorsehen.
+
+#ib#Nachbarn#ie# sind Stationen, die an denselben #ib#Netzstrang#ie# angeschlossen oder direkt
+über ein #ib#V.24#ie#-Kabel verbunden sind.
+
+Bei der Entscheidung, welche Stationen man zu #ib#Knoten#ie# macht, sollte beachtet wer­
+den, daß (a) Stationen, zwischen denen hoher Verkehr besteht, Nachbarn werden und
+daß (b) besonders leistungsfähige Rechner #ib#Knoten#ie#stationen sein sollten.
+#page#
+
+1.2. Einrichten des Netzes
+#goalpage("1.2")#
+
+
+Hinweis: Dieses Kapitel ist nur für Systembetreuer wichtig.
+
+a) Legen Sie für die am Netz beteiligten Rechner #ib#Stationsnummer#ie#n fest (von 1 an
+ aufsteigend).
+
+ Die Boxen haben ebenfalls Stationsnummern. Die Stationsnummern der Box und
+ des zugeordneten Rechners müssen übereinstimmen.
+
+
+b) Holen Sie an jeder #ib#Station#ie# die Task #on("bold")#configurator#off("bold")# an ein Terminal und geben Sie
+ das Kommando #on("bold")##ib#define station#ie# (x)#off("bold")#, wobei #on("bold")#x#off("bold")# die gewählte Stationsnummer ist.
+
+ Hinweis: Taskkommunikationen, die zu diesem Zeitpunkt laufen, führen zu feh­
+ lerhaftem Verhalten. Dies liegt daran, daß durch #on("bold")#define station#off("bold")# alle
+ #ib#Task-Id#ie#'s geändert werden müssen, weil eine #ib#Task-Id#ie# u.a. die
+ Stationsnummer der eigenen Station enthält (siehe 1.3). TASK-
+ Variablen, die noch Task-Id's mit keiner oder falscher Stationsnum­
+ mer enthalten, können nicht mehr zum Ansprechen einer Task ver­
+ wendet werden.
+
+ Beispiel: Der #ib#Spoolmanager#ie# [3] richtet beim Kommando #on("bold")#start#off("bold")# einen #ib#Worker#ie# ein
+ und merkt sich dessen #ib#Task-Id#ie# in einer TASK-Variablen, um sicher­
+ zustellen, daß nur der Worker #ib#Datei#ie#en zum Drucken abholt. Wird jetzt
+ das Kommando #on("bold")# define station#off("bold")# gegeben, kann der Spoolmanager
+ seinen Worker nicht mehr identifizieren, weil der Worker eine neue
+ Task-Id erhalten hat. Man muß daher vor #on("b")#define station#off("b")# den Worker
+ löschen und ihn danach mit dem Kommando #on("bold")##ib#start#ie##off("bold")# im Spoolmanager
+ wieder neu einrichten.
+
+
+ Sinnvollerweise gibt man #on("bold")#define station#off("bold")# sofort nachdem man ein frisches System
+ vom Archiv geladen hat.
+
+ Zum Anschluß einer #ib#Datenbox#ie# #ib#konfigurieren#ie# Sie mit dem Kommando #on("bold")##ib#configurate#ie##off("bold")#
+ den für das Netz vorgesehenen #ib#Kanal#ie# auf
+
+ - transparent
+ - 9600 #ib#Baud#ie# (Standardeinstellung der Boxen)
+ - #ib#RTS/CTS#ie#-#ib#Protokoll#ie#
+ - großen Puffer
+ - 8 bit
+ - even parity
+ - 1 stopbit.
+
+ Falls diese Einstellungen nicht alle angeboten werden, klären Sie mit Ihrem
+ Rechnerlieferanten, ob und wie diese Einstellungen erreicht werden können.
+
+ Hinweis: Notfalls kann auf das #ib#RTS/CTS#ie#-Protokoll verzichtet werden, wenn der
+ Eingabepuffer der #ib#Station#ie# groß genug ist. Die Anzahl simultan laufen­
+ der Netzkommunikationen ist dann auf
+
+ puffergröße DIV 150
+
+ begrenzt (bei Z80, 8086: 3; bei M20: 10).
+
+ Hinweis: Es können auch andere #ib#Baud#ie#raten (2400, 4800, 19200) an der Box
+ eingestellt werden.
+
+
+c) Achten Sie bei der #ib#Verbindung#ie# von der Station zur #ib#Netzbox#ie# (bzw. zur Gegen­
+ station bei einem Zweistationennetz ohne Boxen) darauf, daß neben den Emp­
+ fangs- und Sendeleitungen auch die Leitungen RTS und CTS verdrahtet wer­
+ den, also ein 5-poliges Kabel verwendet wird [2]. Die #ib#Pin-Belegung#ie# der Boxen
+ entspricht der eines Kabels zur Rechner-Rechner-Kopplung.
+
+ Beispiel:
+
+ Verbindung eines BICOS-Systems mit der Box:
+
+ Stecker Stecker
+ Pin Pin
+
+ 2 <---------> 3
+ 3 <---------> 2
+ 4 <---------> 5
+ 5 <---------> 4
+ 7 <---------> 7
+
+
+d) Richten Sie eine Task #on("bold")##ib#net#ie##off("bold")# unter #on("bold")#SYSUR#off("bold")# ein und legen Sie eine #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# an, die
+ Ihre #ib#Netzkonfiguration#ie# enthält, oder ändern Sie die mitgelieferte Datei ent­
+ sprechend ab (siehe auch 1.5.).#goalpage("sperre")#
+
+
+ Dem bisherigen Netz entspricht eine Datei #on("b")#netz#off("b")# mit folgendem Inhalt:
+
+ definiere netz;
+ routen (1,127,k);
+ starte kanal (k,1,x);
+ aktiviere netz.
+
+ k: ihr netzkanal.
+ x: IF yes ("#ib#Flußkontrolle#ie#") THEN 10 ELSE 3 FI.
+
+
+
+ Laden Sie die Datei #on("b")##ib#net install#ie##off("b")# vom Archiv #on("b")#net#off("b")# und übersetzen Sie diese. Je nach­
+ dem, welche EUMEL-Version auf der Maschine installiert ist, werden die notwen­
+ digen Programmdateien insertiert.
+
+ Es sind dies
+
+ net report
+ net hardware interface
+ basic net
+ net manager
+
+
+ Das Netz wird dabei gestartet.
+
+
+ Hinweis: Obwohl die Task #on("b")#net#off("b")# sich noch mit #on("bold")##ib#continue#ie##off ("bold")# an ein Terminal holen
+ läßt, sollte man dies nur kurzzeitig tun, da der Netzverkehr solange
+ blockiert ist.
+
+ In der #ib#Datei#ie# #on("b")#netz#off("b")# sollte der #ib#Kanal#ie#, über den der meiste Verkehr erwar­
+ tet wird, zuerst gestartet werden. Für ihn wird die Task #on("b")##ib#net port#ie##off("b")# gene­
+ riert, für jeden weiteren Kanal wird eine Task #on("b")##ib#net port#ie# k#off("b")# (k=Kanal­
+ nummer) generiert.
+#page#
+
+1.3. Benutzung des Netzes
+#goalpage("1.3")#
+
+
+Zur Benutzung des Netzes stehen folgende Operatoren und Prozeduren zur Verfü­
+gung:
+
+
+
+TASK OP #ib#/#ie# (INT CONST station, TEXT CONST taskname)
+
+liefert die Task #on("bold")#taskname#off("bold")# von der #ib#Station#ie# #on("bold")#station#off("bold")#.
+
+
+#ib#Fehlerfälle#ie#:
+
+ - #ib(4)#Task "...." gibt es nicht#ie(4)#
+
+ Die angeforderte Task gibt es auf der #ib#Zielstation#ie# nicht.
+
+ - #ib(4)##ib#Collectortask#ie# fehlt#ie(4)#
+
+ die Task #on("b")##ib#net port#ie##off("b")# existiert nicht (siehe 6).
+
+ Hinweis: #on("b")#net port#off("b")# wird bei jedem Start des Netzes neu generiert und beim
+ Auftreten eines nicht vorhergesehenen #ib#Fehler#ie#s beendet. Die Feh­
+ lermeldung steht im #on("b")##ib#report#ie##off("b")# (siehe 4).
+
+ - #ib(4)#Station x antwortet nicht#ie(4)#
+
+ Eine nicht vorhandene oder abgeschaltete Station wurde angesprochen.
+
+ Hinweis: Dieser #ib#Fehler#ie# wird angenommen, wenn eine Überwachungszeit von
+ ca. 30 Sekunden verstrichen ist, ohne daß Station x die Taskidenti­
+ fikation angeliefert hat.
+
+ - #ib(4)#Station x gibt es nicht#ie(4)#
+
+ #ib#Station#ie# x steht nicht in den #ib#Routentabelle#ie#n.
+
+ Diese Meldung kann auch erscheinen, wenn Station x erst kürzlich an das Netz
+ angeschlossen wurde. Sie steht dann noch nicht in den Routentabellen (siehe
+ auch 5.3.).
+
+ Beispiel:
+
+ list (5/"PUBLIC")
+
+ Die Dateiliste von PUBLIC der Station 5 wird angefordert.
+
+
+
+TASK OP #ib#/#ie# (INT CONST station, TASK CONST task)
+
+liefert
+
+station / name (task)
+
+Beispiel:
+
+ list (4/public)
+
+
+Fehlerfall:
+
+ "......" #ib(4)#gibt es nicht#ie(4)#
+
+ Auf der eigenen Station gibt es die Task #on("b")#task#off("b")# nicht.
+ Der Taskname wird auf der eigenen Station bestimmt, wenn es dort die Task
+ nicht gibt, führt dies zur obigen Fehlermeldung.
+
+Abhilfe:
+
+ Statt list(4/public) das Kommando list (4/"PUBLIC") verwenden.
+
+
+
+INT PROC #ib#station#ie# (TASK CONST task)
+
+liefert die #ib#Stationsnummer#ie# der Task #on("bold")#task#off("bold")#.
+
+Beispiel:
+
+ put (station (myself))
+
+ gibt die eigene Stationsnummer aus.
+
+
+
+
+PROC #ib#reserve#ie# (TEXT CONST archivename, TASK CONST archivetask)
+
+dient dazu, das Archiv auf der #ib#Station#ie# #on("bold")#station#off("bold")# anzumelden.
+
+Beispiel:
+
+ reserve ("std", 4/"ARCHIVE"); #ib#list#ie# (4/"ARCHIVE")
+
+ gibt das Inhaltsverzeichnis der Archivfloppy im Laufwerk der Station 4 aus.
+
+ Hinweis: Vergessen Sie bei solchen #ib#Querarchivierungen#ie# nicht die Stationsangabe
+ bei jedem einzelnen Archivkommando (z.B fetch ("xxx", #on("bold")#4/#off("bold")#
+ "ARCHIVE")).
+
+ Hinweis: Querarchivieren ist langsam. Verwenden Sie es nur, wenn Sie Floppy­
+ formate umsetzen wollen.
+
+
+
+
+PROC #ib#free global manager#ie#
+
+dient dazu, die eigene Task über das Netz ansprechbar zu machen. Jede andere
+Task im Netz kann dann die üblichen #ib#Manager#ie#aufrufe (#on("bold")##ib#save#ie##off ("bold")#, #on("bold")##ib#fetch#ie##off ("bold")#, usw.) an die
+eigene Task machen, sofern diese nicht an ein Terminal gekoppelt ist.
+
+Die Task wird (wie bei #on("bold")#break#off ("bold")#) abgekoppelt und meldet sich in Zukunft mit #on("bold")#mainte­
+nance#off ("bold")# statt mit #on("bold")#gib kommando#off ("bold")#.
+
+Beispiel:
+
+ An Station 4 ruft man in der Task "hugo" das Kommando #on("bold")#free global manager#off("bold")#
+ auf. Anschließend kann man von jeder Station aus z.B. #on("bold")#list (4/"hugo")#off ("bold")# usw. auf­
+ rufen.
+
+
+
+
+TEXT PROC #ib#name#ie# (TASK CONST t)
+
+Diese (schon immer vorhandene) Prozedur wurde dahingehend erweitert, daß der
+Name einer auf einer anderen Station existierenden Task über Netz angefordert wird.
+
+Existiert die Task nicht, so wird #on("bold")##ib#niltext#ie##off ("bold")# geliefert.
+
+Hinweis: Die Prozedur #on("bold")##ib#exists#ie##off ("bold")# wurde nicht auf das Netz ausgedehnt, da sie in Situa­
+ tionen eingesetzt wird, wo es auf eine sehr schnelle Antwort ankommt.
+ Daher liefert #on("bold")#exists#off ("bold")# für eine stationsfremde Task immer FALSE. Will man
+ wissen, ob eine solche Task existiert, verwende man die Abfrage
+
+ #on("bold")#IF name (task) <> "" THEN ... #off ("bold")#.
+
+#ib#Fehlerfall#ie#:
+
+ - #ib(4)#Station x antwortet nicht#ie(4)#
+
+ - #ib(4)##ib#Station#ie# x gibt es nicht#ie(4)#
+
+#page#
+
+1.4. Informationsmöglichkeiten
+
+#goalpage("1.4")#
+
+In der Task #on("bold")#net#off("bold")# wird eine #ib#Datei#ie# #on("bold")##ib#report#ie##off("bold")# geführt, in der #ib#Fehlersituationen#ie# des Netzes
+verzeichnet werden. Diese Datei kann in jeder anderen Task auf derselben Station mit
+#on("bold")##ib#list#ie# (/"#ib#net#ie#")#off("bold")# angesehen werden. Eine Erklärung der wichtigsten Meldungen finden Sie
+im Anhang.
+
+In jeder Task kann durch das Kommando #on("bold")##ib#list#ie# (/"#ib#net port#ie#")#off("bold")# eine Übersicht über die
+momentan laufenden #ib#Netzübertragungen#ie# der eigenen #ib#Station#ie# erhalten werden (nur für
+den #ib#Kanal#ie#, an dem #on("b")##ib#net port#ie##off("b")# hängt). Entsprechendes gilt für die weiteren Netports der
+eigenen Station.
+
+Mit #on("bold")##ib#list#ie# (/"#ib#net list")#ie##off("bold")# erhält man die Informationen, die man mit #on("b")#list (/"net")#off("b")# und #on("b")##ib#list#ie##off("b")# auf
+alle Netports bekommt, sofern #on("b")##ib#listoption#ie##off("b")# (siehe S. #topage("listop")#) beim Generieren des Netzes
+aufgerufen wurde. Dieser Aufruf funktioniert auch bei fremden Stationen (z.B. #on("b")#list
+(5/"net list")#off("b")#).
+
+#page#
+
+1.5. Eingriffsmöglichkeiten
+
+#goalpage("1.5")#
+
+- Jede Task kann #ib#Sende#ie(1,"ströme")#- und #ib#Empfangsströme#ie#, die bei #on("bold")#list (/"net port")#off("bold")# gemel­
+ det worden sind und die eigene Task betreffen, abbrechen. Hierzu ist das Kom­
+ mando #on("bold")##ib#erase#ie# ("x", /"#ib#net port#ie#")#off ("bold")# zu geben, wobei x die #ib#Stromnummer#ie# (aus dem #on("bold")#list#off ("bold")#)
+ ist.
+ Unberechtigte #ib#Löschversuche#ie# werden abgewiesen.
+ Von privilegierten Tasks aus können jedoch mit #on("b")##ib#erase#ie##off("b")# beliebige Ströme abge­
+ brochen werden.
+
+
+- Durch das Kommando #on("bold")##ib#start#ie##off("bold")# kann von der Task #on("b")##ib#net#ie##off("b")# aus das Netz neu gestartet
+ werden. Dies setzt eine gültige #ib#Datei#ie# #on("bold")#netz#off("bold")# voraus. Es wird ein #on("bold")##ib#run#ie##off("bold")# auf diese Datei
+ gegeben. Das Kommando #on("b")##ib#start#ie##off("b")# ist nur noch aus Kompatibilitätsgründen zum alten
+ Netz vorhanden.
+
+
+- Durch das Kommando #on("bold")##ib#routen aufbauen#ie##off("bold")# in der Task #on("b")##ib#net#ie##off("b")# werden die #ib#Routentabelle#ie#n
+ neu aufgebaut. Dies kann notwendig werden, wenn eine neue #ib#Station#ie# ans Netz
+ angeschlossen wurde (#ib#Fehlermeldung#ie# '#ib(4)#Station x gibt es nicht#ie(4)#'). #on("bold")#routen aufbauen#off ("bold")#
+ muß zuvor auch an allen dazwischenliegenden #ib#Knotenstation#ie#en gegeben werden.
+
+ #on("bold")#routen aufbauen#off ("bold")# erzeugt eine Task #on("b")##ib#router#ie##off("b")#, die sich an das Terminal koppelt (die
+ Task #on("b")#net#off("b")# koppelt sich ab) und ein #ib#Protokoll#ie# ausgibt. Sind die #ib#Route#ie#n aufgebaut,
+ beendet sich die Task #on("b")#router#off("b")# mit der Meldung #on("b")#fertig#off("b")#. Es werden nur Stationen
+ bearbeitet, die nicht #ib#gesperrt#ie# (siehe S. #topage("sperre")#), und für die keine festen Routen
+ vereinbart sind. Der Vorgang dauert ca. 5 Sek. pro nicht gesperrter Station und
+ #ib#Netzkanal#ie#. Die #ib#Route#ie#n werden in einem #ib#Datenraum#ie# #on("b")##ib#port intern#ie##off("b")# hinterlegt.
+
+
+- Der Aufruf #on("bold")##ib#definiere netz#ie##off("bold")# leitet eine #ib#Netzdefinition#ie# in der #ib#Datei#ie# #on("bold")##ib#netz#ie##off("bold")# ein. Dabei
+ werden alle augenblicklichen Netzkommunikationen gelöscht. Die Tasks #on("b")##ib#net port#ie#
+ (k)#off("b")#, wobei #on("b")#k#off("b")# die #ib#Kanalnummer#ie# ist, und #on("b")##ib#net timer#ie##off("b")# werden gelöscht.
+
+ Dieser Aufruf muß vor den Aufrufen von #on("bold")##ib#starte kanal#ie#, #ib#erlaube#ie#, #ib#sperre#ie#, #ib#routen#ie#,
+ #ib#aktiviere netz#ie# und #ib#list option#ie##off("bold")# erfolgen.
+
+
+- PROC #ib#sperre#ie# (INT CONST a,z)
+ bewirkt, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# keine Manageraufrufe an Tasks dieser Station
+ geben dürfen (Genauer gesagt werden sendecodes > 6 nicht weitergeleitet, son­
+ dern ein errornak mit dem Text "#ib(4)#kein Zugriff auf Station#ie(4)#" zurückgeschickt).
+
+ Dieser Aufruf muß vor dem ersten #on("bold")##ib#starte kanal#ie##off("bold")# erfolgen.
+
+
+- PROC #ib#erlaube#ie# (INT CONST a,z)
+ bewirkt, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# Manageraufrufe an Tasks dieser Station geben
+ dürfen.
+
+ Dieser Aufruf muß vor dem ersten #on("bold")##ib#starte kanal#ie##off("bold")# erfolgen.
+
+ Beispiel: Alle Stationen außer 8 und 10 sollen #ib#gesperrt#ie# sein:
+
+ #ib#sperre#ie# (1,127); erlaube (8,8); erlaube (10,10)
+
+ Hinweis: 127 ist z.Zt. die maximale #ib#Stationsnummer#ie(1," maximale")#.
+
+
+- PROC #ib#routen#ie# (INT CONST a,z,k)
+ legt fest, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# an #ib#Kanal#ie# #on("bold")#k#off("bold")# direkt angeschlossen sind. Sen­
+ dungen dieser Stationen werden nur bearbeitet, wenn sie über diesen Kanal her­
+ einkommen (siehe 1.7.). Fehlt für eine Station ein entsprechender Routenaufruf, so
+ darf sie über einen beliebigen #ib#Netzkanal#ie# angeschlossen sein. Dies wird dann von
+ #on("bold")##ib#routen aufbauen#ie##off("bold")# ermittelt.
+
+ PROC routen (INT CONST a,z,k,zw)
+ legt fest, daß die Stationen #on("bold")#a#off("bold")# bis #on("bold")#z#off("bold")# indirekt über die #ib#Knotenstation#ie# #on("bold")#zw#off("bold")# angeschlos­
+ sen sind, und #on("b")#zw#off("b")# am Kanal #on("bold")#k#off("bold")# hängt.
+
+
+- PROC #ib#starte kanal#ie# (INT CONST k,m,q)
+ startet eine #ib#Netztask#ie# am #ib#Kanal#ie# #on("bold")#k#off("bold")# im Modus #on("bold")#m#off("bold")# [4]. Dabei wird mit #on("bold")#q#off("bold")# die Anzahl
+ paralleler #ib#Empfangsströme#ie# festgelegt. Dadurch kann erreicht werden, daß der
+ #ib#Empfangspuffer#ie# nicht überläuft, indem nicht mehr als #on("b")#q#off("b")# Ströme quittiert werden.
+ Bei #ib#V.24#ie#-#ib#Schnittstelle#ie#n gebe man 3 (ohne #ib#Flußkontrolle#ie#) bzw. 10 (mit Flußkon­
+ trolle) an.
+
+
+- PROC #ib#aktiviere netz#ie#
+ muß als Abschluß in der Datei #on("bold")##ib#netz#ie##off("bold")# aufgerufen werden. Dabei wird die Task vom
+ Terminal abgekoppelt. Falls es bei #on("bold")##ib#definere netz#ie##off("bold")# den #ib#Datenraum#ie# #on("b")##ib#port intern#ie##off("b")#, der
+ die #ib#Route#ie#n enthält, nicht gab, wird #on("bold")##ib#routen aufbauen#ie##off("bold")# aufgerufen.
+
+
+- PROC #ib#listoption#ie##goalpage("listop")#
+ erzeugt eine Task #on("b")##ib#net list#ie##off("b")#, die bei #on("bold")#list#off("bold")# den #ib#Fehlermeldung#ie#sreport und den Zustand
+ aller Netports liefert. Diese Task ist auch über Netz ansprechbar. In der Regel
+ sollte man #on("b")#listoption#off("b")# in der Datei #on("b")#netz#off("b")# aufrufen, es sei denn, das System ist sehr
+ klein.
+
+#page#
+
+1.6. #ib#Fehlersuche#ie# im Netz
+
+#goalpage("1.6")#
+
+#ib#Fehler#ie# im Netz können sich verschiedenartig auswirken. Im folgenden wird auf einige
+Beispiele eingegangen:
+
+Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung '#ib(4)#Station#ie(4, " x antwortet nicht")# 4 antwortet nicht'.
+
+
+#ib#Fehler#ie#möglichkeiten:
+
+ - #ib#Station#ie# 4 ist nicht eingeschaltet.
+ Abhilfe: Station 4 einschalten. Kommando erneut geben.
+
+
+ - #ib#Netztask#ie# an Station 4 ist nicht arbeitsfähig.
+ Abhilfe: Kommando #on("bold")##ib#start#ie##off ("bold")# in der Task "net" auf Station 4.
+
+
+ - Stationsnummern und Boxnummern stimmen nicht überein.
+ Abhilfe: Mit #on("bold")#define station#off ("bold")# #ib#Stationsnummer#ie#n korrigieren (siehe 3.2).
+
+
+ - #ib#Verbindung#ie# Rechner/Box am eigenen Rechner oder an Station 4 fehlt.
+ Abhilfe: Verbindungen überprüfen. Durch Ansprechen einer dritten Station
+ kann oft schnell geklärt werden, welche Rechner/Box-Verbindung
+ defekt sein muß.
+
+
+ - Verbindung der Boxen untereinander defekt.
+ Abhilfe: Fehlende Verbindung, #ib#Masseschluß#ie# und #ib#Dreher#ie# (keine 1:1 Verbin­
+ dung) überprüfen und beheben.
+
+ Hinweis: Liegt z.B. ein Masseschluß vor, so kann es durchaus sein, daß
+ Boxen, die nicht in der Nähe des Masseschlusses stehen, noch
+ miteinander arbeiten können. Man kann aus der Tatsache, daß zwei
+ Boxen miteinander arbeiten können, also nicht schließen, daß man
+ nicht nach diesem Fehler suchen muß.
+
+
+
+Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt keine Reaktion.
+
+
+ - Station 4 ist während dieser Sendung zusammengebrochen.
+ Abhilfe: Station 4 wieder starten. Die Bearbeitung des #on("bold")##ib#list#ie##off ("bold")#-Kommandos wird
+ automatisch wieder aufgenommen.
+
+
+ - PUBLIC auf Station 4 ist nicht im Managerzustand.
+ Abhilfe: PUBLIC in den Managerzustand versetzen.
+
+
+ - #ib#Fehler#ie# in der #ib#Netzhardware#ie#.
+ Überprüfen Sie, ob
+
+ - die Boxen eingeschaltet sind,
+ - die Bereitlampe blinkt (wenn nicht: #ib#RESET#ie# an der Box),
+ - die #ib#V.24#ie#-Kabel richtig stecken,
+ - die Boxen untereinander verbunden sind (1 zu 1 Verbindungen der 5 poli­
+ gen Diodenbuchsen).
+
+
+ - Fehler bei der #ib#Netzinstallation#ie#.
+ Überprüfen Sie, ob
+
+ - alle Stationen an einem #ib#Strang#ie# gleiche oder kompatible Netzmodi einge­
+ stellt haben [4],
+ - alle Stationen an einem #ib#Netzstrang#ie# auf die gleiche #ib#Nutzdatenlänge#ie# einge­
+ stellt sind,
+ - bei der #ib#Kommunikation#ie# über #ib#Knoten#ie# alle Stationen die gleiche Nutzdaten­
+ länge bei indirekten Sendungen eingestellt haben,
+ - die #ib#Route#ie#n auf allen beteiligten Stationen korrekt eingestellt sind.
+
+
+
+Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung '#ib(4)##ib#Collectortask#ie# fehlt#ie(4)#'.
+
+ - Das Kommando #on("b")##ib#start#ie##off("b")# (bzw #on("b")##ib#aktiviere netz#ie##off("b")# in der #ib#Datei#ie# #on("b")#netz#off("b")#) wurde nicht gege­
+ ben. Somit existiert #on("b")##ib#net port#ie##off("b")# nicht.
+ Abhilfe: Kommando #on("bold")#start#off ("bold")# in der Task #on("b")#net#off("b")# geben.
+
+
+ - Die #ib#Netzsoftware#ie# ist auf einen nicht vorhergesehenen #ib#Fehler#ie# gelaufen. Dieser
+ wird im #ib#Report#ie# vermerkt. #on("b")##ib#net port#ie##off("b")# wird dabei gelöscht.
+ Abhilfe: Geben Sie in der Task #on("bold")#net#off("bold")# das Kommando #on("bold")#start#off("bold")#. Dadurch wird die
+ Netzsoftware neu gestartet. Alle Netzkommunikationen dieser Station
+ gehen verloren.
+
+
+
+Beispiel:
+
+ Nach #on("bold")##ib#fetch#ie# ("hugo",4/public)#off("bold")# sind Teile der Datei "hugo" verfälscht.
+
+ - Die #ib#V.24#ie#-#ib#Verbindung#ie# zur Box ist nicht in Ordnung.
+ Abhilfe: Abstand zwischen Rechner und Box verkürzen; #ib#Baud#ie#rate ernie­
+ drigen; durch Wechseln der #ib#V.24#ie#-#ib#Schnittstelle#ie# feststellen, ob diese
+ defekt ist.
+ Hinweis: Die Verbindung zwischen den Boxen ist durch #ib#Prüfsummen#ie# abge­
+ sichert (Hardware).
+
+#page#
+
+1.7. Sicherheit im Netz
+
+#goalpage("1.7")#
+
+Bei Benutzung eines Rechnernetzes tauchen neue #ib#Sicherheitsprobleme#ie# auf. Um sie
+verstehen und eingrenzen zu können, muß man sich mit dem #ib#Sicherheitskonzept#ie# des
+Betriebssystems EUMEL vertraut machen:
+
+Eine Task im EUMEL kann nur manipuliert werden, wenn man sie entweder an ein
+Terminal koppelt oder ihr Sendungen zustellt.
+
+Das Ankoppeln kann über #ib#Paßwort#ie# abgesichert werden. Nach dem Ankoppeln kann
+die Task außerdem selbst bestimmen, wie sie die dann möglichen Eingaben behan­
+delt. So kann z.B. noch ein komplizierter Paßalgorithmus zu durchlaufen sein, bis
+man auf einer offenen Programmierumgebung landet.
+
+Sendungen können eine Task auch nur mit ihrem Einverständnis beeinflussen, da
+eine Sendung nur zugestellt wird, wenn die Task in der Prozedur #on("b")##ib#wait#ie##off("b")# steht. Insbe­
+sondere kann die Task den Absender einer Sendung überprüfen und gewisse Opera­
+tionen nur bei gewissen Absendern zulassen. So lehnt ein #on("b")##ib#global manager#ie##off("b")# z.B. alle
+Dateimanagerkommandos ab, die nicht von Nachkommen (z.B. Söhnen) der Task
+kommt. #on("b")##ib#free global manager#ie##off("b")# hingegen läßt Operationen wie #on("b")##ib#save#ie##off("b")# oder #on("b")##ib#erase#ie##off("b")# von
+beliebigen Tasks, auch von fremden #ib#Station#ie#en, zu. Will man nur bestimmte Fremd­
+stationen zulassen, kann man z.B. folgendes Schema verwenden:
+
+ PROC my #ib#manager#ie#
+ (DATASPACE VAR ds, INT CONST code, phase, TASK CONST source):
+
+ IF station (source) = station (myself) OR station (source) = 10
+ THEN
+ free manager (ds, code, phase, source)
+ ELSE
+ errorstop ("kein Zugriff")
+ FI
+
+ END PROC my manager;
+
+ global manager (PROC my manager)
+#page#
+Hier werden nur #on("b")#save#off("b")# usw. von Tasks der eigenen Station und der Station 10 zuge­
+lassen. Der Rest erhält die #ib#Fehlermeldung#ie# "kein Zugriff".
+
+Dieses Verfahren gewährt nur dann Sicherheit, wenn es nicht möglich ist, daß eine
+beliebige Station sich als Station 10 ausgibt.
+
+Damit das Netz diese Sicherheit garantieren kann, müssen natürlich gewisse phy­
+sische Voraussetzungen erfüllt sein. Wenn z.B. die Station 10 über eine #ib#V.24#ie# ange­
+schlossen ist, aber jeder die Möglichkeit hat, an diese #ib#Schnittstelle#ie# seinen eigenen
+Rechner anzuschliessen, dann kann das Netz natürlich nicht erkennen, ob es mit der
+echten Station 10 verkehrt.
+
+Es muß also sichergestellt sein, daß an Kanälen für das Netz nicht manipuliert werden
+kann. Bei einem #ib#Strang#ie# (Anschluß über #ib#Netzbox#ie#en) heißt das für die Boxen, daß sie
+nur #ib#Telegramm#ie#e weitervermitteln, die die eingestellte #ib#Quellstationsnummer#ie# enthalten.
+Sonst könnte jemand, der an denselben Strang wie #ib#Station#ie# 10 angeschlossen ist,
+#ib#Telegramm#ie#e erzeugen, die so aussehen, als kämen sie von 10.
+
+Die #ib#Netzsoftware#ie# ihrerseits darf nur Telegramme auswerten, die über die richtige
+#ib#Route#ie# (#ib#Kanal#ie# und #ib#Knotenstation#ie#) einlaufen.
+
+Leider hat dies die unangenehme Konsequenz, daß man automatisches Aufbauen und
+Ändern von Routen verbieten muß, wodurch die Wartung der #ib#Netzkonfiguration#ie#
+erschwert wird.
+
+Diese Version der #ib#Netzsoftware#ie# bietet den folgenden Kompromiß an: Nur für sicher­
+heitsrelevante #ib#Stationen#ie(1,", sicherheitsrelevante")# (im Beispiel Station 10) muß in der #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# die Route
+angegeben werden. Dies muß in allen Stationen geschehen, für die die Station
+sicherheitsrelevant ist, und in allen #ib#Knoten#ie# dazwischen.
+
+Für nicht sicherheitsrelevante Stationen werden #ib#Routeninformationen#ie# automatisch
+aufgebaut und geändert.
+
+Hinweis:
+Man wird oft ohne sicherheitsrelevante Stationen auskommen, indem man auf Ebenen
+oberhalb der Netzebene Paßwortkontrollen einführt. So ist es z.B. ja möglich, Dateien
+durch Paßworte zu schützen. Ein weiteres Beispiel ist ein #ib#Printerserver#ie#, der nur
+ausdruckt, wenn eine mitgegebene Abrechnungskennung stimmt. Dabei ist es sogar
+wünschenswert, daß die #ib#Station#ie# irrelevant ist, die den Druckauftrag gibt.
+#pagenr ("%",21)##setcount (1)##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#Teil 2 : Arbeitsweise der Netzsoftware
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right#GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+#page#
+
+Teil 2: Arbeitsweise der Netzsoftware
+#goalpage("2")#
+
+
+
+2.1. Die Netztask
+#goalpage("2.1")#
+
+
+In diesem Kapitel wird beschrieben, wie eine #ib#Netztask#ie# in das System eingebettet ist
+und welche Aufgaben sie hat. Unter Einhaltung dieser Konzepte kann die ausgeliefer­
+te Netzsoftware so geändert werden, daß sie beliebige andere #ib#Netzhardware#ie# unter­
+stützt. Die Netzsoftware ist so gegliedert, daß i.allg. nur eine hardwareabhängige
+Komponente ausgetauscht werden muß (siehe Teil 3).
+
+Die Kommunikation zwischen Tasks im EUMEL-Betriebssystem basiert auf einem
+#ib#Rendezvouskonzept#ie#: Die #ib#Zieltask#ie# einer Sendung muß empfangsbereit sein, wenn die
+#ib#Quelltask#ie# sendet.
+
+Die Kommunikationsprozeduren auf der niedrigsten Ebene sind #on("bold")##ib#send#ie##off ("bold")# (Senden) und
+#on("bold")##ib#wait#ie##off ("bold")# (Warten auf Empfang). Bei der Kommunikation werden ein Integer #on("bold")#code#off ("bold")# und ein
+#ib#Datenraum#ie# #on("bold")#dr#off ("bold")# übergeben. #on("bold")#code#off ("bold")# muß >= 0 sein, da negative Codes systemintern ver­
+wandt werden. Ist die empfangende Task an einen #ib#Kanal#ie# gekoppelt (#on("bold")##ib#continue#ie##off ("bold")#), so
+führt eine Zeicheneingabe auf diesem Kanal dazu, daß eine Sendung mit dem Code
+-4 ankommt. Die Eingabedaten müssen mit den üblichen #ib#Eingabeprozeduren#ie# (#on("bold")##ib#inchar#ie##off ("bold")#
+usw.) abgeholt werden. Der übermittelte #ib#Datenraum#ie# und die Absendertask sind dabei
+ohne Bedeutung und dürfen nicht interpretiert werden.
+
+Die Prozedur #on("bold")#send#off ("bold")# hat einen #ib#Rückmeldeparameter#ie#, der besagt, ob die Sendung
+übermittelt wurde. Gibt es die Zieltask nicht oder steht sie nicht im #on("bold")#wait#off ("bold")#, so kann die
+Sendung nicht übermittelt werden.
+
+Ein Entwicklungskriterium für das EUMEL-Netz war es, möglichst wenig Unterstüt­
+zung von der virtuellen EUMEL-Maschine (#ib#EUMEL0#ie#) zu fordern, damit weitgehend in
+ELAN programmiert werden kann. Dadurch ist es möglich, eine (privilegierte) Task mit
+der Netzabwicklung zu betrauen.
+#page#
+Zunächst wird auf die #ib#EUMEL0#ie#-Unterstützung eingegangen:
+
+a) Es gibt die Prozedur #on("bold")##ib#define collector#ie##off ("bold")#, mit der die für das Netz verantwortliche
+ Task der EUMEL0-Maschine bekannt gemacht wird. Diese Task wird im fol­
+ genden #ib#Collector#ie# genannt.
+
+b) Es gibt die Prozedur #on("bold")##ib#define station#ie##off ("bold")#, die für den Rechner eine #ib#Stationsnummer#ie#
+ einstellt. Anhand dieser Nummer werden die Rechner eines Netzes unterschie­
+ den. Das Einstellen bewirkt, daß für alle Tasks die Stationsnummer in ihre
+ #ib#Task-Id#ie# eingetragen wird (Task-Id's sind die Werte, die der Typ TASK anneh­
+ men kann).
+
+c) Der Befehl #on("bold")##ib#station#ie# (task)#off ("bold")# liefert die Stationsnummer der #on("bold")#task#off ("bold")#. So liefert z.B.
+ #on("bold")##ib#station#ie# (myself)#off ("bold")# die #ib#Stationsnummer#ie# des eigenen Rechners.
+
+d) Eine Sendung, deren #ib#Zieltask#ie# auf einem anderen Rechner liegt (also station (ziel)
+ <> station (myself)), wird auf die #ib#Collectortask#ie# geleitet.
+
+e) Es gibt eine Prozedur #on("bold")##ib#collected destination#ie##off ("bold")#, die es dem Collector erlaubt, die
+ eigentliche Zieltask einer auf ihn geleiteten Sendung zu erfahren.
+
+f) Es gibt eine Variante der Prozedur #on("bold")##ib#send#ie##off ("bold")#, die es dem Collector gestattet, der
+ #ib#Zieltask#ie# eine andere Task als Absender vorzutäuschen.
+
+g) Es gibt eine spezielle #ib#Task-Id#ie# #on("bold")##ib#collector#ie##off ("bold")#, durch die der augenblicklich eingestell­
+ te #ib#Collector#ie# erreicht wird. Diese wird als Zieltask beim Aufruf der Vermittlungs­
+ dienste angegeben (siehe S. #topage("collector")#). Eine Sendung an #on("bold")#collector#off ("bold")# wird von EUMEL0
+ an den derzeitig eingestellten Collector geschickt.
+
+Ein Collector kann also auf drei Wegen von den übrigen Tasks desselben Rechners
+Sendungen erhalten:
+
+ 1. Über ein normales #on("b")#send#off("b")# (z.B. bei #on("bold")#list (/"net port")#off ("bold")#, wenn #on("b")#net port#off("b")# der derzeitige
+ #ib#Collector#ie# ist),
+
+ 2. über ein #on("b")#send#off("b")# an die Task #on("bold")#collector#off ("bold")# (s.u.) und
+
+ 3. als umgeleitete Sendung (z.B. bei #on("bold")#list#off ("bold")# an eine Task auf einem anderen
+ Rechner).
+
+Der Collector kann diese Fälle anhand von #on("bold")#collected destination#off ("bold")# unterscheiden.
+
+Die Punkte d) bis f) dienen dazu, den Collector für über Netz kommunizierende Tasks
+unsichtbar zu machen: Der Collector taucht nicht als Ziel oder #ib#Quelle#ie# von Sendungen
+auf. Das ist notwendig, damit normale Tasks sich nicht darum kümmern müssen, ob
+eine Sendung übers Netz geht oder im eigenen Rechner bleibt.
+
+Wenn ein #ib#Datenraum#ie# an einen anderen Rechner geschickt wird, muß der gesamte
+Inhalt (z. Zt. max. 1 MB) übertragen werden. Dies macht bei der üblichen Netzhard­
+ware eine Zerlegung in #ib#Paket#ie#e nötig [5]. Bei der Zerlegung eines Datenraumes in
+Pakete (#ib#Telegramm#ie#e) gelten folgende Einschränkungen:
+
+ - Ein Paket kann maximal eine #ib#Datenraumseite#ie# als #ib#Nutzdaten#ie# enthalten.
+
+ - Die #ib#Nutzdatenlänge#ie# ist für einen #ib#Übertragungsweg#ie# konstant.
+
+ - Alle Stationen eines #ib#Netzstrang#ie#s senden mit gleicher Nutzdatenlänge (#on("b")##ib#data
+ length#ie##off("b")#).
+
+ - Bei indirekter #ib#Kommunikation#ie(1,"indirekte")# (über #ib#Knoten#ie#) muß die Nutzdatenlänge für in­
+ direkte Verbindungen (#on("b")##ib#data length via node#ie##off("b")#) auf allen beteiligten Stationen
+ gleich eingestellt sein.
+
+
+Für Netze stehen spezielle Blockbefehle zur Verfügung:
+
+
+g) #ib#blockin#ie# / #ib#blockout#ie# (dr,seite,512+abstand,anzahl,rest)
+
+ Es werden maximal #on("bold")#anzahl#off ("bold")# Bytes transferiert. In #on("bold")#rest#off ("bold")# wird zurückgemeldet, wie
+ viele Bytes nicht bearbeitet wurden (z.B. weil der #ib#Kanal#ie# nichts anliefert). Bear­
+ beitet werden die Bytes
+
+ #on("bold")#seite#off ("bold")# * 512 + #on("bold")#abstand#off ("bold")#
+
+ bis maximal
+
+ #on("bold")#seite#off ("bold")# * 512 + #on("bold")#abstand#off ("bold")# + #on("bold")#anzahl#off ("bold")# - 1
+
+ Der Kanal, an den die Task gekoppelt ist, wird dabei über #ib#Stream-IO#ie# (d.h.
+ #on("bold")##ib#incharety#ie##off ("bold")#, bei #on("bold")#blockin#off ("bold")# bzw. #on("bold")#out#off ("bold")# bei #on("bold")#blockout#off ("bold")#) angesprochen.
+
+ Hinweis: Die Anforderung darf nicht über #ib#Seitengrenze#ie# gehen, d.h.
+
+ #on("bold")#abstand#off ("bold")# + #on("bold")#anzahl#off ("bold")# <= 512
+
+ muß erfüllt sein.
+
+
+Eine Netzsendung läuft wie folgt ab:
+
+Die Task q auf Rechner rq mache ein #on("bold")##ib#send#ie##off ("bold")# an die Task z auf Rechner rz.
+
+1. Die Prozedur #on("bold")#send#off ("bold")# ist ein #ib#EUMEL0#ie#-Befehl. Die EUMEL0-Ebene erkennt, daß die
+ Sendung an die #ib#Station#ie# rz geht, da die #ib#Stationsnummer#ie# in der #ib#Task-Id#ie# enthalten
+ ist. Daher wird die Sendung zum #ib#Collector#ie# umgeleitet, den EUMEL0 wegen der
+ Einstellung durch #on("bold")##ib#define collector#ie##off ("bold")# kennt, umgeleitet.
+
+2. Die Task Collector empfängt über #on("bold")##ib#wait#ie##off ("bold")# den #ib#Datenraum#ie#, den #ib#Sendecode#ie# und die
+ Absendertask q. Die #ib#Zieltask#ie# z erfährt sie durch #on("bold")##ib#collected destination#ie##off ("bold")#.
+
+3. Der Collector nimmt Kontakt mit dem Collector des Rechners #on("b")#rz#off("b")# auf, dessen Sta­
+ tionsnummer ja #on("bold")##ib#station#ie#(z)#off ("bold")# ist, und übermittelt diesem Sendecode, #ib#Quelltask#ie# (q),
+ eigentliche Zieltask (z) und den #ib#Datenraum#ie#. Da die Collectoren in ELAN geschrie­
+ ben sind, können sie an beliebige #ib#Netzhardware#ie# und #ib#Protokoll#ie#e angepaßt werden.
+
+4. Der #ib#Collector#ie# auf Rechner #on("b")#rz#off("b")# verwendet das spezielle #on("bold")#send#off ("bold")#, um der Zieltask die
+ Sendung zuzustellen. Dadurch erscheint nicht der Collector, sondern die Task #on("b")#q#off("b")#
+ als Absender der Sendung.
+
+Zur Abwicklung der #ib#Vermittlungsebene#ie# (siehe S. #topage("vermittlung")#) muß der Collector noch spe­
+zielle Funktionen beherrschen. Diese sind
+
+ der #on("b")##ib#/#ie#-Operator#off("b")# (Taskname in #ib#Task-Id#ie# wandeln) und
+ die #on("b")##ib#name#ie##off("b")#-Prozedur (Task-Id in Namen wandeln).
+
+Der #on("b")#/#off("b")#-Operator macht eine Sendung an den #on("bold")##ib#collector#ie##off ("bold")#, wobei im #ib#Datenraum#ie# der Name
+der Task steht und der #ib#Sendecode#ie# gleich der Stationsnummer ist (siehe [6] ). Der
+#ib#Collector#ie# setzt sich mit dem Collector dieser Station in Verbindung, damit dieser die
+Task-Id ermittelt und zurückschickt. Der eigene Collector schickt dann dem #on("b")#/#off("b")#-Oper­
+ator als Antwort einen Datenraum, der die #ib#Task-Id#ie# enthält.
+
+Umgekehrt läuft #on("bold")##ib#name#ie##off ("bold")# ab: Wenn die Task-Id von einer fremden Station ist, schickt
+#on("bold")#name#off ("bold")# eine Sendung an den #on("bold")##ib#collector#ie##off ("bold")#, wobei im Datenraum die Task-Id steht und
+Sendecode = 256 ist. Der Collector entnimmt die #ib#Stationsnummer#ie# der Task aus der
+Task-Id und läßt sich vom entsprechenden Collector den Tasknamen geben. Dieser
+wird der #on("bold")#name#off ("bold")#-Prozedur im Antwortdatenraum übergeben.
+
+Netztasks bauen sich #ib#Routentabellen#ie# auf (#ib#Datei#ie#name #on("b")##ib#port intern#ie##off("b")#). Aufgrund dieser
+Tabellen weiß jede #ib#Netztask#ie#, über welchen #ib#Kanal#ie# und welche #ib#Nachbarstation#ie# eine
+#ib#Zielstation#ie# erreichbar ist. Wenn der #ib#Collector#ie# einen Sendeauftrag erhält, prüft er, ob
+die Zielstation über seinen Kanal erreichbar ist. Wenn nicht, leitet er Parameter und
+#ib#Datenraum#ie# der Sendung an die geeignete Netztask weiter.
+#page#
+
+2.2. Ebenen
+
+#goalpage("2.2")#
+
+In diesem Kapitel werden die #ib#Protokollebenen#ie# für das Netz beschrieben, wie sie die
+ausgelieferte Netzsoftware benutzt und erwartet. Bei anderer Netzhardware als Daten­
+boxen müssen die Ebenen a) bis c) ausgetauscht werden [4]. Unter Einhaltung der im
+vorigen Kapitel beschriebenen Randbedingungen können auch die höheren Ebenen
+geändert werden.
+
+
+a) Physikalische Ebene
+
+ - #ib#Station#ie# <--> Box
+
+ #ib#V.24#ie#-#ib#Schnittstelle#ie# mit #ib#RTS/CTS#ie#-Handshake. Vollduplex.
+
+ - Box <--> Box
+
+ #ib#RS422#ie# über 2 verdrillte Leitungspaare (Takt und Daten).
+
+
+b) Verbindungsebene
+
+ - Station <--> Box
+
+ Asynchron
+ 8 Bit
+ Even Parity
+ 2400/4800/9600/19200 #ib#Baud#ie# einstellbar über Lötbrücken)
+
+ - Box <--> Box
+
+ #ib#SDLC#ie#
+ 400 KBaud
+#page#
+c) #ib#Netzebene#ie#
+#goalpage("quelle")#
+
+ - Station <--> Box
+
+ #ib#Telegrammformat#ie#: #ib#STX#ie#, <n>, <ziel>, <#ib#quelle#ie#>, <(n-4) byte>
+
+ <n> ist #ib#Längenangabe#ie# ( 8 <= n <= 160)
+ <ziel>, <quelle> sind #ib#Stationsnummer#ie#n. Diese müssen an den jeweiligen
+ Boxen eingestellt sein.
+
+ Box --> Station:
+
+ Ein #ib#Telegramm#ie# kommt nur bei der #ib#Station#ie# an, bei deren Box die Nummer
+ <ziel> eingestellt ist. Dadurch ist ein Mithören fremder #ib#Übertragung#ie# nicht
+ möglich (Datenschutz).
+
+ Zwischen Telegrammen können #ib#Fehlermeldung#ie#en der Box (Klartext) übermittelt
+ werden (z.B. 'skipped x', wenn ein #ib#STX#ie# von der Box erwartet wurde, aber 'x'
+ von der Station ankommt).
+
+ Station --> Box:
+
+ Ein Telegramm wird nur abgeschickt, wenn <#ib#quelle#ie#> mit der eingestellten
+ Nummer übereinstimmt (Datenschutz: Man kann nicht vorschwindeln, eine
+ beliebige Station zu sein, es sei denn, man hat physischen Zugriff zur Box und
+ stellt dort die Stationsnummer um).
+
+ - Box <--> Box
+
+ #ib#Telegrammformat#ie#:
+ FRAME, <ziel>, <#ib#quelle#ie#>, <daten>, <CRC-Code>
+
+ Eine #ib#Längenangabe#ie# ist nicht nötig, da #ib#SDLC#ie# eine Rekonstruktion der Länge
+ erlaubt.
+
+ Telegramme mit falschen #ib#CRC-Code#ie# werden vernichtet. Auf höheren Ebenen
+ muß dies durch #ib#Zeitüberwachung#ie# erkannt und behandelt werden.
+
+#page#
+d) Transportebene
+
+ Diese Ebene wickelt das Rendezvous zwischen einer Task, die #on("bold")##ib#send#ie##off ("bold")# macht, und
+ einer Task, die im #on("bold")##ib#wait#ie##off ("bold")# steht, ab [1].
+
+ Der im #on("bold")#send#off ("bold")# angegebene #ib#Datenraum#ie# wird als Folge von #ib#Seiten#ie# (im EUMEL-
+ Sinne: Pagingeinheit und Allokiereinheit) übermittelt, wobei jede Seite ggf. noch in
+ n Byte große Stücke zerlegt wird. Es werden nur echt allokierte Seiten übermit­
+ telt. Um nicht jedes #ib#Telegramm#ie# voll qualifizieren zu müssen, wird zunächst eine
+ Art virtuelle #ib#Verbindung#ie# durch ein #ib#OPEN#ie#-Telegramm eröffnet. Danach folgen
+ variabel viele #ib#DATA#ie#-Telegramme. Beide Sorten werden durch #ib#QUIT#ie#-Tele­
+ gramme quittiert, um folgende Funktionen zu ermöglichen:
+
+ #ib#Flußkontrolle#ie# (z.B. Zielrechner langsam),
+ Wiederaufsetzen (verlorene Telegramme),
+ Abbruch (z.B. weil Zieltask inzwischen beendet).
+
+ Ein #ib#CLOSE#ie#-Telegramm ist nicht nötig, da das letzte DATA-Telegramm als
+ solches erkannt werden kann (siehe unten).
+#page#
+ - #ib#OPEN#ie#-Telegramm
+
+#clear pos#
+ 0 1 2 3 4 5 6 7 8 9. Byte
++------+------+------+------+-------------+-------------+-------------------+
+I STX I 24 I Ziel IQuelleI Endziel I Endquelle I Strom I
++------+------+------+------+-------------+-------------+-------------------+
+
+ 10 11 12 13 14 15 16 17
++-------------+-------------+---------------------------+
+I Sequenz I Seite I Quelltask I
++-------------+-------------+---------------------------+
+
+ 18 19 20 21 22 23
++---------------------------+-------------+
+I Zieltask I Code I
++---------------------------+-------------+
+
+
+
+ <#ib#ziel#ie#>, <#ib#quelle#ie#> siehe S. #topage("quelle")#
+
+ <#ib#endziel#ie#> Eigentliche #ib#Zielstation#ie#. Ist <ziel> = <endziel>, so ist
+ das #ib#Telegramm#ie# angekommen. Andernfalls muß die Station
+ <ziel> den #ib#Nachbarn#ie# zum Erreichen des <endziel> als
+ neues <ziel> einsetzen und das Telegramm an diesen
+ Nachbarn weiterleiten.
+
+ <#ib#endquelle#ie#> Eigentliche #ib#Absenderstation#ie#. <quelle> ist dagegen immer
+ die Nummer der sendenden #ib#Nachbarstation#ie#.
+
+ <#ib#strom#ie#> Die #ib#Stromnummer#ie# identifiziert die virtuelle #ib#Verbindung#ie#. Sie
+ muß in den #ib#QUIT#ie#-Telegrammen angegeben werden.
+
+ <#ib#sequenz#ie#> -1 (Kennzeichen für OPEN)
+
+ <#ib#seite#ie#> Nummer der ersten echt allokierten #ib#Seite#ie# des #ib#Datenraum#ie#s
+ (=-1, falls Nilspace)
+
+ <#ib#quelltask#ie#> #ib#Task-Id#ie# der sendenden Task
+
+ <#ib#zieltask#ie#> Task-Id der empfangenden Task
+
+ <code> Wert des im #on("bold")##ib#send#ie##off ("bold")# angegebenen Codes
+#page#
+ - #ib#DATA#ie#-Telegramm
+
+
+
+
+
+ 0 1 2 3 4 5 6 7 8 9. Byte
++------+------+------+------+-------------+-------------+-------------------+
+I STX I LängeI Ziel IQuelleI Endziel I Endquelle I Strom I
++------+------+------+------+-------------+-------------+-------------------+
+
+ 10 11 12 13 14
++-------------+-------------+-----------------------------------------------+
+I Sequenz I Seite I n Byte Daten (Länge = 14 + n) I
++-------------+-------------+-----------------------------------------------+
+
+
+ <#ib#laenge#ie#> Gesamtlänge des Telegramms.
+ #on("b")#laenge#off("b")# = #on("b")##ib#nutzlaenge#ie##off("b")# + 14.
+ Für #on("b")#nutzlaenge#off("b")# sind nur die Werte 64,128,256 und 512
+ zugelassen (siehe 1). #on("b")#laenge#off("b")# wird codiert dargestellt (siehe
+ Teil 3).
+
+
+ <#ib#sequenz#ie#> wird von Telegramm zu Telegramm hochgezählt. Sie dient
+ der Überwachung bzgl. verlorengegangener Telegramme
+ bzw. durch #ib#Zeitüberwachung#ie# verdoppelter Telegramme.
+
+ <#ib#seite#ie#> Nummer der x-ten echt allokierten Seite des #ib#Datenraum#ie#s
+ (x = ((<sequenz> DIV anzahl pakete pro seite) + 2)
+
+ <n byte> #ib#Nutzinformation#ie#. Diese gehört zur #ib#Adresse#ie# a des Daten­
+ raums.
+
+ a =
+ N (<sequenz> DIV anzahl pakete pro seite + 1) * 512
+ + (<sequenz> MOD anzahl pakete pro seite) * n
+
+ wobei N (x) die Nummer der x-ten Seite und
+ n die #ib#Nutzdatenlänge#ie# ist.
+
+ Aus den Formeln ergibt sich, daß diese Nummer schon in
+ einem vorhergehenden DATA/OPEN-Telegramm über­
+ mittelt wurde (im Feld <seite>).
+
+ - #ib#QUIT#ie#-Telegramm
+
+
+ 0 1 2 3 4 5 6 7 8 9. Byte
++------+------+------+------+-------------+-------------+-------------------+
+I STX I 12 I Ziel IQuelleI Endziel I Endquelle I Strom I
++------+------+------+------+-------------+-------------+-------------------+
+
+ 10 11
++-------------+
+I Quit I
++-------------+
+
+
+
+ <#ib#strom#ie#> muß die #ib#Stromnummer#ie# sein, die in dem #ib#OPEN#ie#/#ib#DATA#ie#­
+ Telegramm stand, das quittiert wird.
+
+ <quit> 0 : ok. Nächstes Telegramm schicken.
+
+ -1: #ib#Übertragung#ie# neu starten (mit #ib#OPEN#ie#), weil die Emp­
+ fangsstation das OPEN nicht erhalten hat.
+
+ -2: Übertragung ca. 20 Telegramme zurücksetzen.
+
+ -3: Übertragung abbrechen.
+
+ -4: #ib#Quittung#ie# für letztes Telegramm einer Sendung.
+
+
+e) #ib#Vermittlungsebene#ie##goalpage("vermittlung")# #goalpage("collector")#
+
+ Diese Ebene ist dafür zuständig, Namen von Tasks auf anderen Stationen in
+ #ib#Task-Id#ie#'s (Werte des Typs TASK) zu wandeln und umgekehrt. Hierzu wird im
+ entsprechenden #ib#OPEN#ie#-Telegramm der Code -6 (bzw. -7) als <code> ein­
+ getragen. Die #ib#Netzempfangstask#ie# erkennt diese #ib#Codes#ie# und wickelt die Aufgaben
+ selbst ab, so daß es dabei nicht nötig ist, irgendeine Task-Id der #ib#Zielstation#ie# zu
+ kennen.
+
+ Dieses Verfahren ist möglich, weil im #on("bold")##ib#send#ie##off ("bold")# nur positive Codes erlaubt sind.
+#page#
+f) #ib#Höhere Ebenen#ie#
+
+ Höhere Ebenen sind nicht mehr netzspezifisch. Sie basieren alle auf dem Send/
+ Wait-Konzept des EUMEL. So gibt es z.B. den #on("bold")##ib#global manager#ie##off ("bold")#, der Aufbewah­
+ rung und Zugriff von #ib#Datei#ie#en in einer Task regelt. Dabei darf diese Task (bei der
+ Variante #on("bold")##ib#free global manager#ie##off ("bold")#) auf einer beliebigen #ib#Station#ie# im Netz liegen. Wegen
+ des #ib#Rendezvous-Konzept#ie#s können beliebige Sicherheitsstrategien benutzt werden
+ (z.B.: keine Dateien an Station 11 ausliefern). Von großem Wert ist z.B., daß
+ man ohne weiteres das Archiv (Floppylaufwerk) einer anderen Station anmelden
+ und benutzen kann, wodurch eine einfache Konvertierung von Floppyformaten
+ möglich ist. Dies ist möglich, weil auch die Archiv-Task der Stationen sich an
+ das Globalmanagerprotokoll halten.
+
+
+
+
+
+Bemerkungen
+
+#ib#Fehlerbehandlung#ie# besteht bis Ebene c) darin, fehlerhafte #ib#Telegramm#ie#e einfach zu
+entfernen. Die Ebene d) überwacht den Netzverkehr sowieso über #ib#Timeout#ie#s, die eine
+Wiederholung eines Telegrammes bewirken, wenn die #ib#Quittung#ie# ausbleibt.
+
+Da bei der sendenden #ib#Station#ie# der ganze #ib#Datenraum#ie# zur Verfügung steht, ist eine
+#ib#Fenstertechnik#ie# (wie bei #ib#HDLC#ie#) nicht nötig. Es kann zu jedem Zeitpunkt um beliebig
+viele Telegramme zurückgesetzt werden.
+
+Da im EUMEL eine #ib#Textdatei#ie# ein #ib#Datenraum#ie# mit sehr komplexer Struktur ist (wegen
+der Insert/Delete-Möglichkeiten, ohne den Rest der #ib#Datei#ie# zu verschieben), ist es ein
+hoher Aufwand, von einem fremden Betriebssytem aus eine Textdatei in das
+EUMEL-Netz zu senden. Für solche Zwecke muß noch eine einfachere Dateistruktur
+definiert und entsprechende Dateikonverter erstellt werden.
+#page#
+
+2.3. Stand der Netzsoftware
+
+#goalpage("2.3")#
+
+Das EUMEL-System wickelt die Prozedur #on("bold")##ib#send#ie##off("bold")# über das Netz ab, wenn die Sta­
+tionsnummer der #ib#Zieltask#ie# ungleich der eigenen #ib#Stationsnummer#ie# ist. Umgekehrt kann
+man der von der Prozedur #on("bold")##ib#wait#ie##off("bold")# gelieferten Absendertask die #ib#Absenderstation#ie# entneh­
+men (siehe Prozedur #on("bold")##ib#station#ie##off("bold")# in Teil 1).
+
+Anders als bei einem #on("bold")##ib#send#ie##off("bold")# innerhalb einer Station meldet ein #on("bold")#send#off("bold")# an eine Task einer
+fremden Station immer 0 zurück (Task gibt es und Task war im wait), obwohl dies
+nicht der Fall sein muß. Ist die Sendung vollständig zur Zielstation übertragen, so
+versucht der dortige #ib#Collector#ie# diese hundertmal im Sekundenabstand zuzustellen.
+Bleibt das erfolglos, wird die Sendung vernichtet.
+#pagenr ("%", 33)##setcount (1)##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#Teil 3 : Netz Hardware Interface
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right#GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+#page#
+
+Teil 3: Netz-Hardware-Interface
+
+
+#goalpage("3")#
+
+
+3.1. Einführung
+
+ #goalpage("3.1")#
+
+In diesem Teil der Netzbeschreibung wird die #ib#Schnittstelle#ie# beschrieben, über die
+#ib#Netzhardware#ie# (also #ib#Datenbox#ie#en, #ib#Netzbox#ie#en oder Netzkarten) an die EUMEL-Netz­
+Software angepaßt werden kann. Dieser Teil der Beschreibung ist also nur für Netz­
+implementatoren wichtig.
+
+Das EUMEL-Netz wurde dazu konzipiert, zwei oder mehr EUMEL-Rechner über
+#ib#V.24#ie#-Leitungen oder Datenboxen miteinander zu vernetzen. Dem heutigen Stand der
+Technik entsprechend, werden auf dem Markt eine Reihe von Möglichkeiten ange­
+boten, um PC's zu vernetzen. Diese Netze unterscheiden sich auch dadurch, daß
+unterschiedliche Medien zur Datenübertragung benutzt werden. Das #ib#EUMEL-
+Datenboxen-Netz#ie# benutzt Telefonkabel, #ib#Ethernet#ie# beispielsweise Koax-Kabel. Auch
+Lichtleiter werden zur Datenübertragung benutzt. Entsprechend gibt es eine ganze
+Menge Hardware (#ib#Treiber#ie#, Netzzugangsgeräte, Datenboxen, Anschlußkarten), die die
+Kopplung zwischen einem #ib#I/O-Kanal#ie# eines Rechners und dem Übertragungsmedium
+(Kabel) übernimmt. Das Netz-Hardware-Interface soll als #ib#Schnittstelle#ie# zwischen der
+Netz­Software und dem Treiber dienen. Damit wird es möglich, mehrere EUMEL-
+Rechner über verschiedene (Teil-) Netze (in dieser Beschreibung Stränge genannt)
+und unterschiedliche #ib#Netzhardware#ie# (Treiber) miteinander zu verbinden. Für den
+EUMEL-Benutzer soll dabei kein Unterschied in der Benutzung des EUMEL-Netzes
+feststellbar sein.
+#page#
+Neben unterschliedlichen Übertragungsmedien und Treibern gibt es weitere Unter­
+schiede zwischen Netzen:
+
+ - in der Netztopologie (Bus-, Ring- oder Sternnetze),
+
+ - in den Netzzugangsverfahren (Token passing, time slice token, slotting oder
+ CSMA/CD),
+
+ - in der #ib#Übertragungsgeschwindigkeit#ie#,
+
+ - im Aufbau der einzelnen #ib#Pakete#ie(1,", Aufbau der")# (#ib#Netztelegramm#ie#e).
+
+Alles, was mit den ersten drei Punkten zusammenhängt, wird von den Netzzugangs­
+geräten behandelt.
+
+Der Paketaufbau aber muß zumeist im Rechner geschehen und kann in den seltens­
+ten Fällen ganz vom Treiber übernommen werden. Ebenso kann der Treiber aus den
+empfangenen Paketen nicht immer die Teile herausfiltern, die von der EUMEL-
+#ib#Netzsoftware#ie# gebraucht werden. Diese Aufgaben übernimmt das #ib#Netz-Hardware-
+Interface#ie#. Das Netz-Hardware-Interface stellt die #ib#Verbindung#ie# zwischen EUMEL-
+#ib#Netzsoftware#ie# und den verschiedenen Netzhardwarearten dar. Ähnlich wie bei den
+Drucker- und Terminal-Anpassungen wurde ein hardwareabhängiger Teil aus der
+Netzsoftware abgetrennt und in einem eigenen #ib#Paket#ie# zusammengefaßt. Beim Start
+des Netzes wird durch Angabe des entsprechenden #ib#Netzmodus#ie# für den jeweiligen
+#ib#Kanal#ie# die entsprechende Anpassung für den benutzten Treiber ausgewählt. Wenn
+andere, neue Treiber angepaßt werden sollen, so müssen lediglich in dem Paket #on("b")##ib#net
+hardware interface#ie##off("b")# die entsprechenden Prozeduren hinzugefügt und die #ib#Sprungleisten#ie#
+(#ib#SELECT#ie#-Statements) erweitert werden.
+
+Durch das #ib#Knotenkonzept#ie# in der #ib#Netzsoftware#ie# ist es möglich, über einen #ib#Knoten­
+rechner#ie# Teilnetze (Stränge), die mit unterschiedlicher #ib#Netzhardware#ie# arbeiten, mitein­
+ander zu verbinden. Es sind dann beispielsweise Verbindungen zwischen Rechnern,
+die über #ib#Ethernet#ie# vernetzt sind, und Rechnern auf dem EUMEL-Datenboxen-Netz
+möglich. Es ist auch möglich, mit einem Rechner Zugang zu einem Netz zu erhalten,
+für das spezielle #ib#Netzhardware#ie# erforderlich ist (Datenboxen, Ethernet-Anschluß). Man
+kann den Rechner über eine Rechner-Rechner-Kopplung (#ib#V.24#ie#) mit einem Rechner
+verbinden, der bereits ans Netz angeschlossen ist, und so (allerdings auf Kosten der
+Leistung des #ib#Knotenrechner#ie#s) Netzhardware einsparen.
+#page#
+
+3.2. Arbeitsweise des
+ Netz-Hardware-Interfaces
+
+
+
+
+
+ #goalpage("3.2")#
+
+Grob vereinfacht kann man sich die Arbeitsweise der #ib#EUMEL-Netz-Software#ie# so vor­
+stellen:
+
+ reset box;
+ REP
+ IF zeichen da THEN lies telegramm ein
+ ELIF telegramm auszugeben THEN gib telegramm aus
+ FI
+ PER .
+
+(Es ist nur der Teil der Software beschrieben, der die Kanalbehandlung betrifft).
+
+
+Das Zusammenspiel zwischen EUMEL-Netz und Netz-Hardware-Interface ge­
+schieht auf folgende Weise:
+
+
+ #on("b")#reset box;#off("b")#
+ REP
+ IF zeichen da THEN #on("b")#next packet start#off("b")#;
+ lies telegramm ein
+ ELIF telegramm auszugeben THEN gib telegramm aus
+ FI
+ PER.
+
+ gib telegramm aus:
+ #on("b")#transmit header#off("b")#;
+ gib eumelnetztelegramm aus;
+ #on("b")#transmit trailer #off("b")#.
+
+Die fett gedruckten Programmteile werden im Netz-Hardware-Interface realisiert, die
+anderen Teile stecken in den darüberliegenden Teilen der EUMEL-Netz-Software.
+#page#
+Beim Senden eines #ib#Telegramm#ie#s wird von der #ib#Netzsoftware#ie# zuerst der #ib#Vorspann#ie# in
+einem #ib#Datenraum#ie# an das Hardware-Interface übergeben (#on("b")##ib#transmit header#ie##off("b")#). Im Hard­
+ware-Interface können aus dem Vorspann die entsprechenden Informationen (Tele­
+grammlänge, #ib#Zielstation#ie# usw.) entnommen werden. Dann wird von der Netzsoftware
+das Telegramm (inklusive Vorspann) per #on("b")##ib#blockout#ie##off("b")# übergeben. Danach wird #on("b")##ib#transmit
+trailer#ie##off("b")# aufgerufen, um dem Hardware-Interface das Ende des Telegramms zu mel­
+den. Beim Empfang ruft die Netzsoftware zuerst die #ib#I/O Control#ie# #ib#Telegrammfreigabe#ie#
+auf [7]. Danach wird das erste #ib#Zeichen#ie# des Telegramms angefordert (#on("b")##ib#next packet
+start#ie##off("b")#). Falls ein #ib#STX#ie# geliefert wurde, wird das Telegramm per #on("b")##ib#blockin#ie##off("b")# eingelesen. Falls
+#ib#Niltext#ie# zurückgeliefert wird, wird von der Netzsoftware #ib#Timeout#ie# angenommen. Alle
+anderen Zeichen werden so interpretiert, als ob Störungen aufgetreten wären. Die
+Netzsoftware übernimmt die #ib#Fehlerbehandlung#ie#. Dazu wird u. U. ein Leerlesen des
+Puffers vom Hardware-Interface verlangt (#on("b")##ib#flush buffers#ie##off("b")#).
+
+Bei der Einstellung der #ib#Nutzdatenlänge#ie# (#on("b")##ib#data length#ie##off("b")#) ist zu beachten, daß
+
+a) alle #ib#Station#ie#en, die an einem #ib#Strang#ie# hängen, auf die gleiche Nutzdatenlänge
+ eingestellt sein müssen.
+
+b) Wenn mehrere Stränge über #ib#Knoten#ie# miteinander verbunden sind, muß die Nutz­
+ länge für Sendungen über Knoten (#on("b")##ib#data length via node#ie##off("b")#) auf allen Stationen des
+ gesamten Netzes gleich eingestellt sein. Die Zusammenfassung oder Aufteilung
+ von #ib#Telegramm#ie#en in Knoten ist nicht möglich.
+
+c) Als mögliche Nutzdatenlänge sind folgende Werte erlaubt:
+
+ 64, 128, 256 und 512 Byte.
+
+ Größere Nutzdatenlängen sind zur Zeit nicht möglich.
+
+d) Je größer die #ib#Nutzdatenlänge#ie# ist, desto geringer ist der Overhead an #ib#Zeichen#ie#,
+ die auf den Rechnern verarbeitet werden müssen. Allerdings muß der Rechner
+ leistungsfähig genug sein, die ankommenden Blöcke schnell genung zu verarbei­
+ ten, und die Netztreiber müssen entsprechend große Puffer haben.
+
+
+Alle implementierten Netzanpassungen sollen in einem Netz-Hardware-Interface
+zusammengefaßt werden. Dies ist notwendig, um über #ib#Knotenrechner#ie# Netzstränge
+verbinden zu können, die mit unterschiedlicher #ib#Netzhardware#ie# arbeiten. So können
+zum Beispiel ein #ib#Strang#ie#, der mit Datenboxen aufgebaut ist, und ein #ib#Ethernet#ie#-#ib#Strang#ie#
+über einen Knotenrechner miteinander verkoppelt werden.
+#page#
+Aus diesem Grund wurden #on("b")#Netzmodi#off("b")# eingeführt. Man kann dadurch, daß die Netz­
+modi, genau wie die #ib#Kanal#ie#angaben, in der #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# niedergelegt sind, ohne Aus­
+tausch einer Softwarekomponente die Netzhardware wechseln. Es gibt auch die
+Möglichkeit, durch verschiedene Netzmodi unterschiedliche Treiber an ein und das­
+selbe Netz anzuschließen. Beispielsweise gibt es für einige Rechnertypen Steckkarten,
+mit denen der Rechner an das Ethernet angeschlossen werden kann. Man kann,
+wenn diese Karten angepaßt sind, den #ib#Ethernet#ie#-Zugang über verschiedene Netz­
+anschlußkarten realisieren.
+
+Das Netz-Hardware-Interface muß folgende Aufgaben übernehmen:
+
+ Bei der Ausgabe an den Treiber:
+
+ - Generieren und Ausgeben des #ib#Paket#ie#headers,
+ - Umsetzen von logischen Stationsadressen (#ib#Stationsnummer#ie#n) in phy­
+ sische #ib#Adresse#ie#n,
+ - Ausgeben der Daten (EUMEL-Netz-#ib#Telegramm#ie#e),
+ - Generieren und Ausgeben des Trailers und evtl. Auffüllen des Pakets mit
+ #ib#Füllzeichen#ie#, falls auf dem Netz eine Mindestlänge für Pakete gefordert
+ wird.
+
+ Bei der Eingabe vom Treiber:
+
+ - Weglesen von #ib#Füllzeichen#ie#,
+ - Prüfen der #ib#Adresse#ie#n,
+ - Weglesen von #ib#Paket#ie#teilen, die in der EUMEL-Netz-Software nicht
+ gebraucht werden.
+
+ Weiterhin können Funktionen wie
+
+ - Reset des Treibers,
+ - Prüfung, ob Stationsadresse und #ib#Adresse#ie# im Treiber übereinstimmen,
+ - Statistik und Service
+
+ durch das Netz-Hardware-Interface übernommen werden.
+
+Dazu wird ein Satz von Prozeduren über die #ib#DEFINES#ie#-#ib#Schnittstelle#ie# des Netz-
+Hardware-Interfaces zur Verfügung gestellt. Wenn neue Treiber oder Netzarten
+implementiert werden sollen, so muß an diesem Interface nichts geändert werden. Die
+herausgereichten Prozeduren realisieren #ib#Sprungleisten#ie# (#ib#SELECT#ie#-Statements), über
+die durch Erweiterung (#ib#CASE#ie#) die Prozeduren erreicht werden können, die den ent­
+sprechenden #ib#Netzmodus#ie# realisieren. Außerdem werden Informationsprozeduren für die
+darüberliegenden Programmteile zur Verfügung gestellt.
+#page#
+
+3.3. Netztreiber
+
+ #goalpage("3.3")#
+Unter #ib#Netztreiber#ie#n versteht man die Einheiten, die den Anschluß des Rechners an ein
+Netz realisieren. Das können #ib#Netzbox#ie#en sein, die mit dem Rechner über eine #ib#V.24#ie#-
+Leitung verbunden sind, aber auch Anschlußkarten, die direkt auf den Datenbus des
+Rechners gehen. Falls die #ib#Schnittstelle#ie# der Treiber-Hardware eine andere als die
+serielle #ib#V.24#ie# ist, muß in der Regel eine Anpassung für die Hardware im #ib#SHard#ie# vorge­
+nommen werden.
+
+Falls der Treiber über eine serielle #ib#V.24#ie#-#ib#Schnittstelle#ie# mit dem Rechner verbunden
+ist, wie das auch bei der direkten Kopplung oder dem Datenboxennetz der Fall ist,
+wird die hohe #ib#Übertragungsgeschwindigkeit#ie# auf dem eigentlichen Netz durch die
+relativ geringe Übertragungsgeschwindigkeit auf der #ib#V.24#ie#-#ib#Schnittstelle#ie# zwischen
+Rechner und Treiber (Box) gebremst. Über andere Schnittstellen im Rechner, wenn
+sie mit #ib#Stream I/O#ie# [7] betrieben werden, kann man dies vermeiden. Diese Schnitt­
+stellen müssen vom SHard bedient werden.
+
+Wenn in den Rechner integrierte Netztreiber (Netzanschlußkarten) benutzt werden
+sollen, so muß in der Regel die Behandlung dieser Netzanschlußkarte im SHard
+durchgeführt werden.
+
+Um effizient implementieren zu können, sollte darauf geachtet werden, daß möglichst
+wenig zusätzliche #ib#Zeichen#ie# von der #ib#Netzsoftware#ie# bzw. dem Netz-Hardware-Inter­
+face bearbeitet werden müssen. Das Auffüllen von Paketen auf eine Mindestlänge
+sollte möglichst vom Treiber gemacht werden, ebenso wie das Weglesen dieser
+Zeichen.
+
+Um einen sicheren und effektiven Netzbetrieb zu garantieren, sollten die Treiber
+folgende Eigenschaften haben:
+
+ - Die #ib#Stationsadresse#ie# ist im Treiber festgelegt, sie soll nicht ohne weiteres
+ verändert werden können (Datenschutz).
+ - Der Treiber reicht nur #ib#Paket#ie#e mit richtiger #ib#Zieladresse#ie#, keine #ib#Broad- oder
+ Multicasts#ie# an die Netzsoftware weiter.
+ - Der Treiber sendet nur #ib#Paket#ie#e mit richtiger #ib#Absenderadresse#ie# bzw. setzt die
+ Absenderadresse selbst ein.
+ - Die am Treiber eingestellte #ib#Adresse#ie# kann abgefragt werden, oder es wird,
+ wenn ein Paket mit falscher #ib#Absenderadresse#ie# vom Rechner kommt, eine
+ #ib#Fehlermeldung#ie# an den Rechner gegeben. Die Fehlermeldung muß durch das
+ Netz-Hardware-Interface in den #on("b")##ib#report#ie##off("b")# eingetragen werden.
+ - Falls Pakete mit #ib#Füllzeichen#ie# aufgefüllt werden müssen, sollten die Füll­
+ zeichen durch den Treiber generiert und beim Empfang wieder entfernt
+ werden.
+ - Falls mehrere Betriebsmodi möglich sind, so sollten sie softwaremäßig
+ einstellbar sein.
+ - Falls die Treiber über eine serielle #ib#Schnittstelle#ie# an den Rechner angeschlos­
+ sen werden, so sollte der Treiber konfigurierbar sein. In jedem Fall sollte die
+ serielle Schnittstelle mit #ib#Flußkontrolle#ie# (#ib#RTS/CTS#ie#) implementiert werden.
+
+Zusätzlich ist ein Transparent-Modus als #ib#Netzmodus#ie# von Vorteil:
+
+ - Der Modus (transparent) kann zu Testzwecken benutzt werden. Beispiels­
+ weise um auch mit Rechnern kommunizieren zu können, die über Netz
+ erreichbar sind, aber kein EUMEL-Netz-#ib#Protokoll#ie# benutzen.
+
+ Modus n: transparent.
+
+ Ausgabeseitig: Das #ib#Paket#ie# wird unverändert ausgegeben.
+ #ib#Adresse#ie#n usw. müssen schon im Paket vor­
+ handen sein. Es wird nicht mit #ib#Füllzeichen#ie#
+ aufgefüllt.
+ Eingabeseitig: Das Paket wird unverändert an die Netzsoft­
+ ware weitergegeben.
+
+#page#
+
+3.4. Prozedurschnittstelle
+ des EUMEL-Netzes
+
+
+
+
+
+ #goalpage("3.4")#
+Im PACKET #on("b")##ib#net hardware interface#ie##off("b")# sind folgende Prozeduren untergebracht:
+
+
+
+ BOOL PROC #ib#blockin#ie#
+ (DATASPACE VAR ds, INT CONST seite, abstand, länge):
+
+ Versucht, #on("b")#länge#off("b")# Zeichen vom #ib#Kanal#ie# einzulesen. Liefert TRUE, wenn alle
+ Zeichen eingelesen wurden, FALSE, wenn innerhalb einer bestimmten
+ Zeit nicht alle #on("b")#länge#off("b")# Zeichen eingelesen werden konnten (z.B. weil der
+ Kanal nicht mehr Zeichen anliefert). Die eingelesenen Zeichen werden im
+ #ib#Datenraum#ie# #on("b")#ds#off("b")# in #ib#Seite#ie# #on("b")#seite#off("b")# ab #on("b")#abstand#off("b")# bis #on("b")#abstand#off("b")# + #on("b")#länge#off("b")# - 1 abge­
+ legt.
+
+ #ib#Fehlerfall#ie#:
+
+ #on("b")#blockin Abbruch#off("b")#
+
+ Es werden weniger #ib#Zeichen#ie# innerhalb einer festgelegten Zeitspanne über
+ den Kanal angeliefert, als mit #on("b")#länge#off("b")# gefordert.
+
+ Passiert z.B., wenn die Kabel während einer Netzübertragung unter­
+ brochen werden, oder wenn die Gegenstelle abgeschaltet wird. Das
+ #ib#Telegramm#ie# wird vernichtet, die Prozedur liefert FALSE, es wird eine
+ entsprechende Meldung im #on("b")##ib#report#ie##off("b")# erzeugt.
+
+ PROC #ib#blockout#ie#
+ (DATASPACE CONST ds, INT CONST seite, abstand, länge):
+
+ Der Inhalt von Seite #on("b")#seite#off("b")# des #ib#Datenraum#ie#s #on("b")#ds#off("b")# wird von #on("b")#abstand#off("b")# bis
+ #on("b")#abstand#off("b")# + #on("b")#länge#off("b")# - 1 ausgegeben.
+#page#
+ PROC #ib#set net mode#ie# (INT CONST mode):
+
+ Es wird der #ib#Netzmodus#ie# #on("b")#mode#off("b")# eingestellt. Im Netz-Hardware-Interface
+ müssen alle Initialisierungen und Einstellungen vorgenommen werden,
+ damit die mit #on("b")#mode#off("b")# geforderte #ib#Netzhardware#ie# unterstützt wird. Diese
+ Prozedur wird bei jedem #on("b")##ib#start#ie##off("b")#-Kommando in der Netztask aufgerufen.
+ Kann als Initialisierungsprozedur für dieses PACKET verwendet werden.
+ Übergibt den in der #ib#Datei#ie# #on("b")##ib#netz#ie##off("b")# für diesen #ib#Kanal#ie# verlangten Netzmodus an
+ das Netz-Hardware-Interface. Nach Aufruf dieser Prozedur müssen die
+ wertliefernden Prozeduren #on("b")##ib#net mode#ie#, #ib#mode text#ie#, #ib#data length#ie##off("b")# und #on("b")##ib#data
+ length via node#ie##off("b")# korrekt initialisiert sein. Der Aufruf von #on("b")##ib#net addess#ie##off("b")# muß
+ die korrekten (physikalischen) #ib#Adresse#ie# der #ib#Station#ie#en liefern.
+
+ TEXT PROC net address (INT CONST stationsnummer):
+
+ Liefert die (Hardware-) Netz-#ib#Adresse#ie#, über die der EUMEL-Rechner
+ mit der Stationsnummer #on("b")##ib#stationsnummer#ie##off("b")# beim aktuell für diesen Kanal
+ eingestellten #ib#Netzmodus#ie# erreichbar ist. Auf diese #ib#Adresse#ie# muß der Treiber
+ des entsprechenden Rechners eingestellt sein. Auch die eigene Netz-
+ Adresse muß mit der im Treiber eingestellten #ib#Adresse#ie# übereinstimmen.
+ Insbesondere müssen alle Stationen, die auf dem Netz arbeiten, dieselbe
+ Netz-Adresse für eine #ib#Stationsnummer#ie# errechnen.
+
+ TEXT PROC #ib#mode text#ie#:
+
+ Liefert den Text (Namen) des eingestellten #ib#Netzmodus#ie#. Wird in #on("b")##ib#net
+ manager#ie##off("b")# benutzt, um den Netzmodus im #on("b")##ib#report#ie##off("b")# anzugeben.
+
+ TEXT PROC mode text (INT CONST mode):
+
+ Liefert den Text (Namen) zu dem #ib#Netzmodus#ie# #on("b")#mode#off("b")#.
+
+ INT PROC #ib#data length#ie# (INT CONST mode):
+
+ Liefert die #ib#Nutzdatenlänge#ie# (#ib#Länge#ie# der Nettodaten des Eumel-
+ Telegramms) im Netz. Wird von #on("b")##ib#basic net#ie##off("b")# beim Neustart aufgerufen. Muß
+ in einem Netz auf allen Stationen eines #ib#Strang#ie#s denselben Wert liefern.
+
+ Erlaubte Werte: 64, 128, 256 und 512.
+#page#
+ INT CONST #ib#data length via node#ie#:
+
+ Liefert die #ib#Nutzdatenlänge#ie# für Sendungen, die über #ib#Knoten#ie# gehen.
+ Muß auf allen Stationen des Netzes gleich sein.
+
+ Erlaubte Werte: 64, 128, 256 und 512.
+
+ PROC #ib#decode packet length#ie# (INT VAR value):
+
+ Die #ib#Länge#ie# eines Netztelegramms ist im #ib#Telegramm#ie# codiert enthalten. Mit
+ dieser Prozedur wird aus dem Telegrammkopf die Telegrammlänge ermit­
+ telt:
+
+ Falls beim Aufruf dieser Prozedur in #on("b")#value#off("b")# der Wert des Feldes #on("b")#head#off("b")# aus
+ der Struktur #on("b")#vorspann#off("b")#, die in #on("b")#ds#off("b")# per #on("b")##ib#transmit header#ie##off("b")# übergeben wurde,
+ enthalten ist, so wird in #on("b")#value#off("b")# die Länge des EUMEL-Netztelegramms
+ zurückgeliefert.
+
+ PROC #ib#flush buffers#ie#:
+
+ Liest den Eingabepuffer des #ib#Netzkanal#ie#s leer. Die eingelesenen Zeichen
+ werden vernichtet. Wird nach Erkennen von #ib#Übertragungsfehler#ie#n aufge­
+ rufen.
+
+ TEXT PROC #ib#next packet start#ie#:
+
+ Liefert genau ein #ib#Zeichen#ie# (in der Regel das erste Zeichen des EUMEL-
+ Netztelegramms). Wird von der Netzsoftware immer dann aufgerufen,
+ wenn ein neues #ib#Paket#ie# erwartet wird.
+
+ Bedeutung des gelieferten Zeichens für die #ib#Netzsoftware#ie#:
+
+ #ib#STX#ie#: korrekter #ib#Telegrammanfang#ie# (ist das erste Zeichen des
+ EUMEL-Netztelegramms). Der Rest des EUMEL-Netztele­
+ gramms steht im Eingabepuffer, ist also über #ib#blockin#ie# lesbar.
+ Vorher wurden nur Zeichen eingelesen, die zum verwendeten
+ #ib#Netzprotokoll#ie# gehören (z.B. #ib#Ethernet#ie#-#ib#Adresse#ie#n, #ib#Füllzeichen#ie#
+ usw.).
+ niltext: kein neues Telegramm da
+
+ jedes andere Zeichen:
+ Fehler. Entweder wurden Störzeichen eingelesen oder es
+ gingen Zeichen verloren. #ib#Fehlerbehandlung#ie# erfolgt durch die
+ Netzsoftware.
+#page#
+ PROC #ib#transmit header#ie# (DATASPACE CONST ds):
+
+ Wird vor Ausgabe eines jeden #ib#Telegramm#ie#s aufgerufen. In dem #ib#Datenraum#ie#
+ #on("b")#ds#off("b")# wird von der EUMEL-Netz-Software der #on("b")##ib#Vorspann#ie##off("b")# übergeben. Über
+ den jeweiligs eingestellten #ib#Netzmodus#ie# kann für jede implementierte Netz­
+ art über eine #ib#Sprungleiste#ie# (#ib#SELECT#ie#) die Prozedur angesprungen werden,
+ die den #ib#Header#ie# für den eingestellten Netzmodus erstellt und ausgibt.
+ Struktur des von der EUMEL-Netz-Software benutzten Headers:
+
+ BOUND STRUCT
+ (INT head,
+ zwischenziel,
+ zielrechner,
+ quellrechner,
+ strom,
+ sequenz,
+ seitennummer ) VAR vorspann.
+
+ Aus dem Inhalt des Feldes #on("b")#head#off("b")# kann mittels #on("b")##ib#decode packet length#ie##off("b")# die
+ Gesamtlänge des EUMEL-Netztelegramms errechnet werden.
+
+ PROC #ib#transmit trailer#ie#:
+
+ Wird nach Ausgabe eines jeden Telegramms aufgerufen. Evtl. notwendige
+ Nachspänne können ausgegeben werden. Die notwenigen Informationen
+ wurden in #on("b")##ib#transmit header#ie##off("b")# übergeben und müssen aufbewahrt werden,
+ falls sie im Trailer mitgeliefert werden müssen. Kann auch dazu benutzt
+ werden, den unter diesem Packet liegenden Schichten (#ib#SHard#ie# oder Hard­
+ ware) das Ende des Telegramms mitzuteilen. Notwendige #ib#Füllzeichen#ie#
+ können in dieser Prozedur in das #ib#Paket#ie# eingebaut werden.
+
+ PROC #ib#reset box#ie# (INT CONST net mode):
+
+ Kann zur Initialisierung der #ib#Netzhardware#ie# benutzt werden. Wird von #on("b")##ib#basic
+ net#ie##off("b")# beim jedem Neustart aufgerufen.
+
+ INT PROC #ib#max mode#ie#:
+
+ Liefert den Wert des größten erlaubten (implementierten) #ib#Netzmodus#ie#.
+
+ INT PROC #ib#net mode#ie#:
+
+ Liefert den eingestellten Netzmodus.
+#page#
+#pagenr ("%", 45)##setcount (1)##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#Anhang
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right#GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+#clear pos##lpos(1.0)##rpos(9.5)##goalpage("A")#
+
+Anhang: Netz-Meldungen#goalpage("A.1")#
+
+Mit dem Kommando #on("b")##ib#list#ie# (/"net list")#off("b")# (siehe Teil 1) erhalten Sie eine temporäre #ib#Datei#ie#
+auf den Bildschirm. Diese Datei könnte ungefähr so aussehen:
+
+____________________________________________________________________________
+
+ N e u e r S t a r t 12:44 Stationsnummer : 38
+ 01.06.87 12:55 net port 8:20:Nicht zustellbar. . Empfänger: "net dok". Quelle 34 Taskindex: 255
+ 02.06.87 06:30 net port 8:1:wdh data. sqnr 7. Absender: "net dok". Ziel 34 Taskindex: 255
+ 02.06.87 07:03 net port:20:Sequenzfehler: soll 13 ist 14. Empfänger: "POST". Quelle 33 Taskindex:
+ 02.06.87 07:03 net port:blockin abbruch
+ 02.06.87 07:03 net port:20:Sequenzreset von 13 auf 10. Empfänger: "POST". Quelle 33 Taskindex: 29
+ 02.06.87 07:36 net port:Call gelöscht."net dok". Strom 1
+ 02.06.87 07:43 net port 8:verbotene Route: 34
+ 02.06.87 07:50 net port:Header inkorret eingelesen: %0 %2
+ 02.06.87 07:50 net port:buffers flushed
+ 02.06.87 07:52 net port:Weiterleitung nicht möglich für 34
+ 02.06.87 07:53 net port 8:skipped0 6 G O 1 0 . 0 %13 %10 2 8 0 6 0 6 G O 1 0 . 0 %13 %10 2 8 0
+ 02.06.87 08:14 net port 8:skipped%13 %10 S p e c . R e c e i v e E r r o r C 2
+ 02.06.87 08:21 net port:20:Reopen. Empfänger: "WÜFE". Quelle 40 Taskindex: 22
+ 02.06.87 09:25 net port:1:etwas rueckgespult. Absender: "-". Ziel 33 Taskindex: 51
+ 02.06.87 09:25 net port:1:wdh data. sqnr 20. Absender: "-". Ziel 33 Taskindex: 51
+ 02.06.87 09:54 net port:20:Blocknummer falsch, neu: 192, alt : -1. Empfänger: "WÜFE". Quelle 44
+ 02.06.87 10:12 net port:Daten ohne Eroeffnung von 40 Sequenznr 7
+ 02.06.87 10:23 net port:Header inkorret eingelesen: O X 0 3 8 B O X 0 4 4 E U %2
+ 02.06.87 10:23 net port:buffers flushed
+ 02.06.87 10:49 net port:1:wdh open. Absender: "-". Ziel 33 Taskindex: 255
+ 02.06.87 10:49 net port:2:wdh open. Absender: "net dok". Ziel 33 Taskindex: 255
+ 02.06.87 10:53 net port:1:Sequenzfehler: soll 2 ist 3. Empfänger: "net dok". Quelle 33 Taskindex:
+ 02.06.87 10:54 net port:1:Sequenzreset von 8 auf 5. Empfänger: "net dok". Quelle 33 Taskindex: 11
+ 02.06.87 10:56 net port:2:etwas rueckgespult. Absender: "-". Ziel 33 Taskindex: 51
+ bekannte Stationen:
+ 1(8,1) 2(8,2) 3(8,3) 4(8,4) 5(8,5) 6(8,6) 7(8,7) 8(8,8) 9(8,9) 10(8,10)
+ 11(8,11) 12(8,12) 13(8,13) 14(8,14) 15(8,15) 16(8,16) 17(8,17) 18(8,18)
+ 19(8,19) 20(8,20) 21(8,21) 22(8,22) 23(8,23) 24(8,24) 25(8,25) 26(8,26)
+ 27(8,27) 28(8,28) 29(8,29) 30(8,30) 31(8,31) 32(8,32) 33(9,33) 34(8,34)
+ 35(9,35) 36(9,36) 37(9,37) 39(9,39) 40(9,40) 41(9,41) 42(9,42) 43(9,43)
+ 44(9,44) 45(9,45) 46(9,46) 47(9,47) 48(9,48)
+ --------
+ Eingestellte Netzmodi:
+ net port 8 haengt an Kanal 8, Modus: (1) EUMEL-Netz 64 Byte
+ net port haengt an Kanal 9, MODUS: (11) ETHERNET via V.24 512 Byte
+
+ Nutzdatenlänge 512 Byte
+ Nutzdatenlänge bei indirekter Verbindung: 64 Byte
+ ********
+ Netz-Software vom 23.05.87
+ Rechner 38 um 11:11
+ net port 8
+
+ Strom 1 (sqnr7/8) sendet an 34 . Absender ist "net dok".
+ net port
+
+ Strom 1 (sqnr45/45) empfaengt von 40 . Empfaenger ist "PUBLIC".
+
+____________________________________________________________________________
+#page#
+Die Datei enthält den aktuellen #on("b")##ib#report#ie##off("b")#, in dem #ib#Fehlermeldung#ie#en der einzelnen Tasks
+gesammelt werden. Außerdem wird der Zustand aller Verbindungen (Ströme) von allen
+#on("b")##ib#net port#ie##off("b")#'s angezeigt. Im #on("b")#report#off("b")#-Teil kann man drei Informationsblöcke unterscheiden:
+
+a) den Block mit den Fehlermeldungen. Es werden jeweils Datum, Uhrzeit, der Name
+ des betroffenen #on("b")#net port#off("b")# und, wenn notwendig, die #ib#Stromnummer#ie# angegeben.
+ Darauf folgt der Meldungstext, der auch Informationen über Absender und Emp­
+ fänger enthalten kann.
+
+ <Datum> <Zeit> <Name der #ib#Kanaltask#ie#> : [<#ib#Stromnummer#ie#> : ] <Meldung>
+
+
+b) den Block mit der Liste der bekannten #ib#Station#ie#en. Ein Eintrag in dieser Liste ent­
+ hält jeweils die Stationsnummer der bekannten Station und in Klammern dahin­
+ ter die Nummer des Kanals auf diesem Rechner, über den die Station erreichbar
+ ist und die Nummer der nächsten #ib#Zwischenstation#ie#.
+
+ <Zielstation> (<Kanalnr>,<Zwischenstation>)
+
+ Bei direkt erreichbaren Stationen ist Zwischenstation gleich #ib#Zielstation#ie#.
+
+ Hinweis: Auch #ib#gesperrt#ie#e Stationen erscheinen in dieser Liste.
+
+
+c) den Block, der Auskunft über die Netzinstallation gibt. Es werden für jeden Netz­
+ kanal die eingestellten Netzmodi angegeben. Des weiteren werden die beiden
+ Größen #on("b")##ib#data length#ie##off("b")# (#ib#Nutzdatenlänge#ie#) und #on("b")##ib#data length via node#ie##off("b")# (Nutzdatenlänge bei
+ indirekter Verbindung) angegeben. Zusätzlich erscheinen noch die #ib#Netzversion#ie# und
+ die genaue Uhrzeit, zu der dieser #on("b")#report#off("b")# erstellt wurde.
+
+#page#
+Für jeden #on("b")##ib#net port#ie##off("b")# wird pro aktivem #ib#Strom#ie# folgende Meldung generiert:
+
+Strom <Stromnr> (sqnr<akt Seqnr>/<max Seqnr>) <Zustand> <Partner>
+
+
+<Stromnr> #ib#Stromnummer#ie#
+
+<akt Seqnr> #ib#Sequenznummer#ie# des gerade bearbeiteten #ib#Telegramm#ie#s
+
+<max Seqnr> Bei #ib#Sendeströme#ie#n die Nummer der letzten zu übertragenden
+ #ib#Sequenz#ie#, bei Empfangsströmen in der Regel die Nummer der
+ letzten Sequenz der gerade übertragenen #ib#Datenraumseite#ie#.
+
+<#ib#Zustand#ie#> Hier wird die Aktion (senden, empfangen usw.) und die Partner­
+ station angegeben.
+
+<#ib#Partner#ie#> Der Name der Task mit der kommuniziert wird.
+
+
+Die Meldungen, die in der #ib#Datei#ie# #on("b")##ib#report#ie##off("b")# protokolliert werden, kann man in verschiedene
+Gruppen einordnen. Die eine Gruppe beschreibt Störungen durch #ib#Zeichenverluste#ie#
+oder ­verfälschungen, eine andere Gruppe protokolliert besondere Situationen, bei­
+spielsweise den Abbruch von #ib#Übertragung#ie#en, und die letzte Gruppe befasst sich mit
+#ib#Fehlermeldung#ie#en, die ein Eingreifen von aussen notwendig machen. Je nachdem, ob
+die Station, auf der die Meldung protokolliert wird, Empfänger oder Absender ist, wird
+bei den Meldungen #ib#Stationsnummer#ie# und Taskname des Kommunikationspartners mit
+angegeben.
+
+Zur ersten Gruppe gehören:
+
+#ib(4)##ib#skipped#ie##ie(4)#
+ 'skipped' oder skipped mit einem Zusatztext erscheint, wenn Zei­
+ chen eingelesen wurden, die zu keinem gültigen #ib#Telegramm#ie# ge­
+ hören. Dies kann passieren, wenn auf der Leitung zwischen
+ Rechner und Box #ib#Zeichen#ie# verlorengegangen sind. Auch nach dem
+ Einschalten oder nach einem Reset auf Box oder Rechner kann
+ diese Meldung kommen. Mindestens ein Teil der eingelesenen
+ Daten wird mit ausgegeben, wobei Steuerzeichen durch % und den
+ Code des Steuerzeichens dargestellt werden. Die einzelnen Zeichen
+ werden durch ein Blank voneinander getrennt.
+#page#
+#ib(4)##ib#Sequenzfehler#ie##ie(4)#
+ Die #ib#Sequenznummer#ie# ist zu groß, es fehlen also Telegramme. Die
+ Gegenstation wird aufgefordert, ab einem früheren Telegramm zu
+ wiederholen.
+
+#ib(4)#wdh data#ie(4)#
+ Das letzte Telegramm wird erneut geschickt. Passiert, wenn die
+ #ib#Quittung#ie# für dieses Telegramm nach einer bestimmten Zeit nicht
+ angekommen ist.
+
+#ib(4)##ib#Sequenzreset#ie##ie(4)#
+ Die #ib#Sequenznummer#ie# des empfangenen Telegramms ist kleiner als
+ die Sequenznummer des vorher empfangenen Telegramms. Die
+ Verbindung wird bei der zuletzt empfangenen Sequenznummer
+ fortgesetzt.
+
+#ib(4)#Blocknummer falsch#ie(4)#
+ Die #ib#Seitennummer#ie# in dem #ib#Telegramm#ie# ist falsch.
+
+#ib(4)#etwas rueckgespult#ie(4)#
+ Auf Anforderung der Gegenseite werden die letzten drei #ib#Datenraum­
+ seite#ie#n erneut übertragen.
+
+#ib(4)#Daten ohne Eroeffnung#ie(4)#
+ Es werden Telegramme mit einer #ib#Stromnummer#ie# empfangen, zu der
+ vorher kein OPEN-Telegramm empfangen wurde. In diesem Fall
+ wird die Gegenstation aufgefordert, die #ib#Übertragung#ie# von vorn zu
+ beginnen. Diese Meldung kann auch kommen, wenn das Netz neu
+ gestartet wurde.
+
+#ib(4)#wdh open#ie(4)#
+ Die Übertragung wird mit dem #ib#OPEN#ie#-Telegramm von vorn begon­
+ nen. Passiert auf Aufforderung durch die Gegenstation oder wenn
+ das erste OPEN-Telegramm nicht quittiert wurde.
+
+#ib(4)##ib#buffers flushed#ie##ie(4)#
+ Alle bereits eingelesenen, aber noch nicht bearbeiteten Zeichen
+ wurden gelöscht (der #ib#Eingabepuffer#ie# wurde komplett gelöscht). Verur­
+ sacht durch schwere Störungen (#ib#Zeichenverluste#ie# oder -verfäl­
+ schungen).
+#page#
+#ib(4)#blockin abbruch#ie(4)#
+ Es wurden nicht alle Zeichen eines Telegramms innerhalb eines
+ bestimmten Zeitraums angeliefert.
+
+#ib(4)#Header inkorrekt eingelesen#ie(4)#
+ Es wurde ein Fehler in dem Teil des Netztelegramms gefunden, der
+ nicht zum EUMEL-Netz gehört.
+
+#ib(4)#Strom falsch in Quittung#ie(4)#:
+ In der #ib#Quittung#ie# wurde eine nicht zulässige #ib#Stromnummer#ie# festge­
+ stellt. Zulässig sind Stromnummern zwischen 1 und 20.
+
+#ib(4)#Neustart#ie(4)#
+ Die Gegenstation hat die #ib#Verbindung#ie# von vorne begonnen.
+
+#ib(4)#Falsche Seitennummer#ie(4)#
+ Die #ib#Seitennummer#ie# in dem empfangenen Telegramm ist falsch.
+ Einige Telegramme werden wiederholt.
+
+#ib(4)#Absteigende Seitennummern#ie(4)#
+ Die Seitennummer in dem empfangenen Telegramm ist kleiner als
+ die Seitennummer im vorigen #ib#Telegramm#ie#. Es müssen einige Tele­
+ gramme wiederholt werden.
+
+
+Die folgenden Meldungen beschreiben Situationen, die nicht durch #ib#Zeichenverluste#ie#
+entstehen, mit denen die #ib#Netzsoftware#ie# selbst fertig wird:
+
+
+#ib(4)#Sendung von Gegenstelle gelöscht#ie(4)#
+ Die Verbindung wurde von der Gegenstelle abgebrochen.
+
+#ib(4)#Empfangseintrag freigegeben#ie(4)#
+ Die Verbindung wurde von der empfangenden #ib#Station#ie# gelöscht, weil
+ seit dem Eintreffen des letzten Telegramms zuviel Zeit vergangen ist
+ (#ib#Timeout#ie#).
+
+#ib(4)#Irrläufer#ie(4)#
+ Eine #ib#Intertaskkommunikation#ie# innerhalb der eigenen Station wurde
+ fälschlicherweise über den #on("b")##ib#Collector#ie##off("b")# abgewickelt. Dieser Vorgang
+ wird abgebrochen.
+#page#
+#ib(4)#Call-Löschung vorgemerkt#ie(4)#
+ Sobald der Call abgewickelt ist, wird diese Verbindung gelöscht.
+ Beispielsweise führt ein vom Benutzer abgebrochenes #on("b")##ib#name#ie##off("b")# zu
+ dieser Meldung.
+
+#ib(4)#Call gelöscht#ie(4)#
+ Die #ib#Verbindung#ie# wurde auf Anforderung durch den Auftraggeber
+ gelöscht.
+
+#ib(4)#Quellrechner#ie(4)#
+ Als #ib#Quellrechnernummer#ie# wurde ein unzulässiger Wert festgestellt.
+ Zulässig sind Zahlen zwischen 1 und 127.
+
+#ib(4)#Nicht zustellbar#ie(4)#
+ Innerhalb eines bestimmten Zeitraums war die #ib#Zieltask#ie# nicht emp­
+ fangsbereit. Die Verbindung wird abgebrochen.
+
+Bei diesen Meldungen sollten die #ib#Routenanweisungen#ie# überprüft werden:
+
+#ib(4)#Verbotene Route bei Quittung#ie(4)#
+ Die #ib#Quittung#ie# kommt auf einer nicht erlaubten #ib#Route#ie# an. Dies kann
+ bei #ib#Vermaschung#ie# passieren, oder aber, wenn eine Station versucht,
+ sich für eine andere Station auszugeben.
+
+#ib(4)#Verbotene Route#ie(4)#
+ Die danach bezeichnete Station versucht, auf einer anderen Route
+ mit diesem Rechner zu kommunizieren, als auf der Route, die für
+ diesen Rechner in der Datei #on("b")##ib#netz#ie##off("b")# festgelegt wurde.
+
+ Abhilfe:
+ #ib#Routentabellen#ie# der beiden (oder, falls die Meldung auf einer
+ #ib#Knotenstation#ie# erscheint, auf allen beteiligten) Stationen abgleichen.
+
+#ib(4)#Weiterleitung nicht möglich#ie(4)#
+ Die #ib#Routeninformationen#ie# auf dem #ib#Knotenrechner#ie#, wo diese Meldung
+ erscheint, und der sendenden #ib#Station#ie# stimmen nicht überein. Die
+ angegebene Station ist von dieser Station aus nicht erreichbar.
+
+ Abhilfe:
+ #ib#Routentabellen#ie# der Stationen überprüfen.
+
+#ib(4)#Fremdzugriff#ie(4)#
+ Eine #ib#gesperrt#ie#e Station hat versucht, auf diesen Rechner mit #ib#Sende­
+ codes#ie# > 6 zuzugreifen.
+
+
+Folgende Meldungen betreffen '#ib#harte Fehler#ie#'. Diese Fehler werden von der Netzsoft­
+ware nicht abgefangen. In jedem Fall muß das Netz nach einer solchen #ib#Fehler­
+meldung#ie# neu gestartet werden.
+
+#ib(4)#++++++#ie(4)#
+ Meldungen dieser Form sind 'harte' Fehler. Der aufgetretene Fehler
+ wird mit angegeben. Das Netz muß neu gestartet werden, da die
+ Task, in welcher der Fehler aufgetreten ist, gelöscht wird.
+
+#ib(4)#Verbindungsengpaß#ie(4)#
+ Es sind mehr Verbindungen festgestellt worden, als zulässig sind.
+ Nach dieser Meldung wurde der entsprechende Netport gelöscht.
+
+
+Literaturverzeichnis
+
+
+#goalpage("A.2")#
+
+#clear pos#
+#lpos(1.0)##lpos(2.5)#
+#table#
+[1] EUMEL-Systemhandbuch, Teil 5, Intertaskkommunikation
+ GMD St. Augustin, 1986
+[2] EUMEL-Systemhandbuch, Teil 2, Hardware und ihre Steuerung
+[3] EUMEL-Systemhandbuch, Teil 8, Spooler
+[4] EUMEL-Netz Installationsanweisung
+ GMD St. Augustin, 1987
+[5] EUMEL-Systemhandbuch, Teil 4, Blockorientierte Ein/Ausgabe
+[6] EUMEL-Quellcode, Packet #on("b")#tasks#off("b")#
+ GMD St. Augustin, 1986
+[7] EUMEL-Portierungshandbuch 8086, Version 8
+ GMD St. Augustin, 1987
+
+#table end#
+
+
diff --git a/system/net/1.8.7/doc/netzhandbuch.anhang b/system/net/1.8.7/doc/netzhandbuch.anhang
new file mode 100644
index 0000000..17d1ece
--- /dev/null
+++ b/system/net/1.8.7/doc/netzhandbuch.anhang
@@ -0,0 +1,58 @@
+#pagenr ("%", 51)##setcount##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#Anhang
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right#GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+#clear pos##lpos(0.0)##rpos(11.0)##fillchar(".")#
+Anhang: Netz-Fehlermeldungen
+
+#table#
+++++++ 50
+Absteigende Seitennummern 48
+blockin abbruch 48
+Blocknummer falsch 47
+buffers flushed 47
+Call gelöscht 49
+Call-Löschung vorgemerkt 49
+Collectortask fehlt 8, 18
+Daten ohne Eroeffnung 47
+Empfangseintrag freigegeben 48
+etwas rueckgespult 47
+Falsche Seitennummer 48
+Fremdzugriff 50
+Header inkorrekt eingelesen 48
+Irrläufer 48
+kein Zugriff auf Station 14
+Neustart 48
+Nicht zustellbar 49
+Quellrechner 49
+Sendung von Gegenstelle gelöscht 48
+Sequenzfehler 47
+Sequenzreset 47
+skipped 46
+Station x antwortet nicht 8, 11, 16
+Station x gibt es nicht 9, 11, 13
+Strom falsch in Quittung 48
+Task "..." gibt es nicht 8
+Verbindungsengpaß 50
+Verbotene Route 49
+Verbotene Route bei Quittung 49
+wdh data 47
+wdh open 47
+Weiterleitung nicht möglich 49
+#table end#
+
diff --git a/system/net/1.8.7/doc/netzhandbuch.index b/system/net/1.8.7/doc/netzhandbuch.index
new file mode 100644
index 0000000..01d8a0f
--- /dev/null
+++ b/system/net/1.8.7/doc/netzhandbuch.index
@@ -0,0 +1,259 @@
+#pagenr ("%", 52)##setcount (1)##block##pageblock##count per page#
+#headeven#
+#center#EUMEL Netzbeschreibung
+#center#____________________________________________________________
+
+#end#
+#headodd#
+#center#Anhang
+#center#____________________________________________________________
+
+#end#
+#bottomeven#
+#center#____________________________________________________________
+Netz - % #right#GMD
+#end#
+#bottomodd#
+#center#____________________________________________________________
+GMD #right#Netz - %
+#end#
+#clear pos##lpos(0.0)##rpos(11.0)##fillchar(".")#
+Anhang: Index
+
+#table#
+/ 8, 9, 24
+Absenderadresse 39
+Absenderstation 28, 32
+Adresse 29, 37, 39, 41, 42
+aktiviere netz 14, 15, 18
+basic net 41, 43
+Baud 6, 18, 25
+blockin 23, 36, 40, 42
+blockout 23, 36, 40
+Broad- oder Multicasts 38
+buffers flushed 47
+CASE 37
+CLOSE 27
+collected destination 22, 24
+Collector 22, 24, 32, 48
+Collectortask 8, 18, 22
+configurate 6
+continue 7, 21
+CRC-Code 26
+DATA 27, 29, 30
+data length 23, 36, 41, 45
+data length via node 23, 36, 41, 42, 45
+Datei 2, 5, 7, 12, 13, 14, 18, 20, 24, 31, 37, 41, 44, 46
+Datenbox 2, 6, 33
+Datenraum 13, 15, 21, 23, 24, 27, 28, 29, 31, 36, 40, 43
+Datenraumseite 23, 46, 47
+decode packet length 42, 43
+define collector 22, 24
+definere netz 15
+DEFINES 37
+define station 5, 22
+definiere netz 14
+Dreher 16
+Durchsatz 3
+Eingabeprozeduren 21
+Eingabepuffer 47
+Empfangspuffer 15
+Empfangsströme 13, 15
+endquelle 28
+endziel 28
+erase 13, 19
+erlaube 14
+Ethernet 33, 34, 36, 37, 42
+EUMEL0 21, 22, 24
+EUMEL-Datenboxen-Netz 33
+EUMEL-Netz-Software 35
+exists 11
+Fehler 8, 16, 17, 18
+Fehlerbehandlung 31, 36, 42
+Fehlerfälle 8
+Fehlerfall 11, 40
+Fehlermeldung 13, 15, 20, 26, 39, 45, 46, 50
+Fehlersituationen 12
+Fehlersuche 16
+Fenstertechnik 31
+fetch 10, 18
+flush buffers 36, 42
+Flußkontrolle 7, 15, 27, 39
+free global manager 10, 19, 31
+Füllzeichen 37, 39, 42, 43
+gesperrt 13, 14, 45, 50
+global manager 19, 31
+harte Fehler 50
+HDLC 31
+Header 43
+Höhere Ebenen 31
+inchar 21
+incharety 23
+Installation 2
+Installationsanleitung 2
+Intertaskkommunikation 48
+I/O Control 36
+I/O-Kanal 33
+Kanal 3, 6, 7, 12, 14, 15, 20, 21, 23, 24, 34, 37, 40, 41
+Kanalnummer 14
+Kanaltask 45
+Knoten 3, 4, 17, 20, 23, 36, 42
+Knotenkonzept 3, 34
+Knotenrechner 34, 36, 49
+Knotenstation 13, 14, 20, 49
+Kommunikation 17
+Kommunikationindirekte 23
+konfigurieren 6
+Länge 29, 41, 42
+Längenangabe 26
+list 10, 12, 17, 44
+listoption 12, 14, 15
+Löschversuche 13
+Manager 10, 19
+Masseschluß 16
+max mode 43
+mode text 41
+Nachbarn 4, 28
+Nachbarstation 24, 28
+name 11, 24, 49
+net 7, 12, 13
+net addess 41
+net hardware interface 34, 40
+net install 7
+net list 12, 15
+net manager 41
+net mode 41, 43
+net port 7, 8, 12, 13, 18, 45, 46
+net timer 14
+netz 7, 14, 15, 20, 37, 41, 49
+Netzbox 3, 6, 20, 33, 38
+Netzdefinition 14
+Netzebene 26
+Netzempfangstask 30
+Netzhardware 2, 17, 21, 24, 33, 34, 36, 41, 43
+Netz-Hardware-Interface 34
+Netzinstallation 17
+Netzkanal 13, 14, 42
+Netzknoten 3
+Netzkonfiguration 7, 20
+Netzmodus 34, 37, 39, 41, 43
+Netzprotokoll 42
+Netzsoftware 2, 3, 18, 20, 34, 36, 38, 42, 48
+Netzstrang 4, 17, 23
+Netztask 15, 16, 21, 24
+Netztelegramm 34
+Netztreiber 38
+Netzübertragungen 12
+Netzversion 2, 45
+next packet start 36, 42
+niltext 11, 36
+Nutzdaten 23
+Nutzdatenlänge 17, 23, 29, 36, 41, 42, 45
+Nutzinformation 29
+nutzlaenge 29
+OPEN 27, 28, 30, 47
+Paket 23, 34, 37, 38, 39, 42, 43
+Pakete, Aufbau der 34
+Partner 46
+Paßwort 19
+Pin-Belegung 6
+port intern 13, 15, 24
+Printerserver 20
+Protokoll 6, 13, 24, 39
+Protokollebenen 25
+Prüfsummen 18
+Quelle 23, 26, 28
+Quellrechnernummer 49
+Quellstationsnummer 20
+quelltask 21, 24, 28
+Querarchivierungen 10
+QUIT 27, 28, 30
+Quittung 30, 31, 47, 48, 49
+Rechnerkopplung 3
+Rendezvouskonzept 21, 31
+report 8, 12, 18, 39, 40, 41, 45, 46
+reserve 10
+RESET 17
+reset box 43
+Route 13, 15, 17, 20, 49
+routen 14
+Routenanweisungen 49
+routen aufbauen 13, 14, 15
+Routeninformationen 20, 49
+Routentabelle 9, 13
+Routentabellen 24, 49
+router 13
+RS422 25
+RTS/CTS 6, 25, 39
+Rückmeldeparameter 21
+run 13
+save 10, 19
+Schnittstelle 3, 15, 18, 20, 25, 33, 37, 38, 39
+SDLC 25, 26
+seite 28, 29, 40
+Seiten 27
+Seitengrenze 23
+Seitennummer 47, 48
+SELECT 34, 37, 43
+send 21, 22, 24, 27, 28, 30, 32
+Sendecode 24
+Sendecodes 50
+Sendeströme 13, 46
+Sendungskonzept 2
+sequenz 28, 29, 46
+Sequenzfehler 47
+Sequenznummer 46, 47
+Sequenzreset 47
+set net mode 41
+SHard 38, 43
+Sicherheitskonzept 19
+Sicherheitsprobleme 19
+skipped 46
+sperre 14
+Spoolmanager 5
+Sprungleiste 43
+Sprungleisten 34, 37
+start 5, 13, 16, 18, 41
+starte kanal 14, 15
+station 2, 5, 8, 10, 12, 13, 16, 19, 20, 22, 24, 26, 31, 32, 36, 41, 45, 48, 49
+Stationen, sicherheitsrelevante 20
+Stationsadresse 38
+Stationsnummer 5, 10, 16, 22, 24, 26, 32, 37, 41, 46
+Stationsnummer maximale 14
+Strang 3, 17, 20, 36, 41
+Stream I/O 23, 38
+strom 28, 30, 46
+Stromnummer 13, 28, 30, 45, 46, 47, 48
+STX 26, 36, 42
+Task-Id 5, 22, 24, 28, 30
+Telegramm 20, 23, 26, 27, 28, 31, 36, 37, 40, 42, 43, 46, 47, 48
+Telegrammanfang 42
+Telegrammformat 26
+Telegrammfreigabe 36
+Textdatei 31
+Timeout 31, 36, 48
+transmit header 36, 42, 43
+transmit trailer 36, 43
+Treiber 33
+Übertragung 26, 30, 46, 47
+Übertragungsfehler 42
+Übertragungsgeschwindigkeit 34, 38
+Übertragungsweg 23
+V24 3, 4, 15, 17, 18, 20, 25, 33, 34, 38
+Verbindung 3, 6, 16, 18, 27, 28, 34, 48, 49
+Vermaschung 4, 49
+Vermittlungsebene 24, 30
+Vorspann 36, 43
+wait 19, 21, 24, 27, 32
+Worker 5
+Zeichen 36, 38, 40, 42, 46
+Zeichenverluste 46, 47, 48
+Zeitüberwachung 26, 29
+ziel 28
+Zieladresse 38
+Zielstation 4, 8, 24, 28, 30, 36, 45
+Zieltask 21, 22, 24, 28, 32, 49
+Zustand 46
+Zwischenstation 45
+#table end#
+
diff --git a/system/net/1.8.7/source-disk b/system/net/1.8.7/source-disk
new file mode 100644
index 0000000..5a39f6c
--- /dev/null
+++ b/system/net/1.8.7/source-disk
@@ -0,0 +1 @@
+grundpaket/11_austausch.img
diff --git a/system/net/1.8.7/src/basic net b/system/net/1.8.7/src/basic net
new file mode 100644
index 0000000..c5e9278
--- /dev/null
+++ b/system/net/1.8.7/src/basic net
@@ -0,0 +1,1148 @@
+PACKET basic net DEFINES (* D. Heinrichs *)
+ (* Version 10 (!) *) (* 18.02.87 *)
+ nam, (* 03.06.87 *)
+ max verbindungsnummer, (* *)
+ neuer start,
+ neue routen,
+ packet eingang,
+ neue sendung,
+ zeitueberwachung,
+ verbindung,
+ loesche verbindung:
+
+TEXT PROC nam (TASK CONST t):
+ IF t = collector THEN name (t)
+ ELIF station (t) <> station (myself)
+ THEN "** fremd "+text(station(t))+" **"
+ ELSE name (t)
+ FI
+END PROC nam;
+
+INT PROC tasknr (TASK CONST t):
+ IF t = collector THEN maxtasks
+ ELSE index (t)
+ FI
+END PROC tasknr;
+
+LET
+ maxtasks = 127,
+ maxstat = 127,
+ max strom = 20,
+ max strom 1 = 21,
+ stx = ""2"",
+ code stx = 2,
+ error nak = 2,
+ seiten groesse = 512,
+ dr verwaltungslaenge = 8,
+ dr verwaltungslaenge2=10,
+ openlaenge = 24,
+ vorspannlaenge = 14,
+ ack laenge = 12,
+ min data length = 64,
+ (* Codes der Verbindungsebene *)
+
+ task id code = 6,
+ name code = 7,
+ task info code = 8,
+ routen liefern code = 9,
+
+ (* Typen von Kommunikationsströmen *)
+
+ send wait = 0,
+ zustellung = 1,
+ call pingpong = 2,
+ call im wait = 3,
+ call im abbruch = 4,
+ call in zustellung = 5,
+
+ (*quittungscodes*)
+
+ ok = 0,
+ von vorne = 1,
+ wiederhole = 2,
+ loesche = 3,
+ beende = 4;
+
+LET STEUER =
+ STRUCT (
+ INT head,
+ zwischenziel,
+ zielrechner,
+ quellrechner,
+ strom,
+ sequenz,
+ seitennummer,
+ TASK quelle,ziel,
+ INT sende code);
+
+BOUND STEUER VAR open block;
+
+BOUND STRUCT (STEUER steuer, INT typ, maxseq) VAR info block;
+
+BOUND STRUCT (
+ INT head,
+ zwischenziel,
+ zielrechner,
+ quellrechner,
+ strom,
+ sequenz,
+ seitennummer) VAR vorspann ;
+
+LET ACK = STRUCT (
+ INT head,
+ zwischenziel,
+ zielrechner,
+ quellrechner,
+ strom,
+ code);
+BOUND ACK VAR ack packet ;
+BOUND ACK VAR transmitted ack packet;
+
+BOUND STRUCT (ROW maxstat INT port,
+ ROW maxstat INT zwischen) VAR route;
+
+INT CONST max verbindungsnummer := max strom;
+INT VAR codet,net mode, nutzlaenge := data length,
+ data len via node := data length via node;
+
+TEXT VAR buffer first;
+
+DATASPACE VAR work space := nilspace;
+DATASPACE VAR transmitted ack space := nilspace;
+
+
+INT VAR pakete pro seite,
+ pakete pro seite minus 1,
+ packets per page via node,
+ packets per page via node minus 1,
+ datenpacketlaenge via node,
+ datenpacketlaenge ;
+
+INT VAR strom;
+INT VAR last data := -1;
+INT VAR own:=station (myself) ,
+ quit max := 3,
+ quit zaehler := 3,
+ own256 := 256*own;
+INT CONST stx open := code stx+256*openlaenge,
+ stx quit := code stx+256*acklaenge;
+
+ STEUER VAR opti;
+ ROW maxstrom1 STEUER VAR verbindungen;
+ ROW maxstrom1 DATASPACE VAR netz dr;
+ ROW maxstrom1 INT VAR zeit, typ, open try;
+ FOR strom FROM 1 UPTO maxstrom1 REP vdr := nilspace; forget (vdr) PER;
+ ROW maxstrom INT VAR dr page ;
+ ROW maxtasks INT VAR alter call;
+
+.vx : verbindungen (strom).
+
+vdr: netz dr (strom).
+
+ via node:
+ vx.zielrechner <= 0 OR vx.quellrechner <= 0 OR
+ transmit via node OR receive via node.
+
+ transmit via node:
+ route.zwischen (vx.zielrechner) <> vx.zielrechner AND vx.zielrechner <> own.
+
+ receive via node:
+ route.zwischen (vx.quellrechner) <> vx.quellrechner AND vx.quellrechner <> own.
+
+falsche stromnummer: strom < 1 OR strom > maxstrom.
+
+zielrechner ok: vorspann.zielrechner > 0 AND vorspann.zielrechner <= maxstat.
+
+quellrechner ok: vorspann.quellrechner > 0
+ AND vorspann.quellrechner <= maxstat.
+
+call aufruf: typ(strom) >= call pingpong.
+
+alles raus: vx.seitennummer = -1 AND letztes packet der seite .
+
+letztes packet der seite :
+(vx.sequenz AND packets per page minus 1) = packets per page minus 1.
+
+neue verbindung: code t = open laenge.
+
+PROC neue routen:
+ route := old ("port intern");
+END PROC neue routen;
+
+PROC neuer start (INT CONST empfangsstroeme, mode):
+ net mode := mode;
+ strom := 1;
+ neue routen;
+ transmitted ack space := nilspace;
+ workspace := nilspace;
+ open block := workspace;
+ info block := workspace;
+ nutzlaenge := data length;
+ data len via node := data length via node;
+ pakete pro seite:= seitengroesse DIV nutzlaenge;
+ pakete pro seite minus 1 := pakete pro seite -1;
+ packets per page via node := seitengroesse DIV data len via node;
+ packets per page via node minus 1 := packets per page via node - 1;
+ datenpacketlaenge := vorspannlaenge + nutzlaenge;
+ datenpacketlaenge via node := vorspannlaenge + data len via node;
+ vorspann := workspace;
+ ack packet := workspace;
+ transmitted ack packet := transmitted ack space;
+ FOR strom FROM 1 UPTO maxstrom1 REP
+ vx.strom := 0; forget (vdr)
+ PER;
+ INT VAR i;
+ FOR i FROM 1 UPTO maxtasks REP alter call (i) := 0 PER;
+ quitmax := empfangsstroeme;
+ own:=station (myself);
+ quit zaehler := quit max;
+ own256 := 256*own;
+ reset box (net mode);
+ buffer first := "";
+ flush buffers;
+ INT VAR err;
+ fehlermeldung ruecksetzen.
+
+ fehlermeldung ruecksetzen:
+ control (12,0,0,err).
+
+END PROC neuer start;
+
+DATASPACE PROC verbindung (INT CONST nr):
+ INT VAR memory := strom;
+ strom := nr;
+ infoblock.steuer := verbindungen (nr);
+ infoblock.typ := typ (nr);
+ infoblock.maxseq := dspages (netzdr(nr)) * packets per page;
+ strom := memory;
+ workspace
+END PROC verbindung;
+
+PROC neue sendung (TASK CONST q,z, INT CONST cod,z stat, DATASPACE CONST dr):
+
+ naechste verbindung vorbereiten;
+ forget (vdr); vdr := dr;
+ sendung starten (q, z, z stat, cod)
+END PROC neue sendung;
+
+PROC zeitueberwachung
+ (INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr):
+ snr INCR 1;
+ FOR strom FROM snr UPTO maxstrom REP zeitkontrolle PER;
+ snr := 0.
+
+zeitkontrolle:
+ IF vx.strom <> 0 AND zeit(strom) > 0
+ THEN
+ zeit(strom) DECR 1;
+ IF sendung noch nicht zugestellt
+ THEN
+ IF zeit(strom) = 0
+ THEN
+ empfangsreport ("Nicht zustellbar. ");
+ loesche verbindung (strom)
+ ELSE
+ snr := strom;
+ q := vx.quelle;
+ z := vx.ziel;
+ ant := vx.sendecode;
+ dr := vdr;
+ LEAVE zeitueberwachung
+ FI
+ ELIF zeit(strom) = 0
+ THEN wiederholen
+ FI
+ FI.
+
+sendung noch nicht zugestellt:
+ typ (strom) = zustellung.
+
+wiederholen:
+ IF sendeeintrag
+ THEN
+ sendung wiederholen
+ ELSE
+ empfangseintrag freigeben
+ FI.
+
+sendeeintrag : vx.quellrechner = own .
+
+sendung wiederholen:
+ IF wiederholung noch sinnvoll
+ THEN
+ IF frisch
+ THEN
+ time out bei open
+ ELSE
+ datenteil wiederholen
+ FI
+ ELSE
+ sendung loeschen
+ FI.
+
+wiederholung noch sinnvoll:
+ task noch da AND bei call noch im call.
+
+task noch da: vx.quelle = collector OR exists (vx.quelle).
+
+bei call noch im call:
+ IF call aufruf
+ THEN
+ callee (vx.quelle) = vx.ziel
+ ELSE
+ TRUE
+ FI.
+
+frisch: vx.sequenz = -1.
+
+time out bei open:
+ IF vx.sendecode > -4 OR opentry (strom) > 0
+ THEN
+ open wiederholen ;
+ opentry (strom) DECR 1
+ ELSE
+ nak an quelle senden
+ FI.
+
+nak an quelle senden:
+ dr := nilspace;
+ BOUND TEXT VAR erm := dr;
+ erm := "Station "+text(vx.zielrechner)+" antwortet nicht";
+ snr := strom;
+ q := vx.ziel;
+ z := vx.quelle;
+ ant := error nak;
+ sendung loeschen;
+ LEAVE zeitueberwachung .
+
+open wiederholen:
+ sendereport ("wdh open");
+ IF opentry (strom) > 0 THEN zeit(strom) := 4 ELSE zeit(strom) := 40 FI;
+ openblock := vx;
+ openblock.head := stx open;
+ ab die post.
+
+datenteil wiederholen:
+ sendereport ("wdh data. sqnr "+text (vx.sequenz));
+ senden .
+
+empfangseintrag freigeben:
+ IF antwort auf call
+ THEN
+ weiter warten
+ ELSE
+ empfangsreport ("Empfangseintrag freigegeben");
+ loesche verbindung (strom)
+ FI.
+antwort auf call: callee (vx.ziel) = vx.quelle.
+
+weiter warten: zeit (strom) := 400.
+
+END PROC zeitueberwachung;
+
+PROC sendereport (TEXT CONST txt):
+ report (text (strom)+":"+txt+". Absender: """+nam (vx.quelle)+
+ """. Ziel "+text(vx.zielrechner) + " Taskindex: " +
+ text (index (vx.ziel)));
+END PROC sendereport;
+
+PROC empfangsreport (TEXT CONST txt):
+ report (text (strom)+":"+txt+". Empfänger: """
+ +nam (vx.ziel)+""". Quelle "+text (vx.quellrechner) +
+ " Taskindex: " + text (index (vx.quelle)));
+END PROC empfangsreport ;
+
+PROC sendung loeschen:
+ strom loeschen (tasknr (vx.quelle))
+END PROC sendung loeschen;
+
+PROC strom loeschen (INT CONST tasknr):
+ IF callaufruf CAND alter call (tasknr ) = strom
+ THEN
+ alter call (tasknr ) := 0
+ FI;
+ vx.strom := 0;
+ forget (vdr)
+END PROC strom loeschen;
+
+PROC empfang loeschen:
+ quit zaehler INCR 1;
+ strom loeschen (tasknr (vx.ziel))
+END PROC empfang loeschen;
+
+PROC loesche verbindung (INT CONST nr):
+ strom := nr;
+ IF sendeeintrag
+ THEN
+ sendung loeschen
+ ELSE
+ gegenstelle zum loeschen auffordern;
+ empfang loeschen
+ FI.
+
+gegenstelle zum loeschen auffordern:
+ IF verbindung aktiv THEN quittieren (-loesche) FI.
+
+verbindung aktiv: vx.strom > 0.
+
+sendeeintrag: vx.quellrechner = own .
+
+END PROC loesche verbindung;
+
+PROC weiter senden:
+ IF NOT alles raus
+ THEN
+ sequenz zaehlung;
+ IF neue seite THEN seitennummer eintragen FI;
+ senden
+ FI.
+
+sequenz zaehlung:
+ vx.sequenz INCR 1.
+
+neue seite:
+ IF via node THEN (vx.sequenz AND packets per page via node minus 1) = 0
+ ELSE (vx.sequenz AND pakete pro seite minus 1) = 0
+ FI.
+
+seitennummer eintragen:
+ dr page (strom) := vx.seiten nummer;
+ vx.seitennummer := next ds page (vdr, dr page (strom)).
+
+
+END PROC weiter senden;
+
+.packets per page:
+
+ IF via node THEN packets per page via node
+ ELSE pakete pro seite
+ FI.
+
+packets per page minus 1:
+ IF via node THEN packets per page via node minus 1
+ ELSE pakete pro seite minus 1
+ FI.
+
+used length:
+
+ IF via node THEN data len via node
+ ELSE nutzlaenge
+ FI.
+
+PROC senden:
+ INT VAR nl;
+ zeit(strom) := 6;
+ openblock := vx;
+ nl := used length;
+ transmit header (workspace);
+ vorspann senden;
+ daten senden;
+ transmit trailer.
+
+vorspann senden:
+ blockout (workspace, 1, dr verwaltungslaenge, vorspannlaenge).
+
+daten senden:
+ blockout (vdr,dr page (strom),distanz,nl).
+
+distanz: nl* (vx.sequenz AND packets per page minus 1).
+
+END PROC senden;
+
+PROC naechste verbindung vorbereiten:
+ FOR strom FROM 1 UPTO maxstrom REP
+ UNTIL vx.strom = 0 PER;
+ IF vx.strom <> 0 THEN errorstop ("Verbindungsengpass") FI.
+END PROC naechste verbindung vorbereiten;
+
+PROC sendung starten (TASK CONST quelle, ziel, INT CONST code):
+ sendung starten (quelle,ziel, station(ziel), code)
+END PROC sendung starten;
+
+PROC sendung starten (TASK CONST quelle, ziel, INT CONST ziel station,code):
+ IF ziel station = own
+ THEN
+ report ("Irrläufer: Sendung an eigene Station. Absender:"""+
+ nam (quelle)+""".");
+ vx.strom := 0;
+ forget (vdr)
+ ELSE
+ openblock.ziel := ziel;
+ openblock.quelle :=quelle;
+ openblock.sendecode := code;
+ openblock.zielrechner:= ziel station;
+ openblock.quellrechner :=own;
+ openblock.zwischenziel := route.zwischen (ziel station)+own256;
+ alten call loeschen (quelle);
+ IF call oder ping pong
+ THEN typ (strom) := call pingpong; call merken
+ ELSE typ (strom) := send wait FI;
+ sendung neu starten
+ FI.
+
+call oder pingpong: openblock.ziel = callee (openblock.quelle).
+
+call merken: alter call (tasknr (quelle)) := strom.
+
+END PROC sendung starten;
+
+PROC encode packet length (INT VAR val):
+
+ IF val < 96 THEN
+ ELIF val < 160 THEN val DECR 32
+ ELIF val < 288 THEN val DECR 128
+ ELIF val < 544 THEN val DECR 352
+ ELIF val < 1056 THEN val DECR 832
+ ELIF val < 2080 THEN val DECR 1824
+ FI;
+ rotate (val, 8)
+
+ENDPROC encode packet length;
+
+PROC sendung neu starten:
+ INT VAR value;
+ openblock.head:= stx open;
+ openblock.sequenz := -1;
+ openblock.seitennummer:= next ds page (vdr,-1);
+ openblock.strom := strom;
+ vx := open block;
+ schnelles nak bei routen liefern;
+ ab die post;
+ value := vorspannlaenge + used length;
+ encode packet length (value);
+ vx.head:=code stx+value.
+
+schnelles nak bei routen liefern:
+ IF openblock.sendecode = -routen liefern code
+ THEN
+ openblock.zwischenziel := openblock.zielrechner+own256;
+ zeit(strom) := 2;
+ opentry (strom) := 0
+ ELSE
+ zeit (strom) :=8;
+ opentry (strom) := 2
+ FI.
+
+END PROC sendung neu starten; .
+
+ab die post:
+ transmit header (workspace);
+ block out (work space,1, dr verwaltungslaenge,open laenge);
+ transmit trailer.
+
+PROC alten call loeschen (TASK CONST quelle):
+ IF alter call aktiv
+ THEN
+ INT VAR lstrom := strom;
+ vx:=openblock;
+ strom := alter call (tasknr (quelle));
+ IF in ausfuehrungsphase
+ THEN
+ sendereport ("Call-Löschung vorgemerkt");
+ loeschung vormerken
+ ELSE
+ report ("Call gelöscht."""+nam(quelle)+""". Strom "+text(strom));
+ loesche verbindung (strom)
+ FI;
+ strom := lstrom;
+ openblock := vx
+ FI.
+
+in ausfuehrungsphase:
+ typ(strom) = call im wait OR typ (strom) = call in zustellung.
+
+loeschung vormerken:
+ typ(strom) := call im abbruch;
+ alter call (tasknr (quelle)) := 0.
+
+
+ alter call aktiv:
+ alter call (tasknr (quelle)) > 0.
+
+END PROC alten call loeschen;
+
+PROC packet eingang
+ ( INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr):
+ snr := 0;
+ fehlertest;
+ vorspann holen;
+ IF NOT ring logik THEN daten teil FI.
+
+ring logik: FALSE.
+
+fehlertest:
+#
+ INT VAR c12;
+ control (12,0,0,c12);
+ IF c12 <> 0
+ THEN
+ flush buffers;
+ report ("E/A-Fehler "+text (c12));
+ control (12,0,0,c12);
+ LEAVE packet eingang
+ FI.
+
+ #.
+
+vorspann holen:
+ sync;
+ IF NOT blockin (workspace, 1, dr verwaltungslaenge2, block laenge)
+ THEN LEAVE packeteingang
+ FI.
+
+
+blocklaenge: IF code t > min data length
+ THEN
+ vorspannlaenge-2
+ ELSE
+ code t -2
+ FI.
+
+sync:
+ IF NOT packet start already inspected
+ THEN
+ TEXT VAR skipped, t:= "";
+ skipped := next packet start;
+ IF skipped = "" THEN LEAVE packet eingang FI;
+ t := incharety (1);
+ code t := code (t);
+ ELSE
+ skipped := buffer first;
+ buffer first := "";
+ t := incharety (1);
+ code t := code (t);
+ FI;
+ decode packet length;
+IF skipped=stx AND laenge ok THEN LEAVE sync FI;
+ REP
+ skipped CAT t;
+ t := incharety (1); (* next character *)
+ IF t = "" THEN
+ report ("skipped",skipped);
+ LEAVE packet eingang
+ FI ;
+ codet := code (t);
+ UNTIL blockanfang OR length (skipped) > 200 PER;
+ decode packet length;
+ IF skipped <> stx THEN report ("skipped bei sync:", skipped) FI.
+
+decode packet length:
+
+IF code t < 96 THEN
+ ELIF code t < 128 THEN code t INCR 32
+ ELIF code t < 160 THEN code t INCR 128
+ ELIF code t < 192 THEN code t INCR 352
+ ELIF code t < 224 THEN code t INCR 832
+ ELIF code t < 256 THEN code t INCR 1824
+FI.
+
+packet start already inspected: buffer first <> "".
+
+blockanfang:
+ (skipped SUB length(skipped)) = stx AND laenge ok.
+
+laenge ok:
+ (codet = datenpacketlaenge OR codet = datenpacketlaenge via node
+ OR codet = ack laenge OR code t = openlaenge).
+
+zielnummer: vorspann.zielrechner.
+
+daten teil:
+ IF zielnummer = own
+ THEN
+ ziel erreicht (openblock,snr,q,z,ant,dr)
+ ELSE
+ weiter faedeln
+ FI.
+
+weiter faedeln:
+ INT VAR value;
+ IF zielrechner ok
+ THEN
+ IF neue verbindung
+ THEN
+ IF (openblock.sendecode = -routenlieferncode) OR NOT route ok
+ THEN LEAVE packet eingang
+ FI
+ FI;
+ value := code t;
+ encode packet length (value);
+ vorspann.head := code stx + value;
+ vorspann.zwischenziel := own256 + route.zwischen (vorspann.zielrechner);
+ nutzdaten einlesen;
+ dr := workspace;
+ snr := 1000;
+ ant := zielnummer
+ FI.
+
+nutzdaten einlesen:
+ IF code t > data len via node
+ THEN
+ IF NOT blockin (workspace, 1, drverwaltungslaenge+vorspannlaenge, data len via node)
+ THEN
+ LEAVE packeteingang
+ FI;
+ IF NOT next packet ok THEN LEAVE packeteingang FI
+ FI.
+
+END PROC packet eingang;
+
+PROC ziel erreicht (STEUER CONST prefix,
+ INT VAR snr, TASK VAR q, z, INT VAR ant,DATASPACE VAR dr):
+ last data := -1;
+ IF NOT quellrechner ok
+ THEN
+ report ("Quellrechner "+text(prefix.quellrechner));
+ LEAVE ziel erreicht
+ FI;
+ IF neue verbindung
+ THEN
+ IF NOT route ok OR NOT quelltask ok
+ THEN report ("verbotene Route: " + text (prefix.quellrechner));
+ LEAVE ziel erreicht
+ FI;
+ verbindung bereitstellen
+ ELIF quittung
+ THEN
+ strom := ack packet.strom;
+ IF falsche stromnummer THEN report ("Strom falsch in Quittung");
+ LEAVE ziel erreicht FI;
+ IF vx.strom = 0 THEN LEAVE ziel erreicht FI;
+ IF ackpacket.code >= ok THEN weiter senden
+ ELIF NOT route ok THEN
+ sendereport ("verbotene Route bei Quittung");
+ LEAVE ziel erreicht
+ ELIF ackpacket.code = -von vorne THEN
+ sendereport ("Neustart");
+ openblock := vx;
+ sendung neu starten
+ ELIF ackpacket.code = -wiederhole THEN back 16
+ ELIF ackpacket.code = -loesche THEN fremdloeschung
+ ELIF ackpacket.code = -beende AND alles raus THEN strom abschliessen
+ FI
+ ELIF verbindung festgestellt
+ THEN
+ zeit(strom) := 400;
+ opti := vx;
+ datenpacket
+ ELSE
+ strom := maxstrom1;
+ vx:=prefix;
+ report ("Daten ohne Eroeffnung von " +text(prefix.quellrechner)
+ +" Sequenznr "+text(prefix.sequenz));
+ daten entfernen (used length);
+ IF alles raus THEN quittieren (-beende) ELSE quittieren(-von vorne) FI
+ FI.
+
+quelltask ok:
+ prefix.quelle = collector OR antwort auf routen liefern
+ OR station (prefix.quelle) = prefix.quellrechner.
+
+antwort auf routen liefern: prefix.quelle = myself.
+
+verbindung bereitstellen:
+ IF (prefix.sendecode < 0 OR station (prefix.ziel) = own)
+ AND quellrechner ok
+ THEN
+ freie verbindungsnummer;
+ vdr := nilspace;
+ vx := open block;
+ zeit(strom) := 30;
+ quittieren falls genug pufferplatz;
+ vx.sequenz := 0 ;
+ opti := vx;
+ dr page (strom) :=-2;
+ IF abschluss THEN rueckmeldung FI
+ FI.
+
+loeschung vorgemerkt: typ(strom) = call im abbruch.
+
+strom abschliessen:
+ IF call aufruf
+ THEN
+ wdh data vor ablauf der zustellversuche bei der gegenstation;
+ ausfuehrungsphase merken
+ ELSE
+ wdh data sperren
+ FI.
+
+wdh data sperren:
+ zeit (strom) := 12000.
+
+wdh data vor ablauf der zustellversuche bei der gegenstation:
+ zeit (strom) := 80.
+
+ausfuehrungsphase merken: typ(strom) := call in zustellung.
+
+back16:
+ datenraum etwas rueckspulen;
+ opentry (strom) := 2;
+ nicht sofort senden (* wegen vagabundierender Quittungen *).
+
+nicht sofort senden: zeit(strom) := 2.
+
+datenraum etwas rueckspulen:
+ INT VAR pps := packets per page ;
+ sendereport ("etwas rueckgespult");
+ INT VAR vs :=-1;
+ dr page (strom) := -1;
+ INT VAR i;
+ FOR i FROM 1 UPTO vx.sequenz DIV pps - etwas REP
+ vs INCR pps;
+ dr page (strom) := next ds page (vdr, dr page (strom))
+ PER;
+ vx.seiten nummer := next ds page (vdr, dr page (strom)) ;
+ vx.sequenz := vs.
+
+etwas: 3.
+
+fremdloeschung:
+ IF fremdrechner ok und sendung
+ THEN
+ IF typ (strom) = call in zustellung
+ THEN
+ typ (strom) := call im wait
+ ELSE
+ IF NOT alles raus
+ THEN
+ sendereport ("Sendung von Gegenstelle geloescht")
+ FI;
+ sendung loeschen
+ FI
+ FI.
+
+fremdrechner ok und sendung:
+ ackpacket.quellrechner = vx.zielrechner .
+
+
+quittieren falls genug pufferplatz:
+ IF quit zaehler > 0 THEN
+ quit zaehler DECR 1;
+ open quittieren;
+ block vorab quittieren
+ ELSE
+ quittieren (-wiederhole)
+ FI.
+
+open quittieren: quittieren (ok).
+block vorab quittieren:
+ IF prio (myself) < 3 THEN quittieren (ok) FI.
+
+quittung: code t <= ack laenge.
+
+
+verbindung festgestellt:
+ FOR strom FROM maxstrom DOWNTO 1 REP
+ IF bekannter strom
+ THEN LEAVE verbindung festgestellt WITH TRUE FI
+ PER;
+ FALSE.
+
+bekannter strom:
+ vx.strom = prefix.strom AND vom selben rechner.
+
+vom selben rechner:
+ vx.quellrechner = prefix.quellrechner.
+
+daten:
+ IF neue seite da THEN check for valid pagenr;
+ dr page(strom) := prefix.seitennummer;
+ ELIF prefix.seitennummer < dr page(strom)
+ THEN empfangsreport ("Falsche Seitennummer, Soll: " +
+ text(drpage(strom)) + " ist: " +
+ text (prefix.seitennummer)
+ + " bei Sequenznr: " +
+ text(prefix.sequenz));
+ flush buffers;
+ quittieren (- wiederhole);
+ LEAVE ziel erreicht
+ FI;
+ sequenz zaehlung;
+ IF neue seite kommt
+ THEN
+ vx.seiten nummer := prefix.seiten nummer;
+ dr page(strom) := prefix.seitennummer;
+ FI;
+ quittieren(ok);
+ IF NOT blockin (vdr, opti.seiten nummer, distanz, nl)
+ COR NOT next packet ok
+ THEN quittieren (-wiederhole);
+ LEAVE ziel erreicht
+ FI;
+ last data := strom.
+
+check for valid pagenr:
+ IF prefix.seitennummer < dr page(strom) AND prefix.seitennummer > -1
+ THEN report ("Absteigende Seitennummern, alt: " + text(drpage(strom))+
+ " neu: "+ text(prefix.seitennummer) + " Seq.nr: " +
+ text(vx.sequenz) ) ;
+ flush buffers;
+ quittieren (- von vorne);
+ LEAVE ziel erreicht;
+ FI.
+
+datenpacket:
+ INT VAR nl := used length;
+ INT VAR pps1 := packets per page minus 1;
+ IF sendung wartet auf zustellung THEN auffrischen ELSE daten holen FI.
+
+sendung wartet auf zustellung: typ (strom) = zustellung.
+
+auffrischen: zeit (strom) := 200; daten entfernen (nl).
+
+daten holen:
+ IF opti.sequenz >= prefix.sequenz AND opti.sequenz < prefix.sequenz+100
+ AND prefix.sequenz >= 0
+ THEN
+ IF opti.sequenz <> prefix.sequenz
+ THEN empfangsreport ("Sequenzreset von "+text(opti.sequenz)+" auf "+
+ text (prefix.sequenz));
+ vx.sequenz := prefix.sequenz;
+ IF pagenumber ok
+ THEN dr page (strom) := prefix.seitennummer
+ ELSE empfangsreport ("Blocknummer falsch, neu: "+
+ text (prefix.seitennummer) + ", alt : " +
+ text (drpage(strom)) );
+ FI;
+ vorabquittung regenerieren
+ FI;
+ daten ;
+ IF abschluss THEN rueckmeldung FI;
+ ELSE
+ empfangsreport ("Sequenzfehler: soll "+text(vx.sequenz)+" ist "+
+ text(prefix.sequenz));
+ quittieren (-wiederhole);
+ daten entfernen (nl)
+ FI.
+
+pagenumber ok:
+ dr page (strom) >= prefix.seitennummer .
+
+rueckmeldung:
+ snr := strom;
+ q := vx.quelle;
+ z := vx.ziel;
+ ant := vx.sendecode;
+ dr := vdr;
+ LEAVE ziel erreicht.
+
+vorabquittung regenerieren:
+ IF prio (myself) < 3
+ THEN
+ quittieren (ok)
+ FI.
+
+distanz: (opti.sequenz AND pps1 ) * nl.
+
+sequenz zaehlung:
+ vx.sequenz INCR 1.
+
+neue seite da:
+ neue seite kommt.
+
+neue seite kommt:
+(vx.sequenz AND pps1) = 0.
+
+freie verbindungsnummer:
+ INT VAR h strom :=maxstrom1, cstrom := 0;
+ FOR strom FROM 1 UPTO maxstrom REP
+ IF vx.strom = 0 THEN h strom := strom ;
+ typ(strom) := send wait
+ ELIF bekannter strom
+ THEN empfangsreport ("Reopen");
+ quit zaehler INCR 1;
+ IF typ (strom) = zustellung THEN typ (strom) := send wait FI;
+ forget (vdr);
+ LEAVE freie verbindungsnummer
+ ELIF antwort auf call
+ THEN
+ IF loeschung vorgemerkt
+ THEN
+ vx := prefix;
+ loesche verbindung (strom);
+ LEAVE ziel erreicht
+ FI;
+ cstrom := strom;
+ typ (strom) := call pingpong;
+ forget (vdr);
+ FI
+ PER;
+ IF cstrom > 0 THEN strom := cstrom ELSE strom := h strom FI;
+ IF strom = maxstrom1 THEN
+ vx:=prefix;
+ empfangsreport ("Verbindungsengpass");
+ quittieren (-wiederhole);
+ LEAVE ziel erreicht
+ FI.
+
+antwort auf call:
+ prefix.sendecode >= 0 AND
+ call aufruf AND vx.quelle = prefix.ziel AND vx.ziel = prefix.quelle.
+
+END PROC ziel erreicht;
+
+PROC daten entfernen (INT CONST wieviel):
+ BOOL VAR dummy ;
+ dummy:=blockin (workspace, 2, 0, wieviel)
+END PROC daten entfernen;
+
+BOOL PROC route ok:
+ INT VAR zwischenquelle := vorspann.zwischenziel DIV 256,
+ endquelle := vorspann.quellrechner;
+ zwischenquelle abgleichen;
+ endquelle abgleichen;
+ TRUE.
+
+zwischenquelle abgleichen:
+ IF NOT zwischenroute gleich
+ THEN
+ IF NOT zwischenabgleich erlaubt THEN LEAVE route ok WITH FALSE FI;
+ route.port (zwischenquelle) := channel;
+ route.zwischen (zwischenquelle) := zwischenquelle;
+ abgleich (zwischenquelle, zwischenquelle)
+ FI.
+
+zwischenabgleich erlaubt: route.port (zwischenquelle) < 256.
+
+endquelle abgleichen:
+ IF NOT endroute gleich
+ THEN
+ IF NOT endabgleich erlaubt THEN LEAVE route ok WITH FALSE FI;
+ route.port (endquelle) := channel;
+ route.zwischen (endquelle) := zwischenquelle;
+ abgleich (endquelle, zwischenquelle)
+ FI.
+
+endabgleich erlaubt: route.port (endquelle) < 256.
+
+zwischenroute gleich:
+ (route.port (zwischenquelle) AND 255) = channel
+ AND
+ route.zwischen (zwischenquelle) = zwischenquelle.
+
+endroute gleich:
+ (route.port (endquelle) AND 255) = channel
+ AND
+ route.zwischen (endquelle) = zwischenquelle.
+
+END PROC route ok;
+
+BOOL PROC abschluss:
+
+ last data := -1;
+ IF neue seite kommt AND vx.seiten nummer = -1
+ THEN
+ quittieren (-beende);
+ an ziel weitergeben
+ ELSE
+ FALSE
+ FI.
+neue seite kommt:
+(vx.sequenz AND packets per page minus 1) = 0.
+
+an ziel weitergeben:
+ IF tasknummerfrage THEN taskfrage beantworten ;pufferplatz ; FALSE
+ ELIF tasknamenfrage THEN name senden ;pufferplatz ; FALSE
+ ELIF taskinfofrage THEN task info senden;pufferplatz ; FALSE
+ ELIF routenfrage THEN routen senden; pufferplatz; FALSE
+ ELSE senden ; TRUE
+ FI.
+
+pufferplatz : quitzaehler INCR 1 .
+
+senden:
+ IF callaufruf
+ THEN
+ ein versuch (* bei Antwort auf Call muß ein Zustellversuch reichen *)
+ ELSE
+ max 100 versuche;
+ typ (strom) := zustellung
+ FI.
+
+tasknummerfrage:opti.sendecode = -taskid code.
+
+tasknamenfrage: opti.sendecode = -name code.
+
+taskinfofrage: opti.sendecode = -task info code.
+
+routenfrage: opti.sendecode = -routen liefern code.
+
+max 100 versuche: zeit(strom) := 100.
+
+ein versuch: zeit (strom) := 1.
+
+taskfrage beantworten:
+ disable stop;
+ BOUND TEXT VAR tsk := vdr;
+ TEXT VAR save tsk := tsk;
+ forget (vdr); vdr := nilspace;
+ BOUND TASK VAR task id := vdr;
+ task id := task(save tsk);
+ IF is error THEN
+ clear error; enable stop;
+ forget (vdr); vdr := nilspace;
+ BOUND TEXT VAR errtxt := vdr;
+ errtxt := text(own)+"/"""+save tsk+""" gibt es nicht";
+ sendung starten (collector, opti.quelle, 2)
+ ELSE
+ enable stop;
+ sendung starten (collector, opti.quelle, 0)
+ FI.
+
+name senden:
+ quittieren (-loesche);
+ forget (vdr); vdr := nilspace;
+ tsk := vdr;
+ tsk := nam (opti.ziel);
+ sendung starten (collector, opti.quelle, 0).
+
+routen senden:
+ forget (vdr); vdr := old ("port intern");
+ sendung starten (opti.ziel, opti.quelle, 0).
+
+task info senden:
+ disable stop;
+ BOUND INT VAR ti code := vdr;
+ INT VAR ti cd := ti code;
+ forget (vdr); vdr := nilspace;
+ FILE VAR task inf := sequential file (output,vdr);
+ head line (task inf,"Station "+text(own));
+ task info (ti cd, task inf);
+ IF is error
+ THEN
+ forget (vdr); vdr := nilspace;
+ errtxt := vdr;
+ errtxt := errormessage;
+ clear error;
+ sendung starten (collector, opti.quelle, 2)
+ ELSE
+ sendung starten (collector,opti.quelle,0)
+ FI;
+ enable stop
+END PROC abschluss ;
+
+PROC quittieren(INT CONST code) :
+ INT VAR quell := vx.quellrechner ;
+ transmitted ackpacket := ACK:(stx quit, route.zwischen (quell)+own256, quell, own,
+ vx.strom, code);
+ transmit header (transmitted ack space);
+ blockout (transmitted ack space,1,dr verwaltungslaenge, ack laenge);
+ transmit trailer;
+END PROC quittieren;
+
+BOOL PROC next packet ok:
+ buffer first := next packet start;
+ buffer first = "" COR normal packet start.
+
+normal packet start:
+ IF buffer first = stx
+ THEN
+ TRUE
+ ELSE
+ buffer first := ""; flush buffers; FALSE
+ FI.
+
+END PROC next packet ok;
+END PACKET basic net;
+
+
diff --git a/system/net/1.8.7/src/net files-M b/system/net/1.8.7/src/net files-M
new file mode 100644
index 0000000..ae6f9f3
--- /dev/null
+++ b/system/net/1.8.7/src/net files-M
@@ -0,0 +1,5 @@
+net report
+net hardware interface
+basic net
+net manager
+
diff --git a/system/net/1.8.7/src/net hardware interface b/system/net/1.8.7/src/net hardware interface
new file mode 100644
index 0000000..4e3466a
--- /dev/null
+++ b/system/net/1.8.7/src/net hardware interface
@@ -0,0 +1,389 @@
+PACKET net hardware
+
+(************************************************************************)
+(**** Netzprotokoll Anpassung *)
+(**** Komplette Version mit BUS Anpassung 10.06.87 *)
+(**** mit I/0 Controls fuer integrierte Karten *)
+(**** Verschiedene Nutztelegrammgrössen *)
+(**** Version: GMD 2.0 A.Reichpietsch *)
+(************************************************************************)
+
+ DEFINES
+ blockin,
+ blockout,
+ set net mode,
+ net address,
+ mode text,
+ data length,
+ data length via node,
+ decode packet length,
+ next packet start,
+ flush buffers,
+ transmit header,
+ transmit trailer,
+ version,
+ reset box,
+ max mode,
+ net mode:
+
+
+
+
+ LET eak prefix laenge = 6,
+ packet length before stx = 14 (*eth header =14 *),
+ maximum mode nr = 12,
+ stx = ""2"",
+ niltext = "",
+ null = "0",
+ hex null = ""0"",
+ blank = " ",
+ eak prefix = ""0""0""0""0"",
+ typefield = "EU",
+ prefix adresse = "BOX",
+ second prefix adresse = ""0"BOX",
+ second address type bound = 90;
+
+ INT CONST data length via node :: 64;
+ TEXT CONST version :: "GMD 2.0 (10.6.87)";
+
+
+ TEXT VAR own address;
+ INT VAR paketlaenge, eumel paket laenge, mode, rahmenlaenge, actual data length;
+
+BOOL PROC blockin (DATASPACE VAR ds, INT CONST seite, abstand, laenge):
+ INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512;
+ REAL VAR time out := clock (1) + 10.0;
+ REP
+ blockin (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge);
+ UNTIL hilfslaenge = 0 OR clock (1) > time out PER ;
+ IF hilfslaenge <> 0
+ THEN report ("blockin abbruch, fehlende Zeichen: "+text(hilfslaenge));
+ FI;
+ hilfslaenge = 0
+END PROC blockin;
+
+PROC blockout (DATASPACE CONST ds, INT CONST seite, abstand, laenge):
+ INT VAR hilfslaenge:=laenge, code:= abstand+laenge+512;
+ REP
+ blockout (ds,seite,code-hilfslaenge, hilfslaenge, hilfslaenge);
+ UNTIL hilfslaenge = 0 PER
+END PROC blockout;
+
+PROC set net mode (INT CONST new mode):
+ mode := new mode ;
+ own address := net address (station(myself));
+ SELECT mode OF
+ CASE 1,3 : set data length (64);
+ CASE 2 : std framelength; set data length (64)
+ CASE 4,6 : set data length (128)
+ CASE 5 : std framelength; set data length (128)
+ CASE 7,9 : set data length (256)
+ CASE 8 : std framelength; set data length (256)
+ CASE 10,12 : set data length (512)
+ CASE 11 : std framelength; set data length (512);
+
+ OTHERWISE
+ END SELECT.
+
+ std framelength:
+ rahmenlaenge := eak prefix laenge + packet length before stx.
+
+ENDPROC set net mode;
+
+INT PROC max mode:
+ maximum mode nr
+ENDPROC max mode;
+
+INT PROC net mode:
+ mode
+ENDPROC net mode;
+
+TEXT PROC mode text:
+ mode text (mode)
+ENDPROC mode text;
+
+TEXT PROC mode text (INT CONST act mode):
+ SELECT act mode OF
+ CASE 1: "Modus: (1) EUMEL-Netz 64 Byte"
+ CASE 2: "Modus: (2) ETHERNET via V.24 64 Byte"
+ CASE 3: "Modus: (3) ETHERNET integrated 64 Byte"
+ CASE 4: "Modus: (4) EUMEL-Netz 128 Byte"
+ CASE 5: "Modus: (5) ETHERNET via V.24 128 Byte"
+ CASE 6: "Modus: (6) ETHERNET integrated 128 Byte"
+ CASE 7: "MODUS: (7) EUMEL-Netz 256 Byte"
+ CASE 8: "MODUS: (8) ETHERNET via V.24 256 Byte"
+ CASE 9: "MODUS: (9) ETHERNET integrated 256 Byte"
+ CASE 10: "MODUS: (10) EUMEL-Netz 512 Byte"
+ CASE 11: "MODUS: (11) ETHERNET via V.24 512 Byte"
+ CASE 12: "MODUS: (12) ETHERNET integrated 512 Byte"
+ OTHERWISE errorstop ("Modus " + text(mode) + " gibt es nicht");
+ error message
+ END SELECT
+
+ENDPROC mode text;
+
+PROC set data length (INT CONST new data length):
+ actual data length := new data length
+ENDPROC set data length;
+
+INT PROC data length:
+ actual data length
+ENDPROC data length;
+
+PROC reset box (INT CONST net mode):
+ SELECT net mode OF
+ CASE 1,4,7,10 : eumel net box reset
+ CASE 2,5,8,11 : eak reset
+ OTHERWISE controler reset
+ END SELECT.
+
+ eumel net box reset:
+ out (90*""4"");
+ REP UNTIL incharety (1) = niltext PER.
+
+ eak reset:
+ out ("E0"13"E0"13"").
+
+ controler reset:
+ INT VAR dummy;
+ control (-35, 0,0,dummy);
+ control (22,0,0,dummy).
+
+ENDPROC reset box;
+
+PROC remove frame
+ (TEXT VAR erstes zeichen vom eumel telegramm, BOOL VAR kein telegramm da):
+ kein telegramm da := FALSE;
+ SELECT net mode OF
+ CASE 2,5,8,11 : remove ethernet frame
+ (erstes zeichen vom eumel telegramm, kein telegramm da)
+ OTHERWISE
+ END SELECT;
+ENDPROC remove frame;
+
+PROC remove ethernet frame (TEXT VAR string, BOOL VAR schrott):
+ TEXT VAR speicher, t;
+ INT VAR lg;
+
+ t := string;
+ speicher := niltext;
+ WHILE kein stx da REP
+ lies zeichen ein;
+ teste auf timeout;
+ UNTIL textoverflow PER;
+ melde eingelesene zeichen.
+
+ lies zeichen ein:
+ speicher CAT t;
+ t := incharety (1).
+
+ teste auf timeout:
+ IF t = niltext THEN schrott := (speicher <> niltext)
+ CAND not only fill characters;
+ string := niltext;
+ LEAVE remove ethernet frame
+ FI.
+
+ not only fill characters:
+ pos (speicher, ""1"", ""254"",1) <> 0.
+
+ kein stx da :
+ t <> stx.
+
+ textoverflow:
+ length (speicher) > 1000.
+
+ melde eingelesene zeichen:
+ IF kein stx da
+ THEN kein eumeltelegrammanfang
+ ELSE untersuche ethernet header
+ FI.
+
+ kein eumeltelegrammanfang:
+ report ("skipped ,fehlendes <STX> ,letztes Zeichen:", t);
+ string := t;
+ schrott := TRUE.
+
+ untersuche ethernet header:
+ string := t;
+ IF ethernet header inkorrekt
+ THEN melde fehler
+ FI.
+
+ ethernet header inkorrekt:
+ lg := length (speicher);
+ packet zu kurz COR adresse falsch.
+
+ packet zu kurz:
+ lg < packet length before stx.
+
+ adresse falsch:
+ INT VAR adrpos := pos (speicher, own address);
+ zieladresse falsch COR adresse nicht an der richtigen pos .
+
+ zieladresse falsch:
+ adrpos < 1.
+
+ adresse nicht an der richtigen pos:
+ adrpos <> lg - packet length before stx + 1.
+
+ melde fehler:
+ report ("Header inkorrekt eingelesen: ", speicher + t);
+ string := t;
+ schrott := TRUE.
+
+ENDPROC remove ethernet frame;
+
+TEXT PROC next packet start:
+
+ TEXT VAR t := niltext;
+ BOOL VAR schrott := FALSE;
+
+ t:= incharety (1);
+ IF t = niltext THEN LEAVE next packet start WITH niltext
+ ELSE remove frame (t, schrott)
+ FI;
+ IF schrott THEN no stx or niltext
+ ELSE t
+ FI.
+
+ no stx or niltext:
+ IF t = stx THEN "2"
+ ELIF t = niltext THEN "0"
+ ELSE t
+ FI.
+
+ENDPROC next packet start;
+
+PROC flush buffers:
+ REP UNTIL incharety (5) = niltext PER;
+ report ("buffers flushed");
+ENDPROC flush buffers;
+
+PROC transmit header (DATASPACE CONST w):
+ BOUND INT VAR laengeninformation := w;
+ eumel paket laenge := laengeninformation ;
+ decode packet length (eumel paket laenge);
+ SELECT net mode OF
+ CASE 1,4,7,10 :
+ CASE 2,5,8,11 : eak und eth header senden (w)
+ OTHERWISE : telegrammanfang melden;
+ std ethernet header senden (w)
+ END SELECT;
+
+ENDPROC transmit header;
+
+PROC decode packet length (INT VAR decoded length):
+
+ decoded length DECR 2;
+ rotate (decoded length, 8);
+
+ IF decoded length < 96 THEN
+ ELIF decoded length < 128 THEN decoded length INCR 32
+ ELIF decoded length < 160 THEN decoded length INCR 128
+ ELIF decoded length < 192 THEN decoded length INCR 352
+ ELIF decoded length < 224 THEN decoded length INCR 832
+ ELIF decoded length < 256 THEN decoded length INCR 1824
+ FI;
+
+ENDPROC decode packet length;
+
+PROC transmit trailer:
+ INT VAR dummy;
+ SELECT net mode OF
+ CASE 3,6,9,12 : control (21,0,0,dummy)
+ OTHERWISE
+ END SELECT.
+
+ENDPROC transmit trailer;
+
+PROC std ethernet header senden (DATASPACE CONST x):
+ TEXT VAR eth adresse, ethernet kopf := niltext;
+ INT VAR adresse;
+ BOUND STRUCT (INT head, zwischennummern) VAR header := x;
+ zieladresse holen;
+ zieladresse senden;
+ quelladresse senden;
+ typfeld senden;
+ ausgeben.
+
+ zieladresse holen:
+ adresse := header.zwischennummern AND 255;
+ eth adresse := net address (adresse).
+
+ zieladresse senden:
+ ethernetkopf CAT eth adresse.
+
+ quelladresse senden:
+ ethernetkopf CAT own address.
+
+ typfeld senden:
+ ethernetkopf CAT typefield.
+
+ ausgeben:
+ out (ethernetkopf).
+
+ENDPROC std ethernet header senden;
+
+PROC telegrammanfang melden:
+ INT VAR dummy;
+ control (20,eumel paket laenge + packet length before stx,0, dummy).
+
+ENDPROC telegrammanfang melden;
+
+PROC eak und eth header senden (DATASPACE CONST x):
+ TEXT VAR res:= niltext;
+
+ neue laenge berechnen;
+ eak kopf senden;
+ std ethernet header senden (x).
+
+ neue laenge berechnen:
+ paket laenge := rahmenlaenge + eumel paket laenge.
+
+ eak kopf senden:
+ res := code (paket laenge DIV 256);
+ res CAT (code (paket laenge AND 255));
+ res CAT eak prefix;
+ out(res).
+
+ENDPROC eak und eth header senden;
+
+TEXT PROC net address (INT CONST eumel address):
+ TEXT VAR res ;
+ INT VAR low byte;
+
+SELECT mode OF
+ CASE 1,4,7,10 : eumel net address
+ OTHERWISE ethernet address
+END SELECT.
+
+eumel net address:
+ text(eumel address).
+
+ethernet address:
+ IF second adress kind THEN second eth header
+ ELSE first eth header
+ FI;
+ res.
+
+ second adress kind:
+ eumel address = 34 COR
+ eumel address > second address type bound.
+
+ second eth header:
+ low byte := eumel address AND 255;
+ res := second prefix adresse + code (low byte);
+ res CAT hex null.
+
+ first eth header:
+ res := prefix adresse + text (eumel address, 3);
+ changeall (res, blank, null).
+
+ENDPROC net address;
+
+ENDPACKET net hardware;
+
+
+
+
diff --git a/system/net/1.8.7/src/net inserter b/system/net/1.8.7/src/net inserter
new file mode 100644
index 0000000..c89d0f0
--- /dev/null
+++ b/system/net/1.8.7/src/net inserter
@@ -0,0 +1,145 @@
+(*************************************************************************)
+(*** Insertiert alle notwendigen Pakete, die zum Betrieb des Netzes ***)
+(*** notwendig sind. ***)
+(*** Berücksichtigt nur EUMEL - Versionen ab 1.8.1, sowie ***)
+(*** Multi-User-Version ***)
+(*** ***)
+(*** ***)
+(*** 23.05.87 ar ***)
+(*************************************************************************)
+
+LET netfile = "netz",
+ multi files = "net files/M";
+
+
+INT CONST version :: id (0);
+THESAURUS VAR tesa;
+
+head;
+IF no privileged task
+ THEN errorstop (name (myself) + " ist nicht privilegiert!")
+ ELIF station number wrong
+ THEN errorstop ("'define station' vergessen ")
+FI;
+
+IF version < 181 THEN versionsnummer zu klein
+ ELSE install net
+FI.
+
+no privileged task:
+ NOT (myself < supervisor).
+
+station number wrong:
+ station (myself) < 1.
+
+install net :
+ IF NOT exists (netfile)
+ THEN errorstop ("Datei " + netfile +" existiert nicht")
+ FI;
+ IF is multi THEN insert multi net
+ ELSE errorstop ("Diese Netzversion ist nur für Multi-user Versionen freigegeben")
+ FI;
+ forget ("net install", quiet);
+ net start.
+
+net start :
+ say line (" ");
+ do ("start");
+ do ("global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ net manager)").
+
+is multi :
+ (pcb(9) AND 255) > 1.
+
+insert multi net :
+ hole dateien vom archiv;
+ insert say and forget (tesa).
+
+hole dateien vom archiv :
+ fetch if necessary (multi files);
+ tesa := ALL (multi files);
+ forget (multi files, quiet);
+ fetch if necessary (tesa - all);
+ say line (" ");
+ say line ("Archiv-Floppy kann entnommen werden.");
+ release (archive).
+
+
+head :
+ IF online THEN page;
+ put center (" E U M E L - Netz wird installiert.");
+ line;
+ put center ("----------------------------------------");
+ line (2)
+ FI.
+
+versionsnummer zu klein :
+ errorstop ("Netzsoftware erst ab Version 1.8.1 insertierbar !").
+
+PROC fetch if necessary (TEXT CONST datei) :
+ IF NOT exists (datei) THEN say line ("Loading """ + datei + """...");
+ fetch (datei, archive)
+ FI.
+END PROC fetch if necessary;
+
+PROC fetch if necessary (THESAURUS CONST tes) :
+ do (PROC (TEXT CONST) fetch if necessary, tes)
+END PROC fetch if necessary;
+
+PROC insert say and forget (TEXT CONST name of packet):
+ IF online THEN INT VAR cx, cy;
+ put ("Inserting """ + name of packet + """...");
+ get cursor (cx, cy)
+ FI;
+ insert (name of packet);
+ IF online THEN cl eop (cx, cy); line FI;
+ forget (name of packet, quiet)
+END PROC insert say and forget;
+
+PROC insert say and forget (THESAURUS CONST tes):
+ do (PROC (TEXT CONST) insert say and forget, tes)
+END PROC insert say and forget;
+
+PROC put center (TEXT CONST t):
+ put center (t, xsize);
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, xsize);
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
+PROC say line (TEXT CONST t):
+ IF online THEN put line (t) FI
+ENDPROC say line;
+
+
+
diff --git a/system/net/1.8.7/src/net manager b/system/net/1.8.7/src/net manager
new file mode 100644
index 0000000..05f530e
--- /dev/null
+++ b/system/net/1.8.7/src/net manager
@@ -0,0 +1,797 @@
+PACKET net manager DEFINES stop,net manager,frei, routen aufbauen,
+ (* 175 net manager 8 (!) *)
+ start,
+ definiere netz,
+ aktiviere netz,
+ list option,
+ erlaube, sperre, starte kanal, routen:
+
+TEXT VAR stand := "Netzsoftware vom 10.06.87 ";
+ (*Heinrichs *)
+LET
+ maxstat = 127,
+ ack = 0,
+(* nak = 1, *)
+ error nak = 2,
+(* zeichen eingang = 4, *)
+ list code = 15,
+(* fetch code = 11, *)
+ freigabecode = 29,
+ tabellencode = 500,
+ continue code = 100,
+ erase code = 14,
+ report code = 99,
+ abgleichcode = 98,
+ neue routen code = 97,
+ dr verwaltungslaenge = 8,
+
+ (* Codes der Verbindungsebene *)
+
+ task id code = 6,
+ name code = 7,
+ task info code = 8,
+ routen liefern code = 9,
+
+ (* Weitergabecodes für Netzknoten *)
+
+ route code = 1001,
+ out code = 1003,
+
+ (* Typen von Kommunikationsströmen *)
+
+ zustellung = 1,
+ call im wait = 3,
+ call im abbruch = 4,
+ call in zustellung = 5;
+
+LET STEUER =
+ STRUCT (
+ INT head,
+ zwischenziel,
+ zielrechner,
+ quellrechner,
+ strom,
+ INT sequenz,
+ seiten nummer,
+ TASK quelle,ziel,
+ INT sende code);
+
+LET INFO = STRUCT (STEUER steuer, INT typ,maxseq);
+
+LET PARA = STRUCT (TASK quelle, ziel, INT sendecode, zielstation);
+
+
+TASK VAR sohn;
+INT VAR strom,c,kanalmode, rzaehler := 20;
+BOUND STRUCT (ROW maxstat INT port,
+ ROW maxstat INT zwischen) VAR route;
+
+
+TASK PROC netport (INT CONST ziel):
+ INT VAR kan := route.port (ziel) AND 255;
+ IF kan < 1 OR kan > 15
+ THEN
+ niltask
+ ELSE
+ IF NOT exists (nettask (kan))
+ THEN
+ access catalogue;
+ nettask (kan) := task (kan);
+ IF NOT (nettask (kan) < father) THEN nettask (kan) := niltask FI;
+ FI;
+ nettask (kan)
+ FI
+END PROC netport;
+
+PROC frei (INT CONST stat,lvl):
+ DATASPACE VAR ds := nilspace;
+ BOUND STRUCT (INT x,y) VAR msg := ds;
+ msg.x := stat; msg.y := lvl;
+ INT VAR return;
+ call (netport (stat), freigabecode, ds, return) ;
+ forget (ds)
+END PROC frei;
+
+PROC net manager (DATASPACE VAR ds, INT CONST order, phase, TASK CONST
+ ordertask):
+
+ IF order = report code AND ordertask < myself
+ THEN
+ IF storage (old("report")) > 20 THEN forget ("report", quiet) FI;
+ FILE VAR rp := sequential file (output, "report");
+ BOUND TEXT VAR rpt := ds;
+ putline (rp, rpt);
+ send (ordertask, ack, ds)
+ ELIF order = abgleichcode AND ordertask < myself
+ THEN
+ BOUND STRUCT (INT ende, zwischen) VAR x := ds;
+ route.port (x.ende) := channel (ordertask);
+ route.zwischen (x.ende) := x.zwischen;
+ send (ordertask, ack, ds)
+ ELIF order = neue routen code AND ordertask < myself
+ THEN
+ forget ("port intern");
+ copy (ds,"port intern");
+ route := old ("port intern");
+ send (ordertask, ack, ds)
+ ELIF station (ordertask) = station (myself)
+ THEN
+ IF ordertask < myself
+ OR order = list code
+ OR order > continue code
+ THEN
+ IF order = list code
+ THEN
+ enable stop;
+ forget (ds); ds := old ("report");
+ FILE VAR ff := sequential file (output,ds);
+ putline (ff,"bekannte Stationen:");
+ stationen; line (ff); putline (ff,"--------");
+ putline (ff,"Eingestellte Netzmodi:");
+ kanaele ;
+ paketgroessen;
+ line (ff); putline (ff,"********");
+ putline (ff,stand);
+ putline (ff,"Rechner "+text(station(myself))+" um "+time of day);
+ send (ordertask, ack, ds)
+ ELSE
+ free manager (ds,order,phase,order task)
+ FI
+ ELSE
+ errorstop ("nur 'list' ist erlaubt")
+ FI
+ FI .
+
+stationen:
+INT VAR stat;
+INT VAR mystation := station (myself);
+FOR stat FROM 1 UPTO maxstat REP
+ IF route.port (stat) > 0 AND stat <> mystation
+ THEN
+ put (ff,text(stat)+"("+text (route.port (stat) AND 255)+","+
+ text(route.zwischen(stat))+")")
+ FI
+PER.
+
+paketgroessen:
+
+ line(ff);
+ put (ff, "Nutzlaenge bei indirekter Verbindung "+
+ text (data length via node) + " Byte "); line (ff).
+
+kanaele:
+ INT VAR portnummer;
+ TASK VAR tsk;
+ FOR portnummer FROM 1 UPTO 15 REP
+ tsk := task (portnummer);
+ IF tsk < myself THEN beschreibe kanal FI;
+ PER.
+
+beschreibe kanal:
+ putline (ff, name (tsk) + " haengt an Kanal " + text (channel (tsk))
+ + ", " + mode text (netz mode (portnummer))).
+
+END PROC net manager;
+
+TASK VAR cd,stask;
+ROW maxstat INT VAR erlaubt;
+
+PROC communicate:
+ enable stop;
+ INT VAR scode, merken :=0;
+ DATASPACE VAR dr := nilspace;
+ neuer start (quit max, kanalmode);
+REP
+ forget (dr);
+ telegrammfreigabe;
+ wait (dr, scode, stask);
+ cd := collected destination;
+ IF weiterleitung steht noch aus
+ THEN
+ send (netport (merken), out code, mds, reply);
+ IF reply <> -2 THEN forget (mds); merken := 0 FI
+ FI;
+ IF zeichen da OR zeit abgelaufen
+ THEN
+ packet
+ ELIF cd = myself
+ THEN
+ netz info und steuerung
+ ELSE
+ sendung untersuchen (stask, cd, scode, dr)
+ FI
+PER.
+
+telegrammfreigabe:
+ INT VAR dummy;
+ control (22,0,0,dummy).
+
+zeichen da: scode < 0 .
+
+zeit abgelaufen: scode = ack AND cd = myself.
+
+packet:
+ INT VAR snr, ant,err;
+ TASK VAR quelle, ziel;
+ snr := 0;
+ IF NOT zeichen da THEN routen erneuern FI;
+ REP
+ IF NOT zeichen da
+ THEN
+ forget (dr);
+ zeitueberwachung (snr, quelle, ziel, ant, dr);
+ ELIF NOT weiterleitung steht noch aus
+ THEN
+ packet eingang (snr, quelle, ziel, ant, dr);
+ FI;
+ IF snr = 1000
+ THEN
+ packet weiterleiten
+ ELIF snr > 0
+ THEN
+ IF ant > 6 AND erlaubt(station (quelle)) < 0
+ THEN unerlaubt
+ ELSE
+ send (quelle,ziel,ant,dr,err);
+ fehlerbehandlung ;
+ FI
+ FI
+ UNTIL snr = 0 OR zeichen da PER.
+
+routen erneuern:
+ rzaehler DECR 1;
+ IF rzaehler = 0
+ THEN
+ rzaehler := 20;
+ neue routen holen
+ FI.
+
+weiterleitung steht noch aus: merken <> 0.
+
+packet weiterleiten:
+ INT VAR reply;
+ IF NOT ((route.port (ant) AND 255) = channel OR route.port (ant) < 0)
+ THEN
+ send (netport (ant), out code, dr, reply);
+ IF reply = -2
+ THEN
+ merken := ant;
+ DATASPACE VAR mds := dr
+ FI
+ ELSE
+ report ("Weiterleitung nicht möglich für "+text(ant))
+ FI.
+
+fehlerbehandlung:
+ IF ok oder ziel nicht da THEN loesche verbindung (snr) FI.
+
+ok oder ziel nicht da: err=0 OR err=-1.
+
+netz info und steuerung:
+ IF scode = list code THEN list status
+ ELIF scode = erase code THEN strom beenden
+ ELIF scode = freigabe code AND stask = father THEN freigabelevel
+ ELIF scode >= route code THEN weitergaben
+ ELIF scode > tabellencode THEN routen ausliefern
+ ELSE forget (dr); ablehnen ("nicht möglich")
+ FI.
+
+weitergaben:
+ IF stask < father
+ THEN
+ IF scode = out code
+ THEN
+ BOUND INT VAR stx lng := dr;
+ INT VAR decoded lng := stx lng;
+ decode packet length (decoded lng);
+ transmit header (dr);
+ blockout (dr,1,drverwaltungslaenge,decoded lng);
+ transmit trailer
+ ELIF scode = route code
+ THEN
+ BOUND PARA VAR parah := dr;
+ PARA VAR para := parah;
+ pingpong (stask, ack, dr, reply);
+ neue sendung (para.quelle, para.ziel, para.sendecode,
+ para.zielstation, dr);
+ forget (dr); dr := nilspace;
+ send (stask, ack, dr)
+ FI
+ ELSE
+ forget (dr);
+ ablehnen ("nicht Sohn von "+name(father))
+ FI.
+
+routen ausliefern:
+ neue sendung (stask, myself, -routen liefern code, scode-tabellencode,dr).
+
+freigabelevel:
+ BOUND STRUCT (INT stat,lvl) VAR lv := dr;
+ IF lv.stat > 0 AND lv.stat <= maxstat THEN erlaubt (lv.stat) := lv.lvl FI;
+ send (stask,ack,dr).
+
+unerlaubt:
+ report ("Fremdzugriff von "+text(station (quelle))+" auf "+nam(ziel)
+ +" code "+text(ant));
+ loesche verbindung (snr);
+ forget (dr); dr := nilspace;
+ BOUND TEXT VAR errtxt := dr;
+ errtxt:="Kein Zugriff auf Station "+text (station (myself));
+ neue sendung (ziel, quelle, error nak, station (quelle), dr).
+
+strom beenden:
+ BOUND TEXT VAR stromtext := dr;
+ INT VAR erase strom := int (stromtext);
+ forget (dr);
+ strom := erase strom;
+ IF falsche stromnummer THEN ablehnen ("Strom gibt es nicht")
+ ELSE
+ BOUND INFO VAR v := verbindung (strom);
+ IF
+ stask < supervisor OR stask = vx.quelle OR stask = vx.ziel
+ THEN
+ loeschen
+ ELSE ablehnen ("Nur Empfänger/Absender darf löschen")
+ FI
+ FI.
+
+loeschen:
+ IF sendeeintrag THEN
+ IF callee (vx.quelle) = vx.ziel THEN absender warnen FI;
+ loesche verbindung (strom)
+ ELSE
+ IF callee (vx.ziel) = vx.quelle THEN warnen FI;
+ loesche verbindung (strom)
+ FI;
+ dr := nilspace;
+ send (stask,ack,dr).
+
+absender warnen:
+ dr := nilspace;
+ send(vx.ziel,vx.quelle,1,dr,err) .
+
+warnen:
+ dr := nilspace;
+errtxt := dr; errtxt:= "Station antwortet nicht";
+send (vx.quelle,vx.ziel,error nak, dr, err).
+
+falsche stromnummer: strom < 1 OR strom > max verbindungsnummer.
+sendeeintrag: vx.quellrechner = station (myself).
+vx: v.steuer.
+END PROC communicate;
+
+PROC list option:
+ begin ("net list",PROC list net, sohn)
+END PROC list option;
+
+PROC list net:
+ disable stop;
+ DATASPACE VAR ds ;
+ INT VAR scode;
+ REP
+ wait (ds, scode, stask);
+ forget (ds); ds := nilspace;
+ FILE VAR f := sequential file (output, ds);
+ list (f, father);
+ list netports;
+ IF is error THEN clear error;
+ forget(ds);
+ ds := nilspace;
+ f := sequential file (output, ds);
+ output (f); putline (f,errormessage);
+ clear error
+ FI;
+ send (stask, ack, ds)
+ PER.
+
+list netports:
+ INT VAR k;
+ FOR k FROM 1 UPTO 15 REP
+ TASK VAR tsk := task (k);
+ IF tsk < father
+ THEN
+ putline (f, name (tsk));
+ list (f,tsk)
+ FI
+ PER.
+
+END PROC list net;
+
+PROC neue routen holen:
+ forget ("port intern", quiet);
+ fetch ("port intern");
+ route := old ("port intern");
+ neue routen
+END PROC neue routen holen;
+
+PROC sendung untersuchen (TASK CONST q, z, INT CONST cod, DATASPACE VAR dr):
+ IF z = collector
+ THEN
+ verbindungsebene
+ ELIF station (z) <> 0
+ THEN
+ sendung (q,z,cod,station (z),dr)
+ ELSE
+ ablehnen ("Station 0")
+ FI.
+
+verbindungsebene:
+ IF cod = 256 THEN name von fremdstation
+ ELIF cod > 256
+ THEN
+ taskinfo fremd
+ ELIF callee (q) = z (* gegen errornak an collector *)
+ THEN
+ task id von fremd
+ FI.
+
+taskinfo fremd: sendung (q, collector, -task info code,cod-256,dr).
+
+task id von fremd: sendung (q, collector, -task id code, zielstation, dr) .
+
+name von fremdstation:
+ BOUND TASK VAR tsk := dr;
+ TASK VAR tsk1 := tsk;
+ forget (dr);
+ dr := nilspace;
+ sendung (q, tsk1, -name code, station (tsk1), dr).
+
+zielstation: cod.
+END PROC sendung untersuchen;
+
+PROC sendung (TASK CONST q, z, INT CONST code, z stat, DATASPACE VAR dr):
+ IF z stat < 1 OR z stat > maxstat
+ THEN
+ ablehnen ("ungültige Stationsnummer");
+ LEAVE sendung
+ FI;
+ INT VAR reply;
+ INT VAR rp := route.port (z stat) AND 255;
+ IF rp = 255 THEN neue routen holen ;rp := route.port (z stat) AND 255 FI;
+ IF rp = channel
+ THEN
+ sendung selbst betreiben
+ ELIF rp > 0 AND rp < 16
+ THEN
+ sendung weitergeben
+ ELSE
+ ablehnen ("Station "+text(z stat)+" gibt es nicht")
+ FI.
+
+sendung selbst betreiben:
+ neue sendung (q, z, code, z stat, dr).
+
+sendung weitergeben:
+ DATASPACE VAR ds := nilspace;
+ BOUND PARA VAR p := ds;
+ p.quelle := q;
+ p.ziel := z;
+ p.zielstation := z stat;
+ p.sendecode := code;
+ call (netport (z stat), route code, ds, reply);
+ forget (ds);
+ pingpong (netport (z stat), 0, dr, reply);
+ forget (dr);
+ IF reply < 0 THEN ablehnen ("netport "+text(route.port(zstat)AND255)
+ + " fehlt") FI
+END PROC sendung;
+
+PROC ablehnen (TEXT CONST t):
+ DATASPACE VAR vdr := nilspace;
+ BOUND TEXT VAR errtxt := vdr;
+ INT VAR err;
+ errtxt := t;
+ send (cd,stask, error nak, vdr,err);
+ forget (vdr).
+END PROC ablehnen;
+
+PROC stop:
+ access catalogue;
+ IF exists task ("net timer")
+ THEN
+ TASK VAR nets := father (/"net timer");
+ ELSE
+ nets := myself
+ FI;
+ nets := son (nets);
+ WHILE NOT (nets = niltask) REP
+ IF text (name (nets),3) = "net" OR name (nets) = "router"
+ THEN
+ end (nets)
+ FI;
+ nets := brother (nets)
+ PER
+END PROC stop;
+
+PROC list status:
+
+ DATASPACE VAR ds := nilspace;
+ FILE VAR f:=sequential file (output, ds);
+ line(f);
+ FOR strom FROM 1 UPTO max verbindungsnummer REP
+ IF strom > 0 THEN
+ BOUND INFO VAR v := verbindung (strom);
+ IF vx.strom <> 0 THEN info FI
+ FI;
+ PER;
+ send (stask, ack, ds).
+
+info:
+ put (f,"Strom "+text(strom));
+ put (f,"(sqnr"+text(vx.sequenz)+"/"+text (v.maxseq)+")");
+ IF sendeeintrag THEN sendeinfo ELSE empfangsinfo FI;
+ line (f).
+
+sendeeintrag: vx.quellrechner = station(myself) .
+
+sendeinfo:
+ IF v.typ = call im wait THEN put (f,"erwartet Antwort von")
+ ELIF v.typ = call in zustellung THEN put (f,"Ziel busy. Zielstation:")
+ ELIF v.typ = call im abbruch THEN put (f,"wird gelöscht bei Antwort von")
+ ELSE put (f,"sendet an")
+ FI;
+ put (f,vx.zielrechner);
+ put (f,". Absender ist """+nam (vx.quelle)+""".").
+
+empfangsinfo:
+ IF v.typ = zustellung THEN
+ put (f,"Sendung noch nicht zustellbar")
+ ELSE
+ put (f,"empfängt von");
+ put (f,vx.quellrechner);
+ FI;
+ put (f,". Empfaenger ist """+nam (vx.ziel)+""".").
+
+vx: v.steuer.
+END PROC list status;
+
+INT VAR quitmax := 3;
+
+ROW 15 TASK VAR net task;
+ROW 15 INT VAR netz mode;
+
+PROC erlaube (INT CONST von, bis):
+ IF ein kanal gestartet
+ THEN
+ putline ("Warnung: 'erlaube' muß vor 'starte kanal'")
+ FI;
+ test (von); test (bis);
+ INT VAR i;
+ FOR i FROM von UPTO bis REP erlaubt (i) := 0 PER
+END PROC erlaube;
+
+PROC sperre (INT CONST von, bis):
+ IF ein kanal gestartet
+ THEN
+ putline ("Warnung: 'sperre' muß vor 'starte kanal'")
+ FI;
+ test (von); test (bis);
+ INT VAR i;
+ FOR i FROM von UPTO bis REP erlaubt (i) :=-1 PER
+END PROC sperre ;
+
+BOOL VAR alte routen, ein kanal gestartet;
+
+PROC definiere netz:
+ stop;
+ INT VAR i;
+ FOR i FROM 1 UPTO 15 REP net task (i) := niltask PER;
+ ein kanal gestartet := FALSE;
+ FILE VAR s := sequential file (output,"report");
+ putline (s," N e u e r S t a r t " + date + " " + time of day );
+ alte routen := exists ("port intern");
+ IF alte routen
+ THEN
+ route := old ("port intern")
+ ELSE
+ route := new ("port intern");
+ initialize routes
+ FI.
+
+ initialize routes:
+ FOR i FROM 1 UPTO maxstat REP
+ route.zwischen(i) := i
+ PER.
+
+END PROC definiere netz;
+
+PROC starte kanal (INT CONST k,modus,stroeme):
+ ein kanal gestartet := TRUE;
+ IF exists (canal (k)) THEN end (canal (k)) FI;
+ IF stroeme <= 0 THEN errorstop ("3.Parameter negativ") FI;
+ quitmax := stroeme;
+ c := k;
+ IF c < 1 OR c > 15 THEN errorstop ("unzulässiger Kanal:"+text(c)) FI;
+ kanalmode := modus;
+ IF kanalmode < 1 OR kanalmode > max mode
+ THEN errorstop ("unzulässiger Netzbetriebsmodus:"+text(kanalmode))
+ ELSE netz mode (c) := kanalmode
+ FI;
+ IF NOT exists task ("net port")
+ THEN
+ begin ("net port",PROC net io, net task (c));
+ define collector (/"net port")
+ ELSE
+ begin ("net port "+text (c),PROC net io, net task (c))
+ FI.
+END PROC starte kanal;
+
+PROC routen (INT CONST von, bis, kanal, zw):
+ INT VAR i;
+ IF kanal < 0 OR kanal > 15 THEN errorstop ("Kanal unzulässig") FI;
+ test (von); test (bis);
+ FOR i FROM von UPTO bis REP
+ route.port (i) := kanal+256;
+ IF zw=0
+ THEN
+ route.zwischen (i) := i
+ ELSE
+ test (zw);
+ route.zwischen (i) := zw
+ FI
+ PER.
+END PROC routen;
+
+PROC routen (INT CONST von, bis, kanal):
+ routen (von, bis, kanal, 0)
+END PROC routen;
+
+PROC test (INT CONST station):
+ IF station < 1 OR station > maxstat
+ THEN
+ errorstop (text (station) + " als Stationsnummer unzulässig")
+ FI
+END PROC test;
+
+PROC aktiviere netz:
+vorgegebene routen pruefen;
+IF existstask ("net timer") THEN end (/"net timer") FI;
+begin ("net timer",PROC timer,sohn);
+IF NOT alte routen
+THEN
+ routen aufbauen
+ELSE
+ IF online THEN break FI
+FI.
+
+vorgegebene routen pruefen:
+ INT VAR i;
+ FOR i FROM 1 UPTO maxstat REP
+ INT VAR s := route.port (i) AND 255;
+ IF s > 0 AND s <= 15 CAND nettask (s) = niltask
+ THEN
+ errorstop ("Kanal "+text(s)+" nicht gestartet, steht aber in Routen")
+ FI
+ PER.
+END PROC aktiviere netz;
+
+
+PROC routen aufbauen:
+ alte routen := TRUE;
+ c := channel;
+ break (quiet);
+ begin ("router", PROC rout0, sohn).
+END PROC routen aufbauen;
+
+PROC rout0:
+ disable stop;
+ rout;
+ IF is error
+ THEN
+ put error
+ FI;
+ end (myself)
+END PROC rout0;
+
+PROC rout:
+ IF c>0 THEN continue (c) FI;
+ clear error; enable stop;
+ fetch ("port intern");
+ route := old ("port intern");
+ routen aufbauen;
+ ds := old ("port intern");
+ call (father, neue routen code, ds, reply).
+
+routen aufbauen:
+ access catalogue;
+ TASK VAR port := brother (myself);
+ WHILE NOT (port = niltask) REP
+ IF text (name (port),8) = "net port" THEN nachbarn FI;
+ port := brother (port)
+ PER;
+ IF online THEN putline ("Fertig. Weiter mit SV !") FI.
+
+aenderbar: route.port (st) < 256.
+
+nachbarn:
+ INT VAR st,reply;
+ FOR st FROM 1 UPTO maxstat REP
+ IF erlaubt (st) >= 0 AND st <> station (myself) AND aenderbar
+ THEN
+ IF online THEN put (name (port)); put (st) FI;
+ DATASPACE VAR ds := nilspace;
+ call (port, tabellencode+st, ds, reply);
+ IF reply = ack
+ THEN
+ BOUND STRUCT (ROW maxstat INT port,
+ ROW maxstat INT zwischen) VAR fremd := ds;
+ route.port (st) := channel(port);
+ route.zwischen (st) := st;
+ indirekte ziele
+ ELIF reply < 0
+ THEN
+ errorstop ("netz läuft nicht (Kanalnummer falsch)")
+ ELSE
+ BOUND TEXT VAR xt := ds;
+ IF online THEN put (xt) FI;
+ FI;
+ IF online THEN line FI;
+ forget (ds)
+ FI
+ PER.
+
+indirekte ziele:
+ INT VAR kanal := fremd.port (station (myself)) AND 255;
+ INT VAR ind;
+ FOR ind FROM 1 UPTO maxstat REP
+ IF ind bei st bekannt AND NOT ((fremd.port (ind) AND 255) = kanal)
+ AND route.port (ind) < 256
+ THEN
+ route.port (ind) := channel (port);
+ route.zwischen (ind) := st
+ FI
+ PER.
+
+ind bei st bekannt: NOT (fremd.port (ind) = -1).
+
+END PROC rout;
+
+
+PROC timer:
+ disable stop;
+ access catalogue;
+ INT VAR old session := 1;
+ REP
+ IF session <> old session
+ THEN
+ define collector (/"net port");
+ old session := session
+ FI;
+ clear error;
+ pause (30);
+ sende tick an alle ports
+ PER.
+
+sende tick an alle ports :
+ TASK VAR fb := son (father);
+ REP
+ IF NOT exists (fb) THEN access catalogue;LEAVE sende tick an alle portsFI;
+ IF channel (fb) > 0
+ THEN
+ DATASPACE VAR ds := nilspace;
+ send (fb, ack, ds);
+ pause (10)
+ FI;
+ fb := brother (fb)
+ UNTIL fb = niltask PER.
+
+END PROC timer;
+
+PROC net io:
+ disable stop;
+ set net mode (kanalmode);
+ fetch ("port intern");
+ route := old ("port intern");
+ commanddialogue (FALSE);
+ continue (c);
+ communicate;
+ TEXT VAR emsg := "++++++ "+error message +" Zeile "+text(errorline);
+ clear error;
+ report (emsg);
+ end (myself)
+END PROC net io;
+
+PROC start: run ("netz") END PROC start;
+
+END PACKET net manager;
+
diff --git a/system/net/1.8.7/src/net report b/system/net/1.8.7/src/net report
new file mode 100644
index 0000000..ddc19d2
--- /dev/null
+++ b/system/net/1.8.7/src/net report
@@ -0,0 +1,41 @@
+PACKET net report DEFINES report, abgleich:
+(* Version 3 (!) *)
+
+LET reportcode = 99, abgleichcode = 98;
+
+PROC abgleich (INT CONST ende, zwischen):
+ DATASPACE VAR ds := nilspace;
+ BOUND STRUCT (INT ende, zwischen) VAR x := ds;
+ x.ende := ende;
+ x.zwischen := zwischen;
+ call (father, abgleichcode, ds, rep);
+ INT VAR rep;
+ forget (ds)
+END PROC abgleich;
+
+PROC report (TEXT CONST x):
+ report(x,"")
+END PROC report;
+
+PROC report (TEXT CONST txt, info):
+ DATASPACE VAR net report := nilspace;
+ BOUND TEXT VAR rinfo := net report;
+ rinfo := date;
+ rinfo CAT " "+time of day +" ";
+ rinfo CAT name(myself)+":";
+ rinfo CAT txt;
+ INT VAR i;
+ FOR i FROM 1 UPTO length (info) REP
+ INT VAR z := code (infoSUBi) ;
+ IF z < 32 OR z > 126
+ THEN rinfo CAT "%"+text(z)+" "
+ ELSE rinfo CAT (infoSUBi)+" "
+ FI
+ PER;
+ call (father, report code , net report, reply);
+ INT VAR reply;
+ forget (net report);
+END PROC report;
+
+END PACKET net report;
+
diff --git a/system/net/1.8.7/src/netz b/system/net/1.8.7/src/netz
new file mode 100644
index 0000000..c237ba2
--- /dev/null
+++ b/system/net/1.8.7/src/netz
@@ -0,0 +1,20 @@
+IF exists ("port intern") THEN forget ("port intern") FI;
+definiere netz;
+list option;
+erlaube(1,127);
+sperre (1,9);
+sperre (15,32);
+sperre (37,37);
+sperre (42,42);
+sperre (46,47);
+sperre (49,127);
+routen (1, 32,8);
+routen (33,43, 9);
+routen (34,34,8);
+routen (35,48,9);
+starte kanal (9,11,10);
+starte kanal (8,1,10);
+aktiviere netz;
+
+
+
diff --git a/system/net/1.8.7/src/port server b/system/net/1.8.7/src/port server
new file mode 100644
index 0000000..46c647f
--- /dev/null
+++ b/system/net/1.8.7/src/port server
@@ -0,0 +1,164 @@
+PACKET port server: (* Autor : R. Ruland *)
+ (* Stand : 21.03.86 *)
+
+INT VAR port station;
+TEXT VAR port := "PRINTER";
+
+put ("gib Name des Zielspools : "); editget (port); line;
+put ("gib Stationsnummer des Zielspools : "); get (port station);
+
+server channel (15);
+spool duty ("Verwalter fuer Task """ + port +
+ """ auf Station " + text (port station));
+
+LET max counter = 10 ,
+ time slice = 300 ,
+
+ ack = 0 ,
+ fetch code = 11 ,
+ param fetch code = 21 ,
+ file save code = 22 ,
+ file type = 1003 ,
+
+ begin char = ""0"",
+ end char = ""1"";
+
+
+INT VAR reply, old heap size;
+TEXT VAR file name, write pass, read pass, sendername, buffer;
+FILE VAR file;
+
+DATASPACE VAR ds, file ds, send ds;
+
+BOUND STRUCT (TEXT file name, write pass, read pass, sendername, INT station) VAR msg;
+BOUND TEXT VAR error msg ;
+
+spool manager (PROC save file);
+
+PROC save file :
+
+ disable stop ;
+ command dialogue (FALSE);
+ ds := nilspace; file ds := nilspace; send ds := nil space;
+ old heap size := heap size;
+
+ REP
+ execute save file;
+
+ IF is error THEN save error (error message) FI;
+
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI;
+
+ PER
+
+ENDPROC save file;
+
+
+PROC execute save file :
+
+enable stop;
+forget (file ds) ; file ds := nilspace;
+call (father, fetch code, file ds, reply);
+IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE save file ds
+FI;
+
+. save file ds :
+ IF type (file ds) = file type
+ THEN get file params;
+ insert file params;
+ call station (port station, port, file save code, file ds);
+ ELSE errorstop ("Datenraum hat falschen Typ")
+ FI;
+
+. get file params :
+ forget (ds); ds := nilspace;
+ call (father, param fetch code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE msg := ds;
+ file name := msg. file name;
+ write pass := msg. write pass;
+ read pass := msg. read pass;
+ sendername := msg. sender name;
+ FI;
+
+. insert file params :
+ buffer := "";
+ in headline (filename);
+ in headline (write pass);
+ in headline (read pass);
+ in headline (sendername);
+ file := sequential file (input, file ds) ;
+ headline (file, buffer);
+
+END PROC execute save file;
+
+
+PROC call station (INT CONST order task station, TEXT CONST order task name,
+ INT CONST order code, DATASPACE VAR order ds) :
+
+ INT VAR counter := 0;
+ TASK VAR order task;
+ disable stop;
+ REP order task := order task station // order task name;
+ IF is error CAND pos (error message, "antwortet nicht") > 0
+ THEN clear error;
+ counter := min (max counter, counter + 1);
+ pause (counter * time slice);
+ ELSE enable stop;
+ forget (send ds); send ds := order ds;
+ call (order task, order code, send ds, reply);
+ disable stop;
+ IF reply = ack
+ THEN forget (order ds); order ds := send ds;
+ forget (send ds);
+ LEAVE call station
+ ELSE error msg := send ds;
+ errorstop (error msg);
+ FI;
+ FI;
+ PER;
+
+END PROC call station;
+
+
+TASK OP // (INT CONST station, TEXT CONST name) :
+
+ enable stop;
+ station / name
+
+END OP //;
+
+
+PROC in headline (TEXT CONST information) :
+ IF pos (information, begin char) <> 0
+ OR pos (information, end char) <> 0
+ THEN errorstop ("Name darf nicht Code 0 oder Code 1 enthalten") FI;
+ buffer CAT begin char;
+ buffer CAT information;
+ buffer CAT end char;
+END PROC in headline;
+
+
+PROC save error (TEXT CONST message) :
+ clear error;
+ file name CAT ".";
+ file name CAT sender name;
+ file name CAT ".ERROR";
+ file := sequential file (output, file name);
+ putline (file, " ");
+ putline (file, "Uebertragung nicht korrekt beendet ");
+ putline (file, " ");
+ put (file, "ERROR :"); put (file, message);
+ save (file name, public);
+ clear error;
+ forget(file name, quiet);
+END PROC save error;
+
+ENDPACKET port server;
+
diff --git a/system/net/1.8.7/src/printer server b/system/net/1.8.7/src/printer server
new file mode 100644
index 0000000..b1a30bc
--- /dev/null
+++ b/system/net/1.8.7/src/printer server
@@ -0,0 +1,99 @@
+PACKET multi user printer : (* Autor : Rudolf Ruland *)
+ (* Stand : 24.03.86 *)
+
+INT VAR c;
+put ("gib Druckerkanal : "); get (c);
+
+ server channel (c);
+ station only (FALSE) ;
+ spool duty ("Ausgabe mit dem Drucker");
+ spool control task (myself);
+
+LET ack = 0 ,
+
+ fetch code = 11 ,
+ param fetch code = 21 ,
+ file type = 1003 ;
+
+INT VAR reply, old heap size, sender station;
+TEXT VAR file name, userid, password, sendername;
+FILE VAR file ;
+
+DATASPACE VAR ds, file ds;
+
+BOUND STRUCT (TEXT file name, userid, password, sendername, INT station) VAR msg;
+BOUND TEXT VAR error msg ;
+
+spool manager (PROC printer);
+
+PROC printer :
+
+ disable stop ;
+ command dialogue (FALSE);
+ ds := nilspace; file ds := nilspace;
+ continue (server channel) ;
+ check error ("Kanal belegt");
+
+ old heap size := heap size ;
+ REP
+ execute print ;
+
+ IF is error
+ THEN put error;
+ clear error;
+ FI ;
+
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI
+ PER
+
+ENDPROC printer ;
+
+
+PROC execute print :
+
+ enable stop ;
+ forget (file ds) ; file ds := nilspace ;
+ call (father, fetch code, file ds, reply) ;
+ IF reply = ack CAND type (file ds) = file type
+ THEN get file params;
+ print file
+ FI ;
+
+. get file params :
+ forget (ds); ds := nilspace;
+ call (father, param fetch code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE msg := ds;
+ file name := msg. file name;
+ userid := msg. userid;
+ password := msg. password;
+ sendername := msg. sender name;
+ sender station := msg. station;
+ FI;
+
+. print file :
+ file := sequential file (input, file ds);
+ print (file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC execute print ;
+
+
+PROC check error (TEXT CONST message) :
+ IF is error
+ THEN clear error;
+ rename myself (message);
+ IF is error THEN clear error; end (myself) FI;
+ pause (18000);
+ end (myself);
+ FI;
+END PROC check error;
+
+ENDPACKET multi user printer ;
+
diff --git a/system/net/1.8.7/src/spool cmd b/system/net/1.8.7/src/spool cmd
new file mode 100644
index 0000000..b44e799
--- /dev/null
+++ b/system/net/1.8.7/src/spool cmd
@@ -0,0 +1,112 @@
+PACKET spool cmd (* Autor: R. Ruland *)
+ (* Stand: 01.04.86 *)
+ DEFINES killer,
+ first,
+ start,
+ stop,
+ halt,
+ wait for halt :
+
+LET error nak = 2 ,
+
+ entry line code = 23 ,
+ killer code = 24 ,
+ first code = 25 ,
+ start code = 26 ,
+ stop code = 27 ,
+ halt code = 28 ,
+ wait for halt code = 29 ;
+
+DATASPACE VAR ds;
+
+BOUND STRUCT (TEXT entry line, INT index) VAR control msg;
+BOUND TEXT VAR error msg ;
+
+INT VAR reply;
+
+INITFLAG VAR in this task := FALSE;
+
+
+PROC control spool (TASK CONST spool, INT CONST control code,
+ TEXT CONST question, BOOL CONST leave) :
+
+ enable stop;
+ initialize control msg;
+ WHILE valid spool entry
+ REP IF control question THEN control spool entry FI PER;
+
+ . initialize control msg :
+ IF NOT initialized (in this task) THEN ds := nilspace FI;
+ forget (ds); ds := nilspace; control msg := ds;
+ control msg. entry line := "";
+ control msg. index := 0;
+ say (""13""10"");
+
+ . valid spool entry :
+ call (spool, entry line code, ds, reply);
+ IF reply = error nak
+ THEN error msg := ds;
+ errorstop (error msg);
+ FI;
+ control msg. index <> 0
+
+ . control question :
+ say (control msg. entry line);
+ yes (question)
+
+ . control spool entry :
+ call (spool, control code, ds, reply);
+ IF reply = error nak
+ THEN error msg := ds;
+ errorstop (error msg);
+ FI;
+ IF leave THEN LEAVE control spool FI;
+
+END PROC control spool;
+
+
+PROC killer (TASK CONST spool) :
+
+ control spool (spool, killer code, " loeschen", FALSE)
+
+END PROC killer;
+
+
+PROC first (TASK CONST spool) :
+
+ control spool (spool, first code, " als erstes", TRUE)
+
+END PROC first;
+
+
+PROC start (TASK CONST spool) :
+
+ call (stop code, "", spool);
+ call (start code, "", spool);
+
+END PROC start;
+
+
+PROC stop (TASK CONST spool) :
+
+ call (stop code, "", spool);
+
+END PROC stop;
+
+
+PROC halt (TASK CONST spool) :
+
+ call (halt code, "", spool);
+
+END PROC halt;
+
+
+PROC wait for halt (TASK CONST spool) :
+
+ call (wait for halt code, "", spool);
+
+END PROC wait for halt;
+
+
+END PACKET spool cmd;
+
diff --git a/system/net/1.8.7/src/spool manager b/system/net/1.8.7/src/spool manager
new file mode 100644
index 0000000..e711ab4
--- /dev/null
+++ b/system/net/1.8.7/src/spool manager
@@ -0,0 +1,915 @@
+PACKET spool manager DEFINES (* Autor: J. Liedtke *)
+ (* R. Nolting *)
+ (* R. Ruland *)
+ (* Stand: 22.07.86 *)
+
+ spool manager ,
+
+ server channel ,
+ spool duty,
+ station only,
+ spool control task :
+
+LET que size = 101 ,
+
+ ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ message ack = 3 ,
+ question ack = 4 ,
+ second phase ack = 5 ,
+ false code = 6 ,
+
+ fetch code = 11 ,
+ save code = 12 ,
+ exists code = 13 ,
+ erase code = 14 ,
+ list code = 15 ,
+ all code = 17 ,
+ param fetch code = 21 ,
+ file save code = 22 ,
+ entry line code = 23 ,
+ killer code = 24 ,
+ first code = 25 ,
+ start code = 26 ,
+ stop code = 27 ,
+ halt code = 28 ,
+ wait for halt code = 29 ,
+
+ continue code = 100 ,
+
+ file type = 1003 ;
+
+LET begin char = ""0"",
+ end char = ""1"";
+
+LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station),
+ ENTRY = STRUCT (PARAMS ds params, TEXT entry line, DATASPACE space);
+
+ROW que size ENTRY VAR que ;
+
+PARAMS CONST empty params := PARAMS : ("", "", "", "", -1);
+
+PARAMS VAR save params, file save params;
+
+ENTRY VAR fetch entry;
+
+FILE VAR file;
+
+INT VAR order, last order, phase, reply, old heap size, first, last, list index,
+ begin pos, end pos, order task station, sp channel, counter;
+
+TEXT VAR order task name, buffer, sp duty, start time;
+
+BOOL VAR server is waiting, stop command pending, stat only, valid fetch entry;
+
+TASK VAR order task, last order task, server, calling parent, task in control;
+
+INITFLAG VAR in this task := FALSE;
+
+DATASPACE VAR ds;
+
+BOUND STRUCT (TEXT name, userid, password) VAR msg;
+BOUND STRUCT (TEXT entry line, INT index) VAR control msg;
+BOUND PARAMS VAR fetch msg;
+BOUND THESAURUS VAR all msg;
+BOUND TEXT VAR error msg ;
+
+
+. first entry : que (first)
+. list entry : que (list index)
+. last entry : que (last)
+
+. que is empty : first = last
+. que is full : first = next (last)
+.;
+
+sp channel := 0;
+sp duty := "";
+stat only := FALSE;
+task in control := myself;
+
+PROC server channel (INT CONST channel nr) :
+ IF channel nr <= 0 OR channel nr >= 33
+ THEN errorstop ("falsche Kanalangabe") FI;
+ sp channel := channel nr;
+END PROC server channel;
+
+INT PROC server channel :
+ sp channel
+END PROC server channel;
+
+
+PROC station only (BOOL CONST flag) :
+ stat only := flag
+END PROC station only;
+
+BOOL PROC station only :
+ stat only
+END PROC station only;
+
+
+PROC spool duty (TEXT CONST duty) :
+ sp duty := duty;
+END PROC spool duty;
+
+TEXT PROC spool duty :
+ sp duty
+END PROC spool duty;
+
+
+PROC spool control task (TASK CONST task id):
+ task in control := task id;
+END PROC spool control task;
+
+TASK PROC spool control task :
+ task in control
+END PROC spool control task;
+
+
+PROC spool manager (PROC server start) :
+
+ spool manager (PROC server start, TRUE)
+
+END PROC spool manager;
+
+
+PROC spool manager (PROC server start, BOOL CONST with start) :
+
+ set autonom ;
+ break ;
+ disable stop ;
+ initialize spool manager ;
+ REP forget (ds) ;
+ wait (ds, order, order task) ;
+ IF order <> second phase ack
+ THEN prepare first phase ;
+ spool (PROC server start);
+ ELIF order task = last order task
+ THEN prepare second phase ;
+ spool (PROC server start);
+ ELSE send nak
+ FI ;
+ send error if necessary ;
+ collect heap garbage if necessary
+ PER
+
+ . initialize spool manager :
+ initialize if necessary;
+ stop;
+ erase fetch entry;
+ IF with start THEN start (PROC server start) FI;
+
+ . initialize if necessary :
+ IF NOT initialized (in this task)
+ THEN FOR list index FROM 1 UPTO que size
+ REP list entry. space := nilspace PER;
+ fetch entry. space := nilspace;
+ ds := nilspace;
+ last order task := niltask;
+ server := niltask;
+ calling parent := niltask;
+ server is waiting := FALSE;
+ stop command pending := FALSE;
+ old heap size := 0;
+ clear spool;
+ FI;
+
+ . prepare first phase :
+ IF order = save code OR order = erase code OR order = stop code
+ THEN phase := 1 ;
+ last order := order ;
+ last order task := order task ;
+ FI;
+
+ . prepare second phase :
+ phase INCR 1 ;
+ order := last order
+
+ . send nak :
+ forget (ds) ;
+ ds := nilspace ;
+ send (order task, nak, ds);
+
+ . send error if necessary :
+ IF is error
+ THEN forget (ds) ;
+ ds := nilspace ;
+ error msg := ds ;
+ CONCR (error msg) := error message;
+ clear error;
+ send (order task, error nak, ds)
+ FI;
+
+ . collect heap garbage if necessary :
+ IF heap size > old heap size + 2
+ THEN collect heap garbage;
+ old heap size := heap size;
+ FI;
+
+END PROC spool manager;
+
+
+PROC spool (PROC server start):
+
+ command dialogue (FALSE);
+ enable stop;
+ IF station only CAND station (ordertask) <> station (myself)
+ THEN errorstop ("kein Zugriffsrecht auf Task " + text (station(myself))
+ + "/""" + name(myself) + """")
+ FI;
+
+ SELECT order OF
+
+ CASE fetch code : out of que
+ CASE param fetch code : send fetch params
+ CASE save code : new que entry
+ CASE file save code : new file que entry
+ CASE exists code : exists que entry
+ CASE erase code : erase que entry
+ CASE list code : send spool list
+ CASE all code : send owners ds names
+
+ OTHERWISE :
+
+ IF order >= continue code AND order task = supervisor
+ THEN forget (ds);
+ spool command (PROC server start)
+
+ ELIF spool control allowed by order task
+ THEN SELECT order OF
+ CASE entry line code : send next entry line
+ CASE killer code : kill entry
+ CASE first code : make to first
+ CASE start code : start server
+ CASE stop code : stop server
+ CASE halt code : halt server
+ CASE wait for halt code : wait for halt
+ OTHERWISE : errorstop ("falscher Auftrag fuer Task """
+ + name(myself) + """")
+ END SELECT
+
+ ELSE errorstop ("falscher Auftrag fuer Task """
+ + name(myself) + """")
+ FI;
+ END SELECT;
+
+
+. spool control allowed by order task :
+ (order task = spool control task OR order task < spool control task
+ OR spool control task = supervisor)
+ AND station (order task) = station (myself)
+.
+ out of que :
+ IF NOT (order task = server)
+ THEN errorstop ("keine Servertask")
+ ELIF stop command pending
+ THEN forget (ds);
+ stop;
+ erase fetch entry;
+ ELIF que is empty
+ THEN forget (ds) ;
+ erase fetch entry;
+ server is waiting := TRUE;
+ ELSE send first entry;
+ FI;
+
+.
+ send fetch params :
+ IF order task = server
+ THEN send params
+ ELSE errorstop ("keine Servertask")
+ FI;
+
+ . send params :
+ forget(ds); ds := nilspace; fetch msg := ds;
+ fetch msg := fetch entry. ds params;
+ send (order task, ack, ds);
+
+.
+ new que entry :
+ IF phase = 1
+ THEN prepare into que
+ ELSE into que
+ FI;
+
+.
+ prepare into que :
+ msg := ds ;
+ save params. name := msg.name;
+ save params. userid := msg.userid;
+ save params. password := msg.password;
+ save params. sendername := name (order task);
+ save params. station := station (order task);
+ forget (ds); ds := nilspace;
+ send (order task, second phase ack, ds);
+
+.
+ new file que entry :
+ IF type (ds) <> file type
+ THEN errorstop ("Datenraum hat falschen Typ");
+ ELSE get file params;
+ into que;
+ FI;
+
+ . get file params :
+ file := sequential file (input, ds);
+ end pos := 0;
+ next headline information (file save params. name);
+ next headline information (file save params. userid);
+ next headline information (file save params. password);
+ next headline information (file save params. sendername);
+ next headline information (buffer);
+ file save params. station := int (buffer);
+ IF NOT last conversion ok
+ THEN file save params. station := station (order task) FI;
+ IF file save params. sendername = ""
+ THEN file save params. sendername := name (order task) FI;
+ IF file save params. name = ""
+ THEN IF headline (file) <> ""
+ THEN file save params. name := headline (file);
+ ELSE errorstop ("Name unzulaessig")
+ FI;
+ ELSE headline (file, file save params. name);
+ FI;
+
+.
+ exists que entry :
+ msg := ds ;
+ order task name := name (order task);
+ order task station := station (order task);
+ to first que entry;
+ WHILE next que entry found
+ REP IF is entry from order task (msg. name)
+ THEN send ack;
+ LEAVE exists que entry
+ FI;
+ PER ;
+ forget (ds); ds := nilspace;
+ send (order task, false code, ds)
+
+.
+ erase que entry :
+ msg := ds ;
+ order task name := name (order task);
+ order task station := station (order task);
+ IF phase = 1
+ THEN ask for erase
+ ELSE erase entry from order task
+ FI;
+
+ . ask for erase :
+ to first que entry;
+ WHILE next que entry found
+ REP IF is entry from order task (msg. name)
+ THEN manager question ("""" + msg.name + """ loeschen");
+ LEAVE erase que entry
+ FI;
+ PER ;
+ manager message ("""" + msg.name + """ existiert nicht");
+
+ . erase entry from order task :
+ IF is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ ELSE to first que entry;
+ WHILE next que entry found
+ REP IF is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ FI ;
+ PER ;
+ manager message ("""" + msg.name + """ existiert nicht");
+ FI;
+
+ . delete que entry :
+ erase entry (list index) ;
+ send ack;
+
+.
+ send owners ds names:
+ order task name := name (order task);
+ order task station := station (order task);
+ forget (ds); ds := nilspace; all msg := ds;
+ all msg := empty thesaurus;
+ to first que entry;
+ WHILE next que entry found
+ REP IF is entry from order task ("")
+ THEN insert (all msg, list entry. ds params. name)
+ FI;
+ PER;
+ send (order task, ack, ds)
+
+.
+ send spool list :
+ list spool;
+ send (order task, ack, ds);
+
+.
+ send next entry line :
+ control msg := ds;
+ get next entry line (control msg. entry line, control msg. index);
+ send (order task, ack, ds);
+
+.
+ kill entry :
+ control msg := ds;
+ list index := control msg. index;
+ IF is valid que entry (list index)
+ THEN erase entry (list index)
+ FI;
+ send (order task, ack, ds);
+
+.
+ make to first :
+ control msg := ds;
+ list index := control msg. index;
+ IF is valid que entry (list index)
+ THEN new first (list entry);
+ erase entry (list index);
+ FI;
+ send (order task, ack, ds);
+
+.
+ start server :
+ IF exists (server) THEN errorstop ("Spool muß zuerst gestoppt werden") FI;
+ start (PROC server start);
+ IF server channel <= 0 OR server channel >= 33
+ THEN manager message ("WARNUNG : Serverkanal nicht eingestellt");
+ ELSE send ack
+ FI;
+
+.
+ stop server:
+ IF phase = 1
+ THEN stop;
+ IF valid fetch entry
+ THEN valid fetch entry := FALSE;
+ manager question (""13""10"" +
+ fetch entry. entry line + " neu eintragen");
+ ELSE erase fetch entry;
+ send ack;
+ FI;
+ ELSE IF fetch entry. entry line <> "" THEN new first (fetch entry) FI;
+ erase fetch entry;
+ send ack;
+ FI;
+
+.
+ halt server :
+ stop command pending := TRUE;
+ IF NOT exists (server) OR server is waiting
+ THEN stop;
+ erase fetch entry;
+ FI;
+ send ack;
+
+.
+ wait for halt :
+ IF exists (calling parent)
+ THEN errorstop ("Task """ + name (calling parent) + """ wartet schon auf halt")
+ ELSE calling parent := order task;
+ stop command pending := TRUE;
+ forget (ds);
+ IF NOT exists (server) OR server is waiting
+ THEN stop;
+ erase fetch entry;
+ FI;
+ FI;
+
+END PROC spool;
+
+
+PROC send first entry :
+
+ forget (ds); ds := first entry. space;
+ send (server, ack, ds, reply) ;
+ IF reply = ack
+ THEN server is waiting := FALSE;
+ start time := time of day;
+ start time CAT " am ";
+ start time CAT date;
+ erase fetch entry;
+ fetch entry := first entry;
+ erase entry (first);
+ valid fetch entry := TRUE;
+ ELSE forget (ds);
+ FI;
+
+END PROC send first entry;
+
+
+PROC into que :
+
+ IF que is full
+ THEN errorstop ("Spool ist voll")
+ ELSE make new entry;
+ send ack;
+ awake server if necessary
+ FI;
+
+ . make new entry :
+ IF order = save code
+ THEN last entry. ds params := save params;
+ save params := empty params;
+ ELSE last entry. ds params := file save params;
+ file save params := empty params;
+ FI;
+ last entry. space := ds;
+ counter INCR 1;
+ build entry line;
+ last := next (last) ;
+
+ . build entry line :
+ IF LENGTH last entry. ds params. sender name > 16
+ THEN buffer := subtext (last entry. ds params. sender name, 1, 13);
+ buffer CAT "...""";
+ ELSE buffer := last entry. ds params. sender name;
+ buffer CAT """";
+ buffer := text (buffer, 17);
+ FI;
+ last entry. entry line := entry station text;
+ last entry. entry line CAT "/""";
+ last entry. entry line CAT buffer;
+ last entry. entry line CAT " : """ ;
+ last entry. entry line CAT last entry. ds params. name;
+ last entry. entry line CAT """ (" ;
+ last entry. entry line CAT text (storage (last entry. space));
+ last entry. entry line CAT " K)";
+
+ . entry station text :
+ IF last entry. ds params. station = 0
+ THEN " "
+ ELSE text (last entry. ds params. station, 3)
+ FI
+
+ . awake server if necessary :
+ IF server is waiting THEN send first entry FI;
+
+END PROC into que;
+
+
+PROC list spool :
+
+ forget (ds); ds := nilspace;
+ file := sequential file (output, ds) ;
+ max line length (file, 1000);
+ headline(file, station text + "/""" + name (myself) + """");
+ put spool duty;
+ put current job;
+ put spool que;
+
+ . station text :
+ IF station(myself) = 0
+ THEN ""
+ ELSE text (station(myself))
+ FI
+
+ . put spool duty :
+ IF spool duty <> ""
+ THEN write (file, "Aufgabe: ");
+ write (file, spool duty );
+ line (file, 2);
+ FI;
+
+ . put current job :
+ IF valid fetch entry AND exists (server)
+ THEN write (file, "In Bearbeitung seit ");
+ write (file, start time);
+ write (file, ":");
+ line (file, 2);
+ putline (file, fetch entry. entry line);
+ IF stop command pending
+ THEN putline (file, "Spool wird nach diesem Auftrag deaktiviert");
+ FI;
+ line (file);
+ ELSE write (file, "kein Auftrag in Bearbeitung");
+ IF NOT exists (server)
+ THEN write (file, ", da Spool deaktiviert");
+ ELIF que is empty
+ THEN write (file, ", da Warteschlange leer");
+ LEAVE list spool;
+ FI;
+ line (file, 2);
+ FI;
+
+ . put spool que :
+ IF que is empty
+ THEN putline (file, "Warteschlange ist leer");
+ ELSE write (file, "Warteschlange (");
+ write (file, text (counter));
+ write (file, " Auftraege):");
+ line (file, 2);
+ to first que entry ;
+ WHILE next que entry found
+ REP putline (file, list entry. entry line) PER;
+ FI;
+
+END PROC list spool ;
+
+
+PROC clear spool :
+
+ first := 1;
+ last := 1;
+ counter := 0;
+ FOR list index FROM 1 UPTO que size
+ REP list entry. ds params := empty params;
+ list entry. entry line := "";
+ forget (list entry. space)
+ PER;
+
+END PROC clear spool;
+
+(*********************************************************************)
+(* Hilfsprozeduren zum Spoolmanager *)
+
+BOOL PROC is valid que entry (INT CONST index) :
+
+ que (index). entry line <> ""
+
+END PROC is valid que entry;
+
+
+INT PROC next (INT CONST index) :
+
+ IF index < que size
+ THEN index + 1
+ ELSE 1
+ FI
+
+END PROC next;
+
+
+PROC to first que entry :
+
+ list index := first - 1;
+
+ENDPROC to first que entry ;
+
+
+BOOL PROC next que entry found :
+
+ list index := next (list index);
+ WHILE is not last que entry
+ REP IF is valid que entry (list index)
+ THEN LEAVE next que entry found WITH TRUE FI;
+ list index := next (list index);
+ PER;
+ FALSE
+
+ . is not last que entry :
+ list index <> last
+
+ENDPROC next que entry found ;
+
+
+PROC get next entry line (TEXT VAR entry line, INT VAR index) :
+
+ IF index = 0
+ THEN list index := first - 1
+ ELSE list index := index
+ FI;
+ IF next que entry found
+ THEN entry line := list entry. entry line;
+ index := list index;
+ ELSE entry line := "";
+ index := 0;
+ FI;
+
+END PROC get next entry line;
+
+
+PROC new first (ENTRY VAR new first entry) :
+
+ IF que is full
+ THEN errorstop ("Spool ist voll")
+ ELSE first DECR 1 ;
+ IF first = 0 THEN first := que size FI;
+ first entry := new first entry;
+ counter INCR 1;
+ FI;
+
+END PROC new first;
+
+
+PROC erase entry (INT CONST index) :
+
+ entry. ds params := empty params;
+ entry. entry line := "";
+ forget (entry.space) ;
+ counter DECR 1;
+ IF index = first
+ THEN inc first
+ FI ;
+
+ . entry : que (index)
+
+ . inc first :
+ REP first := next (first)
+ UNTIL que is empty OR is valid que entry (first) PER
+
+END PROC erase entry;
+
+
+PROC erase fetch entry :
+
+ fetch entry. ds params := empty params;
+ fetch entry. entry line := "";
+ forget (fetch entry. space);
+ valid fetch entry := FALSE;
+
+END PROC erase fetch entry;
+
+
+BOOL PROC is entry from order task (TEXT CONST file name) :
+
+ correct order task CAND correct filename
+
+ . correct order task :
+ order task name = list entry. ds params. sendername
+ AND order task station = list entry. ds params. station
+
+ . correct file name :
+ file name = "" OR file name = list entry. ds params. name
+
+END PROC is entry from order task;
+
+
+PROC start (PROC server start):
+
+ begin (PROC server start, server);
+
+END PROC start;
+
+
+PROC stop :
+
+ stop server;
+ send calling parent reply if necessary;
+
+ . stop server:
+ IF exists (server) THEN end (server) FI;
+ server := niltask;
+ server is waiting := FALSE;
+ stop command pending := FALSE;
+
+ . send calling parent reply if necessary :
+ IF exists (calling parent)
+ THEN forget (ds); ds := nilspace;
+ send (calling parent, ack, ds);
+ calling parent := niltask;
+ FI;
+
+END PROC stop;
+
+
+PROC next headline information (TEXT VAR t):
+
+ begin pos := pos (headline (file), begin char, end pos + 1);
+ IF begin pos = 0
+ THEN begin pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE end pos := pos (headline (file), end char, begin pos + 1);
+ IF end pos = 0
+ THEN end pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE t := subtext (headline (file), begin pos+1, end pos-1)
+ FI
+ FI
+
+END PROC next headline information;
+
+
+PROC send ack :
+
+ forget (ds); ds := nilspace;
+ send (order task, ack, ds)
+
+END PROC send ack;
+
+
+PROC manager question (TEXT CONST question) :
+
+ forget (ds); ds := nilspace; error msg := ds ;
+ error msg := question ;
+ send (order task, question ack, ds)
+
+ENDPROC manager question ;
+
+
+PROC manager message (TEXT CONST message) :
+
+ forget (ds); ds := nilspace; error msg := ds ;
+ error msg := message ;
+ send (order task, message ack, ds)
+
+ENDPROC manager message ;
+
+(*********************************************************************)
+(* Spool - Kommandos *)
+
+INT VAR command index , params ;
+TEXT VAR command line, param 1, param 2 ;
+
+LET spool command list =
+"break:1.0start:2.01stop:4.0halt:5.0first:6.0killer:7.0listspool:8.0
+clearspool:9.0spoolcontrolby:10.1";
+
+PROC spool command (PROC server start) :
+
+ enable stop ;
+ continue (order - continue code) ;
+ disable stop ;
+ REP command dialogue (TRUE) ;
+ get command ("gib Spool-Kommando:", command line);
+ analyze command (spool command list, command line, 3, command index,
+ params, param1, param2);
+ execute command (PROC server start);
+ UNTIL NOT online PER;
+ command dialogue (FALSE);
+ break (quiet);
+ set autonom;
+
+END PROC spool command;
+
+
+PROC execute command (PROC server start) :
+
+ enable stop;
+ SELECT command index OF
+ CASE 1 : break
+ CASE 2 : start server
+ CASE 3 : start server with new channel
+ CASE 4 : stop server
+ CASE 5 : halt server
+ CASE 6 : first cmd
+ CASE 7 : killer cmd
+ CASE 8 : show spool list
+ CASE 9 : clear spool
+ CASE 10 : spool control task (task (param1))
+ OTHERWISE do (command line)
+ END SELECT;
+
+ . start server :
+ IF server channel <= 0 OR server channel >= 33
+ THEN line;
+ putline ("WARNUNG : Serverkanal nicht eingestellt");
+ FI;
+ stop server;
+ start (PROC server start);
+
+ . start server with new channel:
+ INT VAR i := int (param1);
+ IF last conversion ok
+ THEN server channel (i);
+ start server;
+ ELSE errorstop ("falsche Kanalangabe")
+ FI;
+
+ . stop server :
+ disable stop;
+ stop;
+ IF valid fetch entry CAND
+ yes (""13""10"" + fetch entry. entry line + " neu eintragen")
+ THEN new first (fetch entry) FI;
+ erase fetch entry;
+ enable stop;
+
+ . halt server :
+ stop command pending := TRUE;
+ IF NOT exists (server) OR server is waiting
+ THEN stop server;
+ erase fetch entry;
+ FI;
+
+ . first cmd :
+ line ;
+ to first que entry ;
+ WHILE next que entry found
+ REP say (list entry. entry line) ;
+ IF yes (" als erstes")
+ THEN new first (list entry);
+ erase entry (list index);
+ LEAVE first cmd
+ FI ;
+ PER;
+
+ . killer cmd :
+ line ;
+ to first que entry ;
+ WHILE next que entry found
+ REP say (list entry. entry line) ;
+ IF yes (" loeschen") THEN erase entry (list index) FI ;
+ PER;
+
+ . show spool list :
+ list spool;
+ disable stop;
+ show (file);
+ forget (ds);
+
+ENDPROC execute command ;
+
+ENDPACKET spool manager;
+
diff --git a/system/net/unknown/doc/EUMEL Netz b/system/net/unknown/doc/EUMEL Netz
new file mode 100644
index 0000000..941e2ea
--- /dev/null
+++ b/system/net/unknown/doc/EUMEL Netz
@@ -0,0 +1,829 @@
+#type ("trium8")##limit (11.0)#
+#start(2.5,1.5)##pagelength (17.4)#
+#block#
+#headeven#
+
+% EUMEL-Netzbeschreibung
+
+
+#end#
+#headodd#
+
+#center#Inhalt#right#%
+
+
+#end#
+
+#type ("triumb12")#
+1. Einleitung
+
+
+Teil 1: Netz einrichten und benutzen
+#type ("trium8")#
+
+1. Benutzung des Netzes
+
+2. Hardwarevoraussetzungen
+
+3. Einrichten des Netzes
+
+4. Informationsmöglichkeiten
+
+5. Eingriffsmöglichkeiten
+
+6. Fehlerbehebung im Netz
+
+#type ("triumb12")#
+
+Teil 2: Arbeitsweise der Netzsoftware
+#type ("trium8")#
+
+1. Die Netztask
+
+2. Protokollebenen
+
+3. Stand der Netzsoftware
+
+#page#
+#headodd#
+
+#center#Einleitung#right#%
+
+
+#end#
+
+#type("triumb12")#
+1. Einleitung #type("trium8")#
+
+
+Das EUMEL-Netz dient dazu mehrere EUMEL-Rechner (sog. Stationen) mit­
+einander zu koppeln. Diese Kopplung wird von Betriebsystem dazu benutzt, das
+Sendungskonzept (siehe Systemhandbuch 1.7, Intertaskkommunikation) so auszu­
+dehnen, daß Tasks verschiedener Stationen einander Datenräume zusenden
+können. Auf dem Sendungskonzept aufbauende Konzepte nutzen daher automa­
+tisch das Netz aus: So ist es z.B. möglich
+
+- von einer Station aus auf einer anderen zu Drucken,
+
+- in PUBLIC einer anderen Station Dateien zu sichern (save), vorausgesetzt, daß
+ PUBLIC dort ein free global manager ist,
+
+- auf einer anderen Station zu archivieren (z.B. wenn das eigene Archivlaufwerk
+ defekt ist oder ein anderes Format hat).
+
+Das Netz kann ab EUMEL-Version 1.7.3 eingesetzt werden.
+
+
+#type("triumb12")#
+Teil 1: Netz einrichten und benutzen
+
+1. Benutzung des Netzes #type("trium8")#
+#headodd#
+
+#center#Teil 1: Netz einrichten und benutzen#right#%
+
+
+#end#
+
+ Zur Benutzung des Netzes stehen folgende Operatoren und Prozeduren zur
+ Verfügung:
+
+
+1.1
+
+ TASK OP / (INT CONST station, TEXT CONST taskname)
+
+ liefert die Task #on("bold")#taskname#off("bold")# von der Station #on("bold")#station#off("bold")#.
+
+ Wenn die Station #on("bold")#station#off("bold")# nicht am Netz ist oder nicht eingeschaltet ist, wird
+ solange gewartet, bis das der Fall ist.
+
+ Fehlerfälle:
+
+ - task "..." gibt es nicht
+
+ Die angeforderte Task gibt es in der Zielstation nicht.
+
+ - Collectortask fehlt
+
+ Das Kommando #on("bold")#define collector#off("bold")# wurde nicht gegeben (siehe 4.2).
+
+ - Station x antwortet nicht
+
+ Eine nicht vorhandene oder abgeschaltete Station wurde angesprochen.
+ Hinweis: Dieser Fehler wird angenommen, wenn eine Überwachungszeit
+ von ca. 30 Sekunden verschrichen ist, ohne daß Station x die
+ Taskidentifikation angeliefert hat.
+
+ Beispiel:
+
+ list (5/"PUBLIC")
+
+ Dateiliste von PUBLIC auf Station 5 wird angefordert.
+
+1.2
+
+ TASK OP / (INT CONST station, TASK CONST task)
+
+ liefert
+
+ station / name (task) .
+
+
+ Beispiel:
+
+ list (4/archive)
+
+
+1.3
+
+ INT PROC station (TASK CONST task)
+
+ liefert die Stationsnummer der Task #on("bold")#task#off("bold")#.
+
+ Beispiel:
+
+ put (station (myself))
+
+ gibt die eigene Stationsnummer aus.
+
+
+1.4
+
+ PROC archive (TEXT CONST archivename, INT CONST station)
+
+ dient dazu das Archiv auf der Station #on("bold")#station#off("bold")# anzumelden.
+
+ Beispiel:
+
+ archive ("std", 4); list (4/archive)
+
+ gibt das Inhaltsverzeichnis der Archivfloppy im Laufwerk der Station 4 aus.
+ Hinweis: Vergessen Sie bei solchen Querarchivierungen nicht die Stations­
+ angabe bei jedem einzelnen Archivkommando (z.B fetch ("xxx", #on("bold")#4/#off("bold")#
+ archive).
+ Hinweis: Querarchivieren ist langsam. Verwenden Sie es nur, wenn Sie Flop­
+ pyformate umsetzen wollen.
+
+
+1.5
+
+ PROC free global manager
+
+ dient dazu, die eigene Task über das Netz ansprechbar zu machen. Jede
+ andere Task im Netz kann dann die üblichen Manageraufrufe ('save', 'fetch',
+ u.s.w.) an die eigene Task machen, sofern diese nicht an ein Terminal gekop­
+ pelt ist.
+
+ Die Task wird (wie bei 'break') abgekoppelt und meldet sich in Zukunft mit
+ 'maintenance' statt mit 'gib kommando'.
+
+ Beispiel:
+
+ An Station 4 ruft man in der Task 'hugo' das Kommando #on("bold")#free global manager#off("bold")#
+ auf. Anschließend kann man von jeder Station aus z.B. 'list (4/"hugo")' u.s.w.
+ machen.
+
+
+1.6
+
+ TEXT PROC name (TASK CONST t)
+
+ Diese (schon immer vorhandene) Prozedur wurde dahingehend erweitert, daß der
+ Name einer Task einer anderen Station über Netz angefordert wird.
+
+ Fehlerfall:
+
+ Station x antwortet nicht
+
+
+
+
+#type("triumb12")#2. Hardwarevoraussetzungen#type("trium8")#
+
+2.1 Zwei Stationen
+
+ Sie können zwei Stationen miteinander Vernetzen, wenn Sie dafür an jeder
+ Station eine V24-Schnittstelle zur Verfügung stellen.
+
+ Diese beiden Schnittstellen verbinden Sie mit einem Kabel zur Rechner­
+ kopplung (siehe Systemhandbuch 1.7 Teil 2).
+
+2.2 Mehrere Stationen
+
+ Wenn Sie mehr als zwei Stationen vernetzen wollen, brauchen neben je
+ einer V24 an jeder Station noch je eine Netzanschlußbox.
+
+ Jede Box besitzt eine V24-Schnittstelle zum Anschluß an die V24-
+ Schnittstelle der zugeorneten Station und eine weitere Schnittstelle zur
+ Verbindung der Boxen untereinander.
+
+
+#type("triumb12")#3. Einrichten des Netzes #type("trium8")#
+
+Hinweis: Dieses Kapitel ist nur für Systembetreuer wichtig.
+
+3.1 Legen Sie Stationsnummern für die am Netz beteiligten Rechner fest (von 1 an
+ aufsteigend).
+
+ Die Boxen haben ebenfalls Stationsnummern. Die Stationsnummern der Box
+ und des zugeordneten Rechners müssen übereinstimmen.
+
+
+3.2 Holen Sie an jeder Station die Task #on("bold")#configurator#off("bold")# an ein Terminal und geben Sie
+ das Kommando #on("bold")#define collector ("net port")#off("bold")#. Geben Sie außerdem das
+ Kommando #on("bold")#define station (x)#off("bold")#, wobei #on("bold")#x#off("bold")# die gewählte Stationsnummer ist.
+
+ Hinweis: Taskkommunikationen, die zu dem Zeitpunkt laufen, führen zu feh­
+ lerhaften Verhalten. Dies liegt daran, daß durch #on("bold")#define station#off("bold")# alle
+ Task-Id's geändert werden müssen, weil eine Task-Id u.a. die
+ Stationsnummer der eigenen Station enthält (siehe 2.3). TASK-
+ Variable, die noch Task-Id's mit keiner oder falscher Stationsnum­
+ mer enthalten, können nicht mehr zum Ansprechen einer Task
+ verwendet werden.
+
+ Beispiel: Der Spoolmanager (siehe Benutzerhandbuch 1.7 Teil 12) richtet
+ beim Kommando #on("bold")#start#off("bold")# einen Worker ein und merkt sich dessen
+ Task-Id in einer TASK-Variablen, um sicherzustellen, daß nur der
+ Worker Dateien zum Drucken abholt. Wird jetzt das Kommando #on("bold")#
+ define station#off("bold")# gegeben, kann der Spoolmanager seinen Worker
+ nicht mehr identifizieren, weil der Worker eine neue Task-Id er­
+ halten hat. Man muß daher den Worker löschen und mit dem
+ Kommando #on("bold")#start#off("bold")# im Spoolmanager wieder neu einrichten.
+
+
+ Sinnvollerweise gibt man #on("bold")#define station#off("bold")# sofort nach den Laden eines
+ frischen Systems von Archiv.
+
+ Konfigurieren Sie mit dem Kommando #on("bold")#configurate#off("bold")# den für das Netz vorgese­
+ henen Kanal auf
+
+ - transparent
+ - 9600 Baud (Standardeinstellung der Boxen)
+ - RTS/CTS-Protokoll
+ - großen Puffer
+ - 8 bit
+ - even parity
+ - 1 stopbit.
+
+ Falls diese Einstellungen nicht alle angeboten werden, klären Sie mit Ihrem
+ Rechnerlieferanten, ob und wie diese Einstellungen erreicht werden können.
+ Hinweis: Notfalls kann auf das RTS/CTS-Protokoll verzichtet werden, wenn
+ der Eingabepuffer der Station groß genug ist. Die Anzahl simultan
+ laufender Netzkommunikationen ist dann auf
+
+ puffergröße DIV 150
+
+ begrenzt (bei Z80, 8086: 3; bei M20: 10).
+ Hinweis: Es können auch andere Baudraten (2400, 4800, 19200) an der Box
+ eingestellt werden.
+
+3.3 Achten Sie bei der Verbindung von der Station zur Netzbox (bzw. zur Gegen­
+ station bei einem Zweistationennetz ohne Boxen) darauf, daß neben den
+ Empfangs- und Sendeleitungen auch die Leitungen RTS und CTS verdrahtet
+ werden, also ein 5 poliges Kabel verwendet wird (siehe Systemhandbuch 1.7
+ Teil 2). Die Pin-Belegung der Boxen entspricht den dortigen Angaben.
+
+ Beispiel:
+
+ Verbindung eines CSK-Systems mit der Box:
+
+ Stecker Stecker
+ Pin Pin
+
+ 2 <---------> 3
+ 3 <---------> 2
+ 4 <---------> 5
+ 5 <---------> 4
+ 7 <---------> 7
+
+
+3.4 Richten Sie eine Task #on("bold")#net#off("bold")# unter #on("bold")#SYSUR#off("bold")# ein und insertieren Sie dort die Datei­
+en
+
+ net report/M
+ basic net
+ net manager/M.
+
+ Beantworten Sie die Frage nach dem Kanal für das Netz und nach der Fluß­
+ kontrolle (RTS/CTS).
+
+
+#type("triumb12")#4. Informationsmöglichkeiten #type("trium8")#
+
+ In der Task #on("bold")#net#off("bold")# wird eine Datei #on("bold")#report#off("bold")# geführt in der Fehlersituationen des
+ Netzes verzeichnet werden. Diese Datei kann in jeder anderen Task mit #on("bold")#list
+ (/"net")#off("bold")# angezeigt werden.
+
+ In jeder Task kann durch das Kommando #on("bold")#list (/"net port")#off("bold")# eine Übersicht über
+ die momentan laufenden Netzübertragungen der eigenen Station erhalten
+ werden.
+
+
+#type("triumb12")#5. Eingriffsmöglichkeiten #type("trium8")#
+#headodd#
+
+#center#Eingriffsmöglichkeiten#right#%
+
+
+#end#
+
+5.1 Jede Task kann Sende- und Empfangsströme, die bei #on("bold")#list (/"net port")#off("bold")# gemel­
+ det worden sind und die eigene Task betreffen, abbrechen. Hierzu ist das
+ Kommando #on("bold")#erase ("x",/"net port")#off ("bold")# zu geben, wobei x die Stromnummer (aus
+ dem 'list') ist.
+
+ Unberechtigte Löschversuche werden abgewiesen.
+
+ Von der Task 'net' aus können jedoch damit beliebige Ströme abgebrochen
+ werden.
+
+5.2 Durch das Kommando #on("bold")#start#off("bold")# kann von der Task 'net' aus das Netz neu gestartet
+ werden. Dabei werden alle augenblicklichen Netzkommunikationen gelöscht.
+ Die Tasks 'net port' und 'net timer' werden dabei gelöscht und neu eingerich­
+ tet.
+
+ #on("bold")#start (kanal, quit)#off("bold")# wirkt wie #on("bold")#start#off("bold")#. Zustzlich wird als Netzkanal 'kanal' eingestellt
+ und maximal 'quit' Empfangsströme zugelassen. 'quit' ist auf 3 zu setzen,
+ wenn der Kanal ohne RTS/CTS angeschlossen ist (siehe 3.2).
+
+
+#type("triumb12")#6. Fehlersuche im Netz #type("trium8")#
+
+ Fehler im Netz können sich verschiedenartig auswirken. Im Folgenden wird auf
+ einige Beispiele eingegangen:
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Station 4 antwortet nicht'.
+
+ Fehlermöglichkeiten:
+
+ - Station 4 gibt es nicht am Netz.
+ Abhilfe: Richtige Station angeben.
+
+ - Station 4 ist nicht eingeschaltet.
+ Abhilfe: Station 4 einschalten. Kommando erneut geben.
+
+ - Netztask an Station 4 ist nicht arbeitsfähig.
+ Abhilfe: Kommando 'start' in der Task 'net'.
+
+ - Stationsnummern und Boxnummern stimmen nicht überein.
+ Abhilfe: Mit 'define station' Stationsnummern korrigieren (siehe 3.2).
+
+ - Verbindung Rechner/Box am eigenen Rechner oder an Station 4 fehlt.
+ Abhilfe: Verbindungen überprüfen. Durch Ansprechen einer dritten Station
+ kann oft schnell geklärt werden, welche Rechner/Box-Verbindung
+ defekt sein muß.
+
+ - Verbindung der Boxen untereinander defekt.
+ Abhilfe: Fehlende Verbindung, Masseschluß und Dreher (keine 1:1 Ver­
+ bindung) überprüfen und beheben.
+ Hinweis: Liegt z.B. ein Masseschluß vor, so kann es durchaus sein, daß
+ Boxen, die nicht in der Nähe des Masseschluß stehen noch mitei­
+ nander arbeiten können. Man kann aus der Tatsache, daß zwei
+ Boxen miteinander arbeiten können, also nicht schließen, daß man
+ nicht nach diesem Fehler suchen muß.
+
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt keine Reaktion.
+
+
+ - Station 4 ist während dieser Sendung zusammengebrochen.
+ Abhilfe: Station 4 wieder starten. Die Bearbeitung des 'list'-Kommandos
+ wird automatisch wieder aufgenommen.
+
+ - PUBLIC auf Station 4 ist nicht im Managerzustand.
+ Abhilfe: PUBLIC in den Managerzustand versetzen.
+
+
+ Hinweis: Das Netz hat nocht nicht die volle Sendungslogik des EUMEL. So
+ wird nur ca. 10 Minuten lang versucht, eine Sendung zuzustellen.
+ Danach wird die Sendung gelöscht. Ist dies eingetreten, so muß
+ das list-Kommando erneut gegeben werden.
+
+ - Fehler in der Netzhardware.
+ Überprüfen Sie, ob
+
+ - die Boxen eingeschaltet sind,
+ - die Bereitlampe blinkt (wenn nicht: RESET an der Box)
+ - die V24-Kabel richtig stecken,
+ - die Boxen untereinander verbunden sind (1 zu 1 Verbindungen der 5
+ poligen Diodenbuchsen).
+
+
+ - Die Netzsoftware ist auf einen nicht vorhergesehenen Fehler gelaufen.
+ Dieser wird im Report vermerkt.
+ Abhilfe: Geben Sie in der Task #on("bold")#net#off("bold")# das Kommando #on("bold")#start#off("bold")#. Dadurch wird die
+ Netzsoftware neu gestartet. Alle Netzkommunikationen dieser
+ Station gehen verloren.
+
+
+ Beispiel:
+
+ Auf #on("bold")#list (4/public)#off("bold")# erfolgt die Meldung 'Collectortask fehlt'.
+
+ - In der Task 'configurator' wurde das Kommando 'define collector' (siehe 3.2)
+ nicht gegeben.
+
+ - Die Task 'net port' existiert nicht mehr.
+ Abhilfe: Kommando 'start' in der Task 'net'.
+
+
+ Beispiel:
+
+ Nach #on("bold")#fetch ("hugo",4/public)#off("bold")# sind Teile von der Datei "hugo" verfälscht.
+
+ - Die V24-Verbindung zur Box ist nicht in Ordnung.
+ Abhilfe: Abstand zwischen Rechner und Box verkürzen; Baudrate ernie­
+ drigen; Durch Wechseln der V24-Schnittstelle feststellen, ob
+ diese defekt ist.
+ Hinweis: Die Verbindung zwischen den Boxen ist durch Prüfsummen abge­
+ sichert (Hardware).
+
+#headodd#
+
+#center#Teil 2: Arbeitsweise der Netzsoftware#right#%
+
+
+#end#
+#page#
+#type("triumb12")#
+
+Teil 2: Arbeitsweise der Netzsoftware
+
+
+1. Die Netztask #type ("trium8")#
+
+In diesem Kapitel wird beschrieben, wie eine Netztask in das System
+eingebettet ist und welche Aufgaben sie hat. Unter Einhaltung dieser
+Konzepte kann die ausgelieferte Netztask so geändert werden, daß sie
+beliebige andere Netzhardware unterstützt. Z.Zt. ist die Netzsoftware noch
+nicht so gegliedert, daß nur eine hardwareabhängige Komponente ausgetauscht
+werden muß.
+
+Die Kommunikation zwischen Tasks im EUMEL-Betriebssystem basiert auf einem
+Rendevouskonzept: Die Zieltask einer Sendung muß empfangsbereit sein, wenn die
+Quelltask sendet.
+
+Die Kommunikationsprozeduren auf der niedrigsten Ebene sind 'send' (Senden)
+und 'wait' (Warten auf Empfang). Bei der Kommunikation werden eine Integer
+'code' und ein Datenraum 'dr' übergeben. 'code' muß >= 0 sein, da negative
+Codes systemintern verwandt werden. Ist die empfangende Task an einen Kanal
+gekoppelt ('continue'), so führt eine Zeicheneingabe auf diesem Kanal dazu,
+daß eine
+Sendung mit dem Code -4 ankommt. Die Eingabedaten müssen mit den üblichen
+Eingabeprozeduren ('inchar' u.s.w.) abgeholt werden. Der übermittelte Datenraum
+und die Absendertask sind dabei ohne Bedeutung und dürfen nicht interpretiert
+werden.
+
+Die Prozedur 'send' hat einen Rückmeldeparameter, der besagt, ob die Sendung
+übermittelt wurde. Gibt es die Zieltask nicht oder steht sie nicht im 'wait', so kann
+die Sendung nicht übermittelt werden.
+
+
+Ein Entwicklungskriterium für das EUMEL-Netz war es, möglichst wenig Unter­
+stützung von der virtuellen EUMEL-Maschine (EUMEL0) zu fordern, damit weit­
+gehend in ELAN programmiert werden kann. Dadurch ist es möglich eine (privili­
+gierte) Task mit der Netzabwicklung zu betrauen.
+
+Zunächst wird auf die EUMEL0-Unterstützung eingegangen:
+
+1.1. Es gibt die Prozedur 'define collector', mit der die für das Netz verantwort­
+ liche Task der EUMEL0-Maschine bekannt gemacht wird. Diese Task wird im
+ folgenden Collector genannt.
+
+1.2. Es gibt die Prozedur 'define station', die für den Rechner eine Stationsnum­
+ mer einstellt. Anhand dieser Nummer werden die Rechner eines Netzes un­
+ terschieden. Das Einstellen bewirkt, daß für alle Tasks die Stationsnummer in
+ ihre Task-Id eingetragen wird (Task-Id's sind die Werte, die der Typ TASK
+ annehmen kann).
+
+1.3. Der Befehl 'station (task)' liefert die Stationsnummer der 'task'. So liefert z.B.
+ 'station (myself)' die Stationsnummer des eigenen Rechners.
+
+1.4. Eine Sendung, deren Zieltask in einem anderen Rechner liegt (also station
+ (ziel) <> station (myself)), wird auf die Collectortask geleitet.
+
+1.5. Es gibt eine Prozedur 'collected destination', die es dem Collector erlaubt, die
+ eigentliche Zieltask einer auf ihn geleiteten Sendung zu erfahren.
+
+1.6. Es gibt eine Variante der Prozedur 'send', die es dem Collector gestattet, der
+ Zieltask eine beliebige andere Task als Absender vorzumachen.
+
+1.7. Es gibt eine spezielle Task-Id 'collector', durch die der augenblicklich ein­
+ gestellte Collector erreicht wird. Diese wird als Zieltask beim Aufruf der Ver­
+ mittlungsdienste angegeben (siehe 2.5). Eine Sendung an 'collector' wird von
+ EUMEL0 an den derzeitigen Collector geschickt.
+
+Ein Collector kann also auf drei Wegen von den übrigen Tasks desselben Rechners
+Sendungen erhalten:
+
+ 1. Über ein normales Send (z.B. bei 'list (/"net port")', wenn "net port" der der­
+ zeitige Collector ist),
+
+ 2. über ein Send an die Task 'collector' (s.u.) und
+
+ 3. als umgeleitete Sendung (z.B. bei 'list' an eine Task auf einem anderen
+ Rechner).
+
+Der Collector kann diese Fälle anhand von 'collected destination' unterscheiden.
+
+Die Punkte 1.4...1.6 dienen dazu, den Collector für über Netz kommunizierende
+Task unsichtbar zu machen: Der Collector taucht nicht als Ziel oder Quelle von
+Sendungen auf. Das ist notwendig, damit normale Tasks sich nicht darum kümmern
+müssen, ob eine Sendung übers Netz geht oder im eigenen Rechner bleibt.
+
+Wenn ein Datenraum an einen anderen Rechner geschickt wird, muß der gesamte
+Inhalt (z. Zt. max. 1 MB) übertragen werden. Dies macht bei der üblichen Netz­
+hardware eine Zerlegung in Packete nötig (siehe Systemhandbuch 173, Teil 4,
+Punkt 5). Für Netze über V24-Kanäle stehen spezielle Blockbefehle zur verfü­
+gung:
+
+1.8. blockin / blockout (dr,seite,512+abstand,anzahl,rest)
+
+ Es werden maximal 'anzahl' Bytes transferiert. In 'rest' wird zurückgemeldet,
+ wieviel Bytes nicht bearbeitet wurden (z.B. weil der Kanal nichts anliefert).
+ Bearbeitet werden die Bytes
+
+ 'seite' * 512 + 'abstand'
+
+ bis maximal
+
+ 'seite' * 512 + 'abstand' + 'anzahl' - 1
+
+ Der Kanal, an den die Task gekoppelt ist, wird dabei über Stream-IO (d.h.
+ 'incharety' bei 'blockin' bzw. 'out' bei 'blockout') angesprochen.
+
+ Hinweis: Die Anforderung darf nicht über Seitengrenze gehen, d.h.
+
+ 'abstand' + 'anzahl' <= 512
+
+ muß erfüllt sein.
+
+
+Eine Netzsendung läuft wie folgt ab:
+
+Die Task q auf Rechner rq mache ein 'send' an die Task z auf Rechner rz.
+
+1. Die Prozedur send ist ein EUMEL0-Befehl. Die EUMEL0-Ebene erkennt, daß
+ die Sendung an die Station rz geht, da die Stationsnummer in der Task-Id
+ enthalten ist. Daher wird die Sendung zum Collector, den EUMEL0 wegen 'de­
+ fine collector' kennt, umgeleitet.
+
+2. Die Task Collector empfängt über 'wait' den Datenraum, den Sendecode und
+ die Absendertask q. Die Zieltask z erfährt sie durch 'collected destination'.
+
+3. Der Collector nimmt Kontakt mit dem Collector des Rechner rz, dessen Sta­
+ tionsnummer ja 'station(z)' ist, auf und Übermittelt diesem Sendecode, Quelltask
+ (q), eigentliche Zieltask (z) und den Datenraum. Da die Collectoren in ELAN
+ geschrieben sind, können sie an beliebige Netzhardware und Protokolle ange­
+ paßt werden.
+
+4. Der Collector auf Rechner rz verwendet das spezielle 'send', um der Zieltask die
+ Sendung zuzustellen. Dadurch erscheint nicht der Collector sondern die Task q
+ als Absender der Sendung.
+
+Zur Abwicklung der Vermittlungsebene (Teil 1: 2.4) muß der Collector noch
+spezielle Funktionen beherrschen. Diese sind
+
+ der /-Operator (Taskname in Task-Id wandeln) und
+ die name-Prozedur (Task-Id in Namen wandeln).
+
+Der /-Operator macht eine Sendung an den 'collector', wobei im Datenraum der
+Name der Task steht und der Sendecode gleich der Stationsnummer ist (siehe
+Quellcode 173, Packet tasks). Der Collector setzt sich mit dem Collector dieser Sta­
+tion in Verbindung, damit dieser die Task-Id ermittelt und zurückschickt. Der
+eigene Collector schickt dann dem /-Operator als Antwort einen Datenraum, der
+die Task-Id enthält.
+
+Umgekehrt läuft 'name' ab: Wenn die Task-Id von einer fremden Station ist,
+schickt 'name' eine Sendung an den 'collector', wobei im Datenraum die Task-Id
+steht und Sendecode = 256 ist. Der Collector entnimmt die Stationnummer der
+Task aus der Task-Id und läßt sich vom entsprechenden Collector den Tasknamen
+geben. Dieser wird der 'name'-Prozedur im Antwortdatenraum übergeben.
+
+#type ("triumb12")#2. Ebenen #type("trium8")#
+
+In diesem Kapitel werden die Protokollebenen für das Netz beschrieben, wie
+sie die ausgelieferte Netzsoftware benutzt und erwartet. Bei anderer
+Netzhardware müssen die Ebenen 1 bis 3 ausgetauscht werden. Unter Einhaltung
+der im vorigen Kapitel beschriebenen Randbedingungen können auch die höheren
+Ebenen geändert werden.
+
+
+2.1 Physikalische Ebene
+
+ 2.1.1 Station <--> Box
+
+ V24-Schnittstelle mit RTS/CTS-Handshake. Vollduplex.
+
+ 2.1.2 Box <--> Box
+
+ RS422 über 2 verdrillte Leitungspaare (Takt und Daten).
+
+2.2 Verbindungsebene
+
+ 2.2.1 Station <--> Box
+
+ Asynchron
+ 8 Bit
+ Even Parity
+ 2400/4800/9600/19200 Baud (einstellbar über Lötbrücken)
+
+ 2.2.2 Box <--> Box
+
+ SDLC
+ 400 KBaud
+
+2.3 Netzebene
+
+ 2.3.1 Station <--> Box
+
+ Telegrammformat: STX, <n>, <ziel>, <quelle>, <(n-4) byte>
+
+ <n> ist Längenangabe ( 8 <= n <= 160)
+ <ziel>, <quelle> sind Stationsnummern. Diese müssen an den je­
+ weiligen Boxen über Lötbrücken eingestellt sein.
+
+ Box --> Station:
+
+ Ein Telegramm kommt nur bei der Station an, bei deren Box die
+ Nummer <ziel> eingestellt ist. Dadurch ist ein Mithören fremder
+ Übertragungen nicht möglich (Datenschutz).
+
+ Zwischen Telegrammen können Fehlermeldungen der Box (Klartext)
+ übermittelt werden (z.B. 'skipped x', wenn ein STX von der Box er­
+ wartet wurde, aber 'x' von der Station ankommt).
+
+ Station --> Box:
+
+ Ein Telegramm wird nur abgeschickt, wenn <quelle> mit der einge­
+ stellten Nummer übereinstimmt (Datenschutz: Man kann nicht eine
+ beliebige Station zu sein vorschwindeln, es sei denn man hat physi­
+ schen Zugriff zur Box und stellt dort die Stationsnummer um).
+
+ 2.3.2 Box <--> Box
+
+ Telegrammformat: FRAME, <ziel>, <quelle>, <daten> ,
+ <CRC-Code>
+
+ Eine Längenangabe ist nicht nötig, da SDLC eine Rekonstruktion der
+ Länge erlaubt.
+
+ Telegramme mit falschen CRC-Code werden vernichtet. Auf höheren
+ Ebenen muß dies durch Zeitüberwachung erkannt und behandelt
+ werden.
+
+
+2.4 Transportebene
+
+ Diese Ebene wickelt das Rendevous zwischen einer Task, die 'send' macht,
+ und einer Task, die im 'wait' steht, ab (siehe: EUMEL-Systemhandbuch).
+
+ Der im 'send' angegebene Datenraum wird als Folge von Seiten (im
+ EUMEL-Sinne: Pagingeinheit und Allokiereinheit) übermittelt, wobei jede Seite
+ noch in 64 Byte große Stücke zerlegt wird. Es werden nur echt allokierte Seiten
+ übermittelt. Um nicht jedes Telegramm voll qualifizieren zu müssen, wird
+ zunächst eine Art virtuelle Verbindung durch ein OPEN-Telegramm eröffnet.
+ Danach folgen variable viele DATA-Telegramme. Beide Sorten werden durch
+ QUIT-Telegramme quittiert, um folgende Funktionen zu ermöglichen:
+
+ Flußkontrolle (z.B. Zielrechner langsam)
+ Wiederaufsetzen (verlorene Telegramme)
+ Abbruch (z.B. weil Zieltask inzwischen beendet).
+
+ Ein CLOSE-Telegramm ist nicht nötig, da das letzte DATA-Telegramm als
+ solches erkannt werden kann (siehe unten).
+
+ 2.4.1 OPEN-Telegramm
+
+ STX, 20, <ziel>, <quelle>, <strom>, <sequenz>, <seite>,
+ <quelltask>, <zieltask>, <code>
+
+ <ziel>, <quelle> siehe 2.3.1
+
+ <strom> Die Stromnummer identifiziert die virtuelle Verbindung.
+ Sie muß in den QUIT-Telegrammen angegeben wer­
+ den.
+
+ <sequenz> -1 (Kennzeichen für OPEN)
+
+ <seite> Nummer der ersten echt allokierten Seite des Datenra­
+ ums (=-1, falls Nilspace)
+
+ <quelltask> Taskid der sendenden Task
+
+ <zieltask> Taskid der empfangenden Task
+
+ <code> Wert des im 'send' angegebenen Codes.
+
+ 2.4.2 DATA-Telegramm
+
+ STX, 74, <ziel>, <quelle>, <sequenz>, <seite>, <64 byte>
+
+ <sequenz> wird von Telegramm zu Telegramm hochgezählt. Dient
+ der Überwachung gegen verlorengegangene Telegramme
+ bzw. durch Zeitüberwachung verdoppelter Telegramme.
+
+ <seite> Nummer der x.ten echt allokierten Seite des Datenra­
+ ums. (x = (<sequenz>+16) DIV 8).
+
+ <64 byte> Nutzinformation. Diese gehört zur Adresse a des Daten­
+ raums.
+
+ a = N (<sequenz> DIV 8 + 1) * 512
+ + (<sequenz> MOD 8) * 64
+
+ wobei N (x) die Nummer der x.ten Seite ist.
+
+ Aus den Formeln ergibt sich, daß diese Nummer schon in
+ einem vorhergehenden DATA/OPEN-Telegramm über­
+ mittelt wurde (im Feld <seite>).
+
+ 2.4.3 QUIT-Telegramm
+
+ STX, 8, <ziel>, <quelle>, <strom>, <quit>
+
+ <strom> muß die Stromnummer sein, die in dem OPEN/DATA-
+ Telegramm stand, das quittiert wird.
+
+ <quit> 0 : ok. Nächstes Telegramm schicken.
+
+ -1: Übertragung neu starten (mit OPEN), weil die
+ Empfangsstation das OPEN nicht erhalten hat.
+
+ -2: Übertragung ca. 20 Telegramme zurücksetzen.
+
+ -3: Übertragung abbrechen.
+
+
+2.5 Vermittlungsebene
+
+ Diese Ebene ist dafür zuständig, Tasknamen von Task auf anderen Stationen
+ in Taskids (Werte des Typs TASK) zu wandeln und umgekehrt. Hierzu wird im
+ entsprechenden OPEN-Telegramm der Code -6 (bzw. -7) als <code>
+ eingetragen. Die Netzempfangstask erkennt diese Codes und wickelt die
+ Aufgaben selbst ab, sodaß es dabei nicht nötig ist, irgendeine Taskid der
+ Zielstation zu kennen.
+
+ Dieses Verfahren ist möglich, weil im 'send' nur positive Codes erlaubt sind.
+
+2.6 Höhere Ebenen
+
+ Höhere Ebenen sind nicht mehr netzspezifisch. Sie basieren alle auf dem
+ Send/Wait-Konzept des EUMEL. So gibt es z.B. den 'global manager', der
+ Aufbewahrung und Zugriff von Dateien in einer Task regelt. Dabei darf diese
+ Task (bei der Variante 'free global manager') auf einer beliebigen Station im
+ Netz liegen. Wegen des Rendevous-Konzepts können beliebige Sicherheit­
+ strategien benutzt werden (z.B.: Keine Dateien an Station 11 ausliefern). Von
+ großen Wert ist z.B., daß man ohne weiteres das Archiv (Floppylaufwerk) einen
+ anderen Station anmelden und benuzten kann, wodurch eine einfache Kon­
+ vertierung von Floppyformaten möglich ist. Dies ist möglich, weil auch die Ar­
+ chiv-Task der Stationen sich an das Globalmanagerprotokoll halten.
+
+
+#type("triumb12")#
+Bemerkungen#type("trium8")#
+
+Fehlerbehandlung besteht bis Ebene 3 darin, fehlerhafte Telegramme einfach zu
+entfernen. Die Ebene 4 überwacht den Netzverkehr sowieso über Timeouts, die
+eine Wiederhohlung eines Telegrammes bewirken, wenn die Quittung ausbleibt.
+
+Da bei der sendenden Station der ganze Datenraum zur Verfügung steht, ist eine
+Fenstertechnik (wie bei HDLC) nicht nötig. Es kann zu jedem Zeitpunkt um beliebig
+viele Telegramme zurückgesetzt werden.
+
+Da im EUMEL eine Textdatei ein Datenraum mit sehr komplexer Struktur ist (wegen
+der Insert/Delete-Möglichkeiten, ohne den Rest der Datei zu schieben), ist es ein
+hoher Aufwand, von einem fremden Betriebssytem her Textdateien ins EUMEL-
+Netz zu senden. Für solche Zwecke muß noch eine einfachere Dateistruktur defi­
+niert werden und entsprechende Dateikonverter erstellt werden.
+
+
+
+#type("triumb12")#3. Stand der Netzsoftware #type("trium8")#
+
+Das EUMEL-System wickelt die Prozedur #on("bold")#send#off("bold")# über das Netz ab, wenn die
+Stationsnummer der Zieltask ungleich der eigenen Stationsnummer ist. Umge­
+kehrt kann man der von der Prozedur #on("bold")#wait#off("bold")# gelieferten Absendertask die Absen­
+derstation entnehmen (siehe Prozedur #on("bold")#station#off("bold")# in Abschnitt 3).
+
+Nicht unterstützt wird z.Zt. die Logik der Prozeduren #on("bold")#call#off("bold")# und #on("bold")#pingpong#off("bold")#. Diese
+funktionieren nur in der gewohnten Weise, wenn die Zieltask in #on("bold")#wait#off("bold")# steht. Ist
+die Zieltask länger als ca. 10 Minuten #on("bold")#busy#off("bold")# oder nicht mehr vorhanden, geht die
+Sendung einfach verloren (Gefordert ist: bei #on("bold")#call#off("bold")#: immer wieder versuchen; bei #on("bold")#
+pingpong#off("bold")#: Rückmeldung -2).
+
+Wegen dieser Einschränkung kann man z.B. ein sicheres Drucken von Station a
+auf einen Drucker der Station b nur durch einen eigenen Spoolmanager auf
+Station a verwirklichen. Die Einrichtung eines solchen Managers ist allerdings
+sowieso sinnvoll, damit man
+
+- das normale 'print'-Kommando verwenden kann (statt z.B. save ("xxx",
+4/printer);) und
+- nicht zu warten braucht, bis die Datei übers Netz gesendet ist.
+
+
diff --git a/system/printer-24nadel/0.9/doc/readme b/system/printer-24nadel/0.9/doc/readme
new file mode 100644
index 0000000..d526aa3
--- /dev/null
+++ b/system/printer-24nadel/0.9/doc/readme
@@ -0,0 +1,320 @@
+#type("nlq10")##limit(18.0)##start(1.5,1.0)#
+#head#
+Treiber-Installations-Programm #right#Seite %
+für 24-Nadel-Matrixdrucker #right#23.12.1988
+
+
+#end#
+#on("u")#Dokumentation zum Treiber-Installations-Programm für 24-Nadel-
+Matrixdrucker#off("u")#
+
+#on("u")#Inhalt:#off("u")#
+
+1. Installations- und Gebrauchsanleitung
+2. Druckertreiber-Auswahl
+3. Steuerungsmöglichkeiten und Spezialfeatures
+4. Weitere Hinweise
+
+
+#on("b")#1. Installations- und Gebrauchsanleitung#off("b")#
+
+#on("u")#Einrichten#off("u")#
+So wird das Treiber-Installationsprogramm eingerichtet:
+
+ SV drücken
+
+ nach 'gib supervisor kommando:'
+
+ begin("PRINTER","SYSUR")
+
+ in der Task "PRINTER" (nach 'gib kommando'):
+
+ archive ("std.printer")
+ fetch ("printer.24.nadel",archive)
+ check off
+ insert ("printer.24.nadel")
+
+Das Programm wird dann insertiert.
+
+#on("u")#Druckerkanal#off("u")#
+Hiernach wird die Kanalnummer des Druckers erfragt. Wenn der Drucker
+über Parallelschnittstelle betrieben wird, ist die Kanalnummer
+meistens 15.
+
+#on("u")#Menüsystem#off("u")#
+Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern.
+Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste
+der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier
+den passenden Typ aus!
+Das Installationsprogramm zeigt nun einige Informationen zu dem ange­
+wählten Drucker. Besonders zu beachten sind hierbei #on("u")#Angaben zur Konfi­
+guration des Druckers#off("u")# (z.B. DIP-Schalter). Der Drucker muß unbedingt
+wie angegeben konfiguriert werden, wenn er mit dem ausgewählten Trei­
+ber betrieben werden soll.
+
+Hinweise zu Konfigurationsangaben:
+1. Die Angabe 'egal' bedeutet, daß die Einstellung für die Funktion
+ des Treibers keine Bedeutung hat. Dennoch solte der Anwender darauf
+ achten, welche Funktion die Schalter haben (Druckerhandbuch!). So
+ ist es zum Beispiel immer empfehlenswert, den Papierende-Sensor zu
+ aktivieren, damit der Drucker nach Papierende nicht auf der Walze
+ weiterdruckt.
+2. Die Konfigurationsangaben beziehen sich immer auf genau den ausge­
+ wählten Druckertyp. Wenn Sie den Treiber mit einem anderen Drucker
+ als den ausgewählten verwenden, dann beachten Sie folgende Regeln
+ für die Konfiguration:
+ - Der Drucker muß auf eine passende Emulation konfiguriert werden.
+ - Der Drucker darf bei einem Carriage Return (Code 13) keinen Zei­
+ lenvorschub durchführen.
+ - Der Drucker darf die Perforation #on("u")#nicht#off("u")# automatisch überspringen.
+
+ - Auf Seitenlängen und internationale Zeichensätze müssen Sie nicht
+ achten.
+
+(Hinweise zur Auswahl des richtigen Treibers gibt Abschnitt 2)
+
+Nach den Konfigurationsangaben werden Steuerungsmöglichkeiten des
+ausgewählten Treibers angezeigt. (Siehe hierzu Abschnitt 3)
+
+Falls der Treiber bestimmte grundsätzliche Betriebsmöglichkeiten er­
+laubt (z.B. DRAFT/NLQ, Einzelblatteinzug), werden Sie danach gefragt,
+welche Möglichkeit standardmäßig gewählt werden soll. diese Vorein­
+stellungen können nachträglich in der Task "PRINTER" mit den entspre­
+chenden Steuerprozeduren neu gesetzt werden. Außerdem können bestimmte
+Einstellungen noch für jedes einzelne Dokument (d.h. für jede Druck­
+datei) gewählt ('material'-Anweisung) oder sogar innerhalb eines Doku­
+ments verändert werden (direkte Druckeranweisung \#"..."\#).
+Über die Steuerungsmöglichkeiten informiert Abschnitt 3 ausführlicher.
+
+
+#on("b")#2. Druckertreiber-Auswahl#off("b")#
+
+#on("u")#Verwendung nicht im Menü enthaltener Drucker#off("u")#
+Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden, soll­
+ten Sie zunächst versuchen, ob ein Treiber für einen anderen Drucker
+des gleichen Herstellers mit Ihrem Drucker korrekt arbeitet.
+Falls dies nicht funktioniert oder der Hersteller überhaupt nicht im
+Menü erscheint, müssen Sie herausfinden (Druckerhandbuch, -händler!),
+welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist.
+(Viele Drucker verfügen über EPSON LQ-1000 oder IBM Grafikdrucker bzw.
+Proprinter-Eumulationen.)
+Eine der beiden Anpassungen 'EPSON LQ-1050' oder 'OKI ML-393
+IBM-kompatibel' müßte immer einen (Minimal-) Betrieb ermöglichen (wobei die
+Verwendung der Proportionalschrift bzw. der doppelt hohen Schriften u. U.
+nicht funktioniert).
+
+
+#on("b")#3. Steuerungsmöglichkeiten und Spezialfeatures#off("b")#
+
+Einige Treiber bieten bestimmte Einstellungsmöglichkeiten (z.B.
+DRAFT/NLQ) und/oder Spezialfeatures (z.B. Farbdruck).
+Die Einstellungen können über
+- Steuerprozeduren
+- Materialanweisungen bzw.
+- direkte Druckeranweisungen
+vorgenommen werden.
+
+#on("u")#Steuerprozeduren#off("u")#
+setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten
+sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER")
+aufgerufen werden. #on("b")#Gültig werden die Änderungen erst, wenn danach in
+der Druckspooltask das Kommando 'start' gegeben wird!#off("b")#
+
+PROC papersize (REAL CONST breite, länge)
+ Dient zur Einstellung der Größe der physikalisch beschreibbaren
+ Fläche.
+ Beispiel: papersize (20.32, 30.48)
+ (Standardeinstellung für Endlospapier 8 Zoll breit und
+ 12 Zoll lang)
+
+PROC papersize
+ Informationsprozedur
+
+PROC top margin (REAL CONST margin)
+ Falls der Drucker es nicht erlaubt, direkt am Blattanfang zu druk­
+ ken (zum Beispiel wegen eines Einzelblatteinzugs), muß mit dieser
+ Prozedur die Länge des oberen Randes, den der Drucker nicht be­
+ drucken kann, in cm angegeben werden.
+ Beispiel: top margin (2.0)
+ (Teilt dem Druckertreiber mit, daß die ersten 2 cm
+ nicht bedruckbar sind.)
+
+REAL PROC top margin
+ Informationsprozedur
+
+PROC std speed (TEXT CONST speed)
+ Parameter: slow, fast
+ Wahl zwischen Positionierung in Mikroschritten (slow) oder in
+ Blanks (fast).
+ Beispiel: std speed ("slow")
+
+TEXR PROC std speed
+ Informationsprozedur
+
+PROC std quality (TEXT CONST quality)
+ übliche Parameter: draft, nlq
+ Wahl zwischen Datenverarbeitungs-Qualität und Schönschrift-
+ Qualität
+ Beispiel: std quality ("draft")
+
+TEXT PROC std quality
+ Informationsprozedur
+
+PROC std typeface (TEXT CONST typeface)
+ übliche Parameter: roman, sansserif, courier
+ Wahl zwischen verschiedenen NLQ-Schriftarten (nur sichtbar im
+ NLQ-Modus, das heißt 'std typeface' schaltet nicht auf NLQ).
+ Beispiel: std typeface ("roman")
+
+TEXT PROC std typeface
+ Informationsprozedur
+
+PROC paper feed (TEXT CONST name)
+ übliche Parameter: tractor, sheet, schacht1, schacht2
+ Wählt Endlospapier oder Einzelblatteinzug und ggf. Schachtnummer.
+ Beispiel: paper feed ("sheet")
+
+TEXT PROC paper feed
+ Informationsprozedur
+
+
+#on("u")#Materialanweisungen \#material("...")\##off("u")#
+müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und
+setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben
+für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge­
+stellten Standardwerten. Diese werden durch die Materialanweisung aber
+nicht geändert.)
+
+Beispiel: \#material("nlq")\#
+ sorgt bei entsprechendem Treiber dafür, daß das gesamte
+ Dokument in Schönschrift-Qualität ausgedruckt wird, egal
+ wie 'std quality' eingestellt ist.
+
+#on("b")#Es darf in einer Datei nur eine Materialanweisung stehen!#off("b")# Sollen meh­
+rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung
+erscheinen. Beispiel: \#material("sheet;draft")\#
+
+
+#on("u")#direkte Druckeranweisungen \#"..."\##off("u")#
+gelten ab der Position, an der sie in der Datei auftreten. Sie haben
+(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und
+Materialeinstellungen.
+
+Beispiel: \#"draft"\#
+ schaltet (bei entsprechendem Treiber) auf Datenverar­
+ beitungs-Qualität, egal welche Standardeinstellung vorliegt
+ und welche Materialanweisung gegeben wurde.
+
+#on("b")#In einer Druckeranweisung darf nur eine Einstellung vorgenommen
+werden.#off("b")# Also: \#"nlq"\#\#"sansserif"\#
+
+
+#on("u")#Wichtig#off("u")#
+- Achten Sie bei Materialanweisungen und direkten Druckeranweisungen
+ besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben
+ berücksichtigt! Also: \#"nlq"\# und keinesfalls \#"NLQ"\#!!!
+- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und
+ nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann
+ daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse
+ erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen
+ Reihenfolge an den Drucker sendet, als er in der Datei steht, die
+ mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B.
+ für beide Spalten) unerwünscht erhalten bleibt.
+
+
+#on("u")#Tabelle#off("u")#
+Die Tabelle soll einen Anhaltspunkt dafür geben, wie welche Einstel­
+lungen erfolgen können.
+
+#type("17")#
+ Steuerprozeduren Materialanweisungen direkte Druckeranweisungen
+
+#on("u")#                                                                                          #off("u")#
+
+Positionierung std speed slow, fast ------
+ slow, fast
+
+Qualität std quality z.B. draft, nlq z.B. draft, nlq
+ z.B. draft, nlq
+
+Schriftart std typeface z.B. roman, z.B. roman,
+(nur bei NLQ) z.B. roman, sansserif, courier sansserif, courier
+ sansserif, courier
+
+Einzelblatt- paper feed z.B. schacht1, z.B. schacht1,
+einzug z.B. tractor, schacht2 schacht2
+ sheet,
+ schacht1, schacht2
+
+Farbdruck ------ ------ z.B. schwarz,
+ rot, blau,
+ violett, gelb
+ orange, grün
+
+
+
+#type("nlq10")##on("b")#4. Weitere Hinweise#off("b")#
+
+#on("u")#Zeichensatzänderungen gegenüber früheren Versionen#off("u")#
+In den Fonttabellen früherer Druckertreiber-Versionen wurden oberhalb
+des Codes 127 einige internationale Zeichen zur Verfügung gestellt
+(und zwar in Anlehnung an den Agfa-Laserdrucker-Zeichensatz).
+Bei den Treibern der vorliegenden Version gilt folgendes:
+- Wie bisher wird der volle im Benutzerhandbuch festgelegte EUMEL-
+ Zeichensatz (sofern möglich) unterstützt.
+- Der Code 252 liefert das Paragraphzeichen.
+- Alle übrigen (vom EUMEL-Zeichensatz nicht definierten) Zeichencodes
+ oberhalb 127 liefern, sofern möglich, die entsprechenden Zeichen des
+ IBM-Grafikzeichensatzes.
+
+
+#on("u")#Hinweis zu Proportionalschriften#off("u")#
+Bei Proportionalschriften kann die Modifikation \#on("i")\# zu Problemen
+führen (z.B. beim Blocksatz), wenn die kursiven Zeichen andere
+Proportionalbreiten haben.
+
+#on("u")#Hinweis zur Modifikation on/off("b") bzw. on/off("r")#off("u")#
+Die meisten 24-Nadel Drucker verfügen sowohl über einen horizontalen als
+auch über einen vertikalen Schattendruck. Diese beiden Druckarten können
+mit der Modifikation on("b") (bold) bzw. on("r") (eigentlich für reverse
+gedacht) eingeschaltet werden.
+
+#on("u")#Hinweis zur Benutzung von Einzelblatteinzügen#off("u")#
+Bei der Benutzung von Einzelblatteinzügen müssen folgende Einstel­
+lungen vorgenommen werden (vgl. auch Abschnitt 3!):
+
+ Am Drucker:
+1. Sie müssen Ihren Drucker auf die Option Einzelblatteinzug
+ schalten (siehe Druckerhandbuch!).
+
+ In der Druckspooltask (meist 'PRINTER'):
+2. Falls der Druckertreiber die Steuerprozedur 'paper feed' zur Verfü­
+ gung stellt, müssen Sie mit 'paperfeed ("sheet")' oder (für
+ 2-Schacht-Einzüge) mit 'paperfeed ("schacht1")' bzw. 'paperfeed
+ ("schacht2")' den Druckertreiber auf Einzelblatteinzug umschalten.
+3. Falls Sie eine andere Papierlänge als 12 Zoll (=30.48 cm) verwen­
+ den, müssen Sie die neuen Papiermaße mit 'papersize' in cm einstel­
+ len.
+ Beispiel: papersize (21.0, 29.7)
+ (für DIN A4-Blätter)
+4. Falls der Drucker mit dem Einzelblatteinzug nicht direkt am Blatt­
+ anfang drucken kann, sondern ein gewisser oberer Rand bleibt, muß
+ mit 'top margin' die Länge des nicht bedruckbaren Randes in cm dem
+ Druckertreiber mitgeteilt werden.
+ Beispiel: top margin (1.5)
+ (Wie groß der obere Rand ist, kann festgestellt werden, indem eine
+ Datei mit \#start(0.0,0.0)\# ausgedruckt wird.)
+
+ Wurde mit 'top margin' dem Treiber die Größe der nicht bedruckbaren
+ Fläche mitgeteilt, so ist darauf zu achten, daß in den Druckdateien
+ ein genügend großer y-Wert für die Startposition eingestellt wird
+ ('start'-Anweisung). Andernfalls kommt es bei der Ausgabe in der
+ ersten Zeile zu Überschreibungen.
+
+
+#on("b")#5. Die Änderungen, die Sie in der Druckspooltask vorgenommen haben
+ werden erst wirksam, wenn das Spool-Kommando 'start' gegeben wird.#off("b")#
+
+
+
+
diff --git a/system/printer-24nadel/0.9/source-disk b/system/printer-24nadel/0.9/source-disk
new file mode 100644
index 0000000..2ed06c0
--- /dev/null
+++ b/system/printer-24nadel/0.9/source-disk
@@ -0,0 +1,3 @@
+grundpaket/07_std.printer_24_nadel.img
+187_ergos/05_std.printer_24nadel.img
+187_ergos/06_std.printer_24nadel.img
diff --git a/system/printer-24nadel/0.9/src/beschreibungen24 b/system/printer-24nadel/0.9/src/beschreibungen24
new file mode 100644
index 0000000..e3d2fa9
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/beschreibungen24
@@ -0,0 +1,62 @@
+
+(*************************************************************************)
+(* Stand : 3. 1.89 *)
+(* Beschreibungen-Datei für 24-Nadel-Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+$necp5p7$
+begin;headnecp5p7;declarations;feed;
+open;opendoch;opendocp5p7;openpagep5-7;close;closepage;
+execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end
+
+$necp6$
+begin;headnecp6;declarations;feed;
+open;opendoch;opendocp6;openpagep5-7;close;closepage;
+execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end
+
+$necp6+$
+begin;headnecp6+;declarations;speed;topmargin;typefacep6+;feed;
+open;opendoch;initspeed;opendocp6+;openpage;close;closepage;
+execute;cmdp6+;crs;move;stdmove;onoff;typep6+;end
+
+$epsonlq850$
+begin;headlq850;declarations;speed;topmargin;typefacelq850;feed;
+open;opendoch;initspeed;opendoclq850;openpage;close;closepage;
+execute;cmdlq850;crs;move;stdmove;onoff;typeplq850;end
+
+$epsonlq1500$
+printerlq1500;end
+
+$oki390/391$
+begin;headoki390/391;declarations;speed;topmargin;typefaceoki;feedschacht;
+open;opendoch;initspeed;opendocokieps;openpage;close;closepage;
+execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end
+
+$oki393/393Ceps$
+begin;headoki393/393Ceps;declarations;speed;topmargin;typefaceoki;feedschacht;
+open;opendoch;initspeed;opendocokieps;openpage;close;closepage;
+execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end
+
+$oki393/393Cibm$
+begin;headoki393/393Cibm;declarations;speed;topmargin;typefaceoki;feedschacht;
+open;opendoch;initspeed;opendocokiibm;openpage;close;closepage;
+execute;cmdoki;crs;move;stdmove;onoff;typeokiibm;end
+
+$toshp321$
+begin;headtoshp321;declarations;speed;feed;
+open;opendochtosh;initspeed;opendoctosh;openpagetosh;close;closepagetosh;
+execute;cmdtosh;crs;move;stdmove;onoff;typetosh;end
+
+$starnb24$
+begin;headstarnb24;declarations;speed;topmargin;typefacestar;feedschacht;
+open;opendoch;initspeed;opendocstar;openpage;close;closepage;
+execute;cmdstar;crs;move;stdmove;onoff;typestar;end
+
+$brotherm1724l$
+begin;headbrotherm1724l;declarations;speed;topmargin;feed;
+open;opendoch;initspeed;opendocbrother;openpage;close;closepage;
+execute;cmdtosh;crs;move;stdmove;onoff;typebrother;end
+
+
+
diff --git a/system/printer-24nadel/0.9/src/fonttab.brother b/system/printer-24nadel/0.9/src/fonttab.brother
new file mode 100644
index 0000000..2251e18
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.brother
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/fonttab.epson.lq1500 b/system/printer-24nadel/0.9/src/fonttab.epson.lq1500
new file mode 100644
index 0000000..1b4c6a6
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.epson.lq1500
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/fonttab.epson.lq850 b/system/printer-24nadel/0.9/src/fonttab.epson.lq850
new file mode 100644
index 0000000..7a6d2f0
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.epson.lq850
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/fonttab.nec.p5 b/system/printer-24nadel/0.9/src/fonttab.nec.p5
new file mode 100644
index 0000000..9910da6
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.nec.p5
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/fonttab.nec.p5.new b/system/printer-24nadel/0.9/src/fonttab.nec.p5.new
new file mode 100644
index 0000000..9804bd5
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.nec.p5.new
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/fonttab.nec.p6+ b/system/printer-24nadel/0.9/src/fonttab.nec.p6+
new file mode 100644
index 0000000..b209e81
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.nec.p6+
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/fonttab.oki b/system/printer-24nadel/0.9/src/fonttab.oki
new file mode 100644
index 0000000..2251e18
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.oki
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/fonttab.toshiba.p321 b/system/printer-24nadel/0.9/src/fonttab.toshiba.p321
new file mode 100644
index 0000000..452afca
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/fonttab.toshiba.p321
Binary files differ
diff --git a/system/printer-24nadel/0.9/src/inserter b/system/printer-24nadel/0.9/src/inserter
new file mode 100644
index 0000000..442075d
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/inserter
@@ -0,0 +1,793 @@
+
+(*************************************************************************)
+(* Installationsprogramm für Stand : 3. 1.89 *)
+(* 24-Nadel Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+PACKET driver inst 24
+
+
+ DEFINES treiber einrichten:
+
+
+LET up = ""3""13""5"",
+
+ generator name = "printer.24.nadel",
+
+ description file name = "beschreibungen24",
+ module file name = "module24";
+
+
+INT VAR pr channel,
+ quality,
+ paper format number,
+ service option;
+TEXT VAR fonttab name :: "",
+ driver name :: "";
+TEXT VAR inp;
+BOOL VAR was esc;
+
+treiber einrichten
+
+PROC treiber einrichten:
+
+ treiber einrichten (0)
+END PROC treiber einrichten;
+
+PROC treiber einrichten (INT CONST service opt):
+
+ ask for print channel;
+ main menu;
+ IF installed
+ THEN generate printer spool
+ ELSE inform about restart
+ FI.
+
+ ask for printchannel:
+ inits;
+ page;
+ headline ("Druckerkanal - Einstellung");
+ cursor (1, 15);
+ putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit");
+ putline (" 'serverchannel (Kanalnummer)' in der Task """ +
+ name (myself) + """");
+ putline (" verändert werden.");
+ REP
+ cursor (1, 10);
+ put (""5"EUMEL-Kanalnummer des Druckerkanals:");
+ get (pr channel);
+ disable stop;
+ serverchannel (pr channel);
+ BOOL VAR no error :: NOT is error;
+ clear error;
+ no error := no error CAND
+ (pr channel <> channel (myself)) CAND
+ (pr channel > 1) CAND
+ (pr channel < 17);
+
+ IF NOT no error
+ THEN cursor (1, 7);
+ put error;
+ putline ("Eingabe korrigiert wiederholen!")
+ FI;
+ enable stop
+ UNTIL no error PER;
+ IF exists task ("canal " + text (pr channel))
+ THEN end (/ ("canal " + text (pr channel)));
+ FI;
+
+. inits:
+ line;
+ IF single task
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+ FI;
+ command dialogue (TRUE);
+ IF name (myself) <> "PRINTER"
+ THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ +
+ name (myself) + """ !");
+ IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?")
+ THEN rename myself ("PRINTER")
+ FI
+ FI;
+ INT VAR choice;
+ service option := service opt.
+
+ single task: (pcb (9) AND 255) = 1.
+
+ main menu:
+ BOOL VAR installed :: FALSE;
+ REP
+ show main menu;
+ get choice;
+ treat choice
+ UNTIL was esc OR installed PER.
+
+ show main menu:
+ page;
+ headline("Hauptmenü 24-Nadel-Drucker");
+ putline (" 1. Brother");
+ putline (" 2. Epson");
+ putline (" 3. NEC");
+ putline (" 4. OKI");
+ putline (" 5. Toshiba").
+
+ get choice:
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Installation abbrechen");
+ ask user (5).
+
+ treat choice:
+ SELECT int (inp) OF
+ CASE 1: brother menu
+ CASE 2: epson menu
+ CASE 3: nec menu
+ CASE 4: oki menu
+ CASE 5: toshiba menu
+ END SELECT.
+
+
+ brother menu:
+ page;
+ headline ("brother - Menü");
+ putline (" 1. M-1724 L");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ brother m1724l inst
+ FI.
+
+ brother m1724l inst:
+ putline ("brother M-1724 L");
+ line;
+ putline ("Wählen Sie folgende DIP-Schalter Optionen:");
+ putline ("Emulationsmodus IBM Proprinter XL ");
+ putline ("Automatischer Zeilenvorschub Nein ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.brother");
+ generate ("brotherm1724l");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ toshiba menu:
+ page;
+ headline ("TOSHIBA - Menü");
+ putline (" 1. P 321");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ toshiba p321 inst
+ FI.
+
+ toshiba p321 inst:
+ putline ("TOSHIBA P 321");
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S3-8 S3-7 S3-5 übrige Schalter");
+ putline ("OFF OFF *) egal ");
+ putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug");
+ show control options ("std speed, paper feed");
+ show material options("slow, fast");
+ show command options ("nlq, draft");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.toshiba.p321");
+ generate ("toshp321");
+ adjust papersize;
+ adjust quality;
+ do ("papersize(21.0,30.48)");
+ installed := TRUE;
+ FI.
+
+
+ epson menu:
+ page;
+ headline ("Epson - Menü");
+ putline (" 1. LQ 850");
+ putline (" 2. LQ 1050");
+ putline (" 3. LQ 1500");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (3);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : lq850 inst
+ CASE 2 : lq850 inst
+ CASE 3 : lq1500 inst
+ END SELECT
+ FI.
+
+ lq850 inst:
+ IF choice = 1
+ THEN putline ("Epson LQ 850")
+ ELSE putline ("Epson LQ 1050")
+ FI;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8");
+ putline ("egal egal egal egal egal egal *1) OFF ");
+ putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line;
+ putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8");
+ putline ("egal egal *2) OFF OFF");
+ putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle ");
+ putline (" gesetzt werden (Druckerhandbuch)");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, roman, sansserif");
+ show command options ("draft, nlq, roman, sansserif");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq850");
+ generate ("epsonlq850");
+ adjust quality;
+ adjust papersize;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ lq1500 inst:
+ putline ("EPSON LQ-1500");
+ show control options ("");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq1500");
+ generate ("epsonlq1500");
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ nec menu:
+ page;
+ headline ("NEC - Menü");
+ putline (" 1. PINWRITER P5 ");
+ putline (" 2. PINWRITER P6 ");
+ putline (" 3. PINWRITER P7 ");
+ putline (" 4. PINWRITER P6 PLUS");
+ putline (" 5. PINWRITER P7 PLUS");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (5);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : necp5p7 inst
+ CASE 2 : necp6 inst
+ CASE 3 : necp5p7 inst
+ CASE 4 : necp6plus inst
+ CASE 5 : necp6plus inst
+ END SELECT
+ FI.
+
+ necp5p7 inst:
+ IF choice = 1
+ THEN putline ("NEC PINWRITER P5")
+ ELSE putline ("NEC PINWRITER P7")
+ FI;
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp5p7");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6 inst:
+ putline ("NEC PINWRITER P6 ");
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp6");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6plus inst:
+ IF choice = 4
+ THEN putline ("NEC PINWRITER P6 PLUS")
+ ELSE putline ("NEC PINWRITER P7 PLUS")
+ FI;
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("CR FUNCTION CR ONLY ");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, courier, souvenir");
+ show command options ("draft, nlq, courier, souvenir");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p6+");
+ generate ("necp6+");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE;
+ IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI;
+ FI.
+
+ oki menu:
+ page;
+ headline ("OKI - Menü");
+ putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel");
+ putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel");
+ putline (" 3. MICROLINE 393/393C EPSON-kompatibel");
+ putline (" 4. MICROLINE 393/393C IBM-kompatibel");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (4);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : oki ml390 inst
+ CASE 2 : oki ml390 inst
+ CASE 3 : oki ml393eps inst
+ CASE 4 : oki ml393ibm inst
+ END SELECT
+ FI.
+
+ oki ml390 inst:
+ IF choice = 1
+ THEN putline ("OKI Microline 390") ;
+ ELSE putline ("OKI Microline 391") ;
+ FI;
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE EPSON LQ ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki390/391");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ oki ml393eps inst:
+ putline ("OKI Microline 393 EPSON-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Ceps");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ oki ml393ibm inst:
+ putline ("OKI Microline 393 IBM-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE ASCII ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Cibm");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+
+
+generate printer spool:
+ IF service opt = 0
+ THEN forget (generator name, quiet);
+ forget (driver name, quiet)
+ FI;
+ eumel must advertise;
+ cursor (1, 10);
+(* putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (2);
+ putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer");
+ putline (" Drucker eingesetzt werden soll.");
+ line (2);
+*)
+(* put ("Generierung beendet, weiter mit 'SV'");
+ break (quiet);
+*)
+ putline (" Generierung beendet.");
+ putline (" Weiter: Bitte Taste drücken");
+ WHILE incharety <> "" REP ENDREP;
+ REP UNTIL incharety <> "" ENDREP;
+ break;
+ do ("spool manager (PROC printer)").
+
+ inform about restart:
+ page;
+ putline ("Es ist kein Druckertreiber installiert worden!");
+ line;
+ putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline ("mit 'treiber einrichten' erneut aufgerufen werden.");
+ line;
+ pause(50);
+ break.
+
+END PROC treiber einrichten;
+
+PROC headline (TEXT CONST header):
+
+ cursor (13,1);
+ putline ("E U M E L - Druckertreiber - Installations - Programm");
+ cursor (40 - LENGTH header DIV 2, 2);
+ put (header);
+ line (2)
+END PROC headline;
+
+PROC ask user (INT CONST max choice):
+
+ TEXT VAR exit;
+ inp := "";
+ REP
+ cursor (1,23);
+ IF inp = ""
+ THEN put ("Ihre Wahl (Nummer eingeben):")
+ ELSE put ("FEHLER! Eingabe korrigieren:")
+ FI;
+ editget (inp, ""27"", "", exit);
+ was esc := exit = ""27"";
+ UNTIL was esc OR ok PER.
+
+ ok:
+ int (inp) > 0 AND int (inp) <= max choice AND last conversion ok.
+END PROC ask user;
+
+PROC show control options (TEXT CONST options):
+
+ line;
+ putline ("Steuerprozeduren in der Task """ + name (myself) + """:");
+ write ("papersize, std quality");
+ IF options <> ""
+ THEN put (",");
+ putline (options)
+ FI
+END PROC show control options;
+
+PROC show material options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche Materialwerte (#material(""..."")#):");
+ putline (options)
+END PROC show material options;
+
+PROC show command options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche direkte Druckeranweisungen (#""...""#):");
+ putline (options)
+END PROC show command options;
+
+PROC ask for quality:
+
+ line (1);
+ putline ("Standard - Druckqualität:");
+ line;
+ REP out (up);
+ IF yes ("Draft Quality (schneller, aber nicht so schön)")
+ THEN quality := 1; LEAVE ask for quality
+ FI;
+ out (up);
+ IF yes ("Near Letter Quality (schöner, aber langsamer)")
+ THEN quality := 2; LEAVE ask for quality
+ FI;
+ PER
+END PROC ask for quality;
+
+PROC adjust quality:
+
+ IF quality = 1
+ THEN do ("std quality (""draft"")")
+ ELSE do ("std quality (""nlq"")")
+ FI
+END PROC adjust quality;
+
+PROC ask for papersize :
+LET up = ""3""13""5"";
+
+ paper format number := paper format ;
+
+ . paper format :
+ line (1);
+ putline ("Papierformat:");
+ line;
+ REP out (up);
+ IF yes ("Endlospapier, 8 Zoll breit")
+ THEN LEAVE paper format WITH 1 FI;
+ out (up);
+ IF yes ("Endlospapier, 13.2 Zoll breit")
+ THEN LEAVE paper format WITH 2 FI;
+ out (up);
+ IF yes ("Einzelblatteinzug, DINA 4")
+ THEN LEAVE paper format WITH 3 FI;
+ PER;
+ 0
+END PROC ask for papersize;
+
+
+PROC adjust papersize:
+
+ SELECT paper format number OF
+ CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 3 : do("papersize (21.0, 29.7)");
+ do ("paper feed (""sheet"")")
+ END SELECT
+
+END PROC adjust papersize;
+
+BOOL PROC all right:
+
+ line (3);
+ cursor (1,23);
+ yes ("Soll der ausgewählte Druckertreiber installiert werden")
+END PROC all right;
+
+PROC get fonttable (TEXT CONST name):
+
+ fonttab name := name;
+ from archive ((description file name & module file name & fonttab name)
+ - all);
+ fonttable (fonttab name);
+ command dialogue (FALSE);
+ save (fonttab name, /"configurator");
+ IF service option = 0
+ THEN forget (fonttab name)
+ FI;
+ command dialogue (TRUE);
+END PROC get fonttable;
+
+PROC from archive (THESAURUS CONST files):
+
+ IF highest entry (files) > 0
+ THEN fetch from archive;
+ release (archive);
+ putline ("Archiv abgemeldet !")
+ FI.
+
+ fetch from archive:
+ THESAURUS VAR thes :: files;
+ REP
+ ask for archive;
+ reserve archive;
+ fetch (thes / ALL archive, archive);
+ thes := thes - all
+ UNTIL highest entry (thes) = 0 PER.
+
+ask for archive:
+ TEXT VAR buffer;
+(*line;
+ putline ("Bitte Archiv mit den Dateien");
+ INT VAR index :: 0;
+ REP
+ get (thes, buffer, index);
+ putline (" " + buffer)
+ UNTIL index = 0 PER;
+ putline ("einlegen !");
+ line;
+ putline ("Wenn eingelegt: Taste drücken !");
+ inchar (buffer)*).
+
+reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop.
+
+END PROC from archive;
+
+THESAURUS OP & (TEXT CONST left, right):
+ THESAURUS VAR result := empty thesaurus;
+ insert (result, left);
+ insert (result, right);
+ result
+END OP &;
+
+THESAURUS OP & (THESAURUS CONST left, TEXT CONST right):
+ THESAURUS VAR result := left;
+ insert (result, right);
+ result
+END OP &;
+
+PROC generate (TEXT CONST name):
+
+ open files;
+ read description;
+ build programme;
+ insert programme;
+ forget files.
+
+ open files:
+ line (5);
+ cursor (1, 20);
+ putline (""4"Bitte warten !");
+ putline (" - Der Treiber wird generiert.");
+ driver name := "printer." + name + "(generiert)";
+ IF exists (driver name)
+ THEN forget (driver name, quiet)
+ FI;
+ FILE VAR des file :: sequential file (modify, description file name),
+ mod file :: sequential file (modify, module file name),
+ driver file :: sequential file (output, driver name).
+
+ read description:
+ to line (des file, 1);
+ col (des file, 1);
+ downety (des file, "$" + name + "$");
+ IF eof (des file)
+ THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" +
+ "Descriptions-File enthalten")
+ FI;
+ TEXT VAR description :: "",
+ record;
+ BOOL VAR done :: FALSE;
+ read record (des file, record);
+ record := subtext (record, col (des file) + LENGTH name + 2);
+ WHILE NOT eof (des file) AND NOT done REP
+ treat record
+ PER.
+
+ treat record:
+ INT VAR dollar pos :: pos (record, "$");
+ IF dollar pos = 0
+ THEN description CAT compress (record);
+ down (des file);
+ read record (des file, record)
+ ELSE description CAT compress (subtext (record, 1, dollar pos - 1));
+ col (des file, dollar pos);
+ done := TRUE;
+ FI.
+
+ build programme:
+ get module name;
+ WHILE still modules REP
+ find module;
+ transfer module;
+ get module name
+ PER.
+
+ get module name:
+ INT VAR semicol pos :: pos (description, ";");
+ TEXT VAR module name;
+ IF semicol pos > 0
+ THEN module name := subtext (description, 1, semicol pos - 1);
+ description := subtext (description, semicol pos + 1)
+ ELSE module name := description;
+ description := ""
+ FI.
+
+ still modules:
+ module name <> "" OR description <> "".
+
+ find module:
+ to line (mod file, 1);
+ col (mod file, 1);
+ downety (mod file, "$" + module name + "$");
+ IF eof (mod file)
+ THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" +
+ "Modul-File enthalten")
+ FI.
+
+ transfer module:
+ done := FALSE;
+ read record (mod file, record);
+ record := subtext (record, col (mod file) + LENGTH module name + 2);
+ WHILE NOT eof (mod file) AND NOT done REP
+ transfer record
+ PER.
+
+ transfer record:
+ dollar pos := pos (record, "$");
+ IF dollar pos = 0
+ THEN write (driver file, compress (record));
+ line (driver file);
+ down (mod file);
+ read record (mod file, record)
+ ELSE write (driver file, compress (subtext (record, 1,
+ dollar pos - 1)));
+ col (mod file, dollar pos);
+ done := TRUE;
+ cout (line no (mod file))
+ FI.
+
+ insert programme:
+ IF online
+ THEN putline (" - Der Treiber wird insertiert.")
+ FI;
+ check off;
+ insert (driver name).
+
+ forget files:
+ IF service option = 0
+ THEN forget (description file name, quiet);
+ forget (module file name, quiet)
+ FI .
+END PROC generate;
+
+END PACKET driver inst 24
+
diff --git a/system/printer-24nadel/0.9/src/module24 b/system/printer-24nadel/0.9/src/module24
new file mode 100644
index 0000000..a4957c2
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/module24
@@ -0,0 +1,1554 @@
+
+(*************************************************************************)
+(* Stand : 03. 1.89 *)
+(* Module-Datei für 24-Nadel-Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+$begin$
+PACKET printer driver
+
+ DEFINES printer,
+ open,
+ close,
+ execute,
+ paper size,
+ std quality,
+
+$headnecp6$ paper feed:
+(* Treiber fuer NEC P6, automatisch generiert *)
+LET underline linetype = 1;
+INT VAR factor 1, factor 2, draft factor 1, draft factor 2;
+
+$headnecp5p7$ paper feed:
+(* Treiber fuer NEC P5, P7 , automatisch generiert *)
+LET underline linetype = 1;
+INT VAR factor 1, factor 2, draft factor 1, draft factor 2;
+
+$headnecp6+$ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+(* Treiber für NEC P6 plus/P7 plus ,automatisch generiert *)
+
+
+$headlq850$ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+(* Treiber für EPSON LQ-850/1050 ,automatisch generiert *)
+
+$headbrotherm1724l$
+ std speed,
+ top margin,
+ paper feed:
+INT VAR vertical factor := 1;
+(* Treiber für BROTHER M-1724L in IBM-Emulation, automatisch generiert *)
+
+$headoki390/391$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+INT VAR vertical factor := 1;
+(* Treiber für OKI MIKROLINE 390/391 ,automatisch generiert *)
+
+$headoki393/393Ceps$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+INT VAR vertical factor := 1;
+(* Treiber für OKI MIKROLINE 393/393C EPSON-kompatibel, automatisch generiert *)
+
+$headoki393/393Cibm$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+INT VAR vertical factor := 1;
+(* Treiber für OKI MIKROLINE 393/393C IBM-kompatibel, automatisch generiert *)
+
+$headtoshp321$ std speed,
+ paper feed:
+(* Treiber für TOSHIBA P321, automatisch generiert *)
+
+$headstarnb24$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+(* Treiber für STAR NB 24-10/15 in Standard Betriebsart automatisch generiert *)
+
+$declarations$
+INT VAR font nr, font bits, modification bits,
+ blankbreite, x rest, high, low, steps;
+REAL VAR x size, y size;
+TEXT VAR buffer :: "";
+BOOL VAR is nlq ;
+TEXT VAR font text :: "";
+TEXT VAR std quality name :: "draft";
+
+. is pica : font bits = 0
+. is elite : font bits = 1
+.;
+
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+END PROC paper size;
+
+papersize (20.32, 30.48);
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+END PROC paper size;
+
+
+
+PROC std quality (TEXT CONST quality) :
+
+ IF quality = "nlq" OR quality = "draft"
+ THEN std quality name := quality
+ ELSE errorstop ("unzulässige Qualitätsbezeichnung")
+ FI
+END PROC std quality;
+
+TEXT PROC std quality :
+
+ std quality name
+END PROC std quality;
+
+
+$topmargin$
+REAL VAR y margin := 0.0 ;
+
+PROC top margin (REAL CONST margin):
+
+ y margin := margin
+END PROC top margin;
+
+REAL PROC top margin:
+
+ y margin
+END PROC top margin;
+
+
+$speed$
+BOOL VAR is slow :: TRUE;
+TEXT VAR std speed name :: "slow";
+
+PROC std speed (TEXT CONST speed) :
+
+ IF speed = "fast" OR speed = "slow"
+ THEN std speed name := speed
+ ELSE errorstop ("unzulässige Geschwindigkeit")
+ FI
+END PROC std speed;
+
+TEXT PROC std speed :
+
+std speed name
+END PROC std speed;
+
+
+$typefacelq850$
+TEXT VAR act typeface name :: "";
+TEXT VAR std typeface name :: "";
+
+. is roman:
+ act typeface name = "roman".
+. is sansserif:
+ act typeface name = "sansserif"
+.;
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "roman" OR typeface = "sansserif"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+
+
+$typefacep6+$
+BOOL VAR is courier :: TRUE;
+TEXT VAR std typeface name :: "courier";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "courier" OR typeface = "souvenir"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+$typefaceoki$
+BOOL VAR is courier ;
+TEXT VAR std typeface name :: "";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "courier" OR typeface = "kassette"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+$typefacestar$
+BOOL VAR is roman ;
+TEXT VAR std typeface name :: "";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "roman" OR typeface = "font1"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+$feed$
+BOOL VAR is sheet feed :: FALSE;
+
+PROC paper feed (TEXT CONST feeder) :
+
+ IF feeder = "sheet"
+ THEN is sheet feed := TRUE
+ ELIF feeder = "tractor"
+ THEN is sheet feed := FALSE
+ ELSE errorstop ("unzulässige Einzugsart")
+ FI
+END PROC paper feed;
+
+TEXT PROC paper feed:
+ IF is sheet feed
+ THEN "sheet"
+ ELSE "tractor"
+ FI
+END PROC paper feed;
+
+$feedschacht$
+BOOL VAR is sheet feed :: FALSE;
+TEXT VAR feeder name :: "tractor";
+
+PROC paper feed (TEXT CONST feeder) :
+
+ IF feeder = "tractor"
+ THEN feeder name := "tractor";
+ is sheet feed := FALSE
+ ELIF feeder = "sheet" OR feeder = "schacht1"
+ THEN feeder name := "schacht1" ;
+ is sheet feed := TRUE
+ ELIF feeder = "schacht2"
+ THEN feeder name := "schacht2" ;
+ is sheet feed := TRUE
+ ELSE errorstop ("unzulässige Einzugsart")
+ FI
+END PROC paper feed;
+
+TEXT PROC paper feed: feeder name END PROC paper feed;
+
+$open$
+PROC open (INT CONST op code, INT VAR param1, param2):
+
+ SELECT op code OF
+ CASE 1: open document(param1,param2)
+ CASE 2: open page (param1,param2)
+ END SELECT.
+END PROC open ;
+
+
+$opendoch$
+PROC open document (INT VAR x steps,y steps):
+ modification bits := 0;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ y steps := (y steps DIV 30) * 30;
+
+$opendochtosh$
+PROC open document (INT VAR x steps,y steps):
+ modification bits := 0;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ y steps := (y steps DIV 36) * 36;
+
+$initspeed$
+ IF pos (material, "slow") <> 0
+ THEN is slow := TRUE;
+ ELIF pos (material, "fast") <> 0
+ THEN is slow := FALSE;
+ ELSE is slow := std speed name = "slow"
+ FI;
+
+$opendocp6+$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ FI;
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN is courier := TRUE ;
+ ELIF pos (material, "souvenir") <> 0
+ THEN is courier := FALSE ;
+ ELSE is courier := std typeface name = "courier"
+ FI;
+END PROC open document ;
+
+$opendocp5p7$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* Amerikanischer Zeichensatz *)
+ out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ center paper ;
+ FI;
+
+ . center paper :
+ INT CONST x steps in chars := x steps DIV x step conversion (2.54 / 10.0),
+ left margin := (136 - x steps in chars) DIV 2;
+ out (""27"P");
+ out (""27"l"); out (code (left margin + 1));
+END PROC open document ;
+
+$opendocp6$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* Amerikanischer Zeichensatz *)
+ out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ FI;
+END PROC open document ;
+
+$opendoclq850$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ FI;
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "roman") <> 0
+ THEN act typeface name := "roman"
+ ELIF pos (material, "sansserif") <> 0
+ THEN act typeface name := "sansserif"
+ ELSE act typeface name := std typeface name
+ FI;
+END PROC open document ;
+
+$opendocokieps$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN IF feeder name = "schacht2"
+ THEN out (""27""25"2")
+ ELSE out (""27""25"1")
+ FI
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN is courier := TRUE ;
+ ELIF pos (material, "kassette") <> 0
+ THEN is courier := FALSE ;
+ ELSE is courier := std typeface name = "courier"
+ FI;
+END PROC open document ;
+
+$opendoctosh$
+ out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *)
+ out (""27"6"); (* Zeichensatz *)
+ out (""27"A"12""27"2") ;
+ out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+END PROC open document ;
+
+$opendocbrother$
+ out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *)
+ out (""27"6" + ""27"R"0""); (* Zeichensatz II ascii *)
+ out (""27"A"10""27"2") ; (* Zeilenabstand *)
+ out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *)
+ IF is sheet feed
+ THEN out (""27""25"4")
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+END PROC open document ;
+
+$opendocokiibm$
+ out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *)
+ out (""27"6" + ""27"!"64""); (* Zeichensatz II ascii *)
+ out (""27""91""92""4""0""0""0""180""); (* 1/180 *)
+ out (""27"A"12""27"2") ; (* Zeilenabstand *)
+ out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *)
+ IF is sheet feed
+ THEN IF feeder name = "schacht2"
+ THEN out (""27""25"2")
+ ELSE out (""27""25"1")
+ FI
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN is courier := TRUE ;
+ ELIF pos (material, "kassette") <> 0
+ THEN is courier := FALSE ;
+ ELSE is courier := std typeface name = "courier"
+ FI;
+END PROC open document ;
+
+$opendocstar$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* amerikanischer Zeichensatz *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN IF feeder name = "schacht2"
+ THEN out (""27""25"2")
+ ELSE out (""27""25"1")
+ FI
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "roman") <> 0
+ THEN is roman := TRUE ;
+ ELIF pos (material, "font1") <> 0
+ THEN is roman := FALSE ;
+ ELSE is roman := std typeface name = "roman"
+ FI;
+END PROC open document ;
+
+$openpagetosh$
+PROC open page (INT VAR x start , y start):
+
+ x start := 0;
+ IF is sheet feed
+ THEN y start := y step conversion (2.54) (* 1 Inch *)
+ ELSE y start := 0;
+ FI;
+ x rest := 0;
+ out (""13"");
+END PROC open page;
+
+$openpage$
+PROC open page (INT VAR x start , y start):
+
+ x start := 0 ;
+ y start := y step conversion (y margin) ;
+ x rest := 0;
+ out (""13"").
+END PROC open page;
+
+$openpagep5-7$
+PROC open page (INT VAR x start , y start):
+
+ x start := 0;
+ IF is sheet feed
+ THEN y start := y step conversion (8.466667e-1) (* 2/6 Inch *)
+ ELSE y start := 0;
+ FI;
+ x rest := 0;
+ out (""13"");
+END PROC open page;
+
+$close$
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+ SELECT op code OF
+ CASE 1: close document
+ CASE 2: close page (param1)
+ END SELECT.
+
+close document :
+.
+END PROC close ;
+
+$closepage$
+PROC close page (INT CONST remaining y steps) :
+ IF remaining y steps > 0
+ THEN out (""12"")
+ ELIF is sheet feed
+ THEN out (""27""25"R")
+ FI;
+END PROC close page;
+
+$closepagetosh$
+PROC close page (INT CONST remaining y steps) :
+ IF is sheet feed
+ THEN out (""12"")
+ ELIF remaining y steps > 0
+ THEN out (""12"")
+ FI;
+END PROC close page;
+
+$execute$
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE 1: write text
+ CASE 2: write cmd
+ CASE 3: carriage return
+ CASE 4: move
+ CASE 5: draw
+ CASE 6: on
+ CASE 7: off
+ CASE 8: type
+END SELECT.
+
+from : param1.
+to : param2.
+
+ write text :
+ out subtext (string, from, to).
+
+$cmdp6+$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "courier"
+ THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI;
+ ELIF buffer = "souvenir"
+ THEN IF is courier THEN is courier := FALSE; switch to souvenir FI;
+ ELIF buffer = "schwarz"
+ THEN out (""27"r0")
+ ELIF buffer = "rot"
+ THEN out (""27"r1")
+ ELIF buffer = "blau"
+ THEN out (""27"r2")
+ ELIF buffer = "violett"
+ THEN out (""27"r3")
+ ELIF buffer = "gelb"
+ THEN out (""27"r4")
+ ELIF buffer = "orange"
+ THEN out (""27"r5")
+ ELIF buffer = "grün"
+ THEN out (""27"r6")
+ ELSE out (buffer)
+ FI.
+
+$cmdp5-7$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN switch to nlq FI;
+ is nlq := TRUE;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN switch to draft FI;
+ is nlq := FALSE;
+ ELSE out (buffer);
+ FI;.
+
+$cmdlq850$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "roman"
+ THEN IF NOT is roman THEN act typeface name := "roman" ;
+ switch to roman FI;
+ ELIF buffer = "sansserif"
+ THEN IF NOT is sansserif THEN act typeface name := "sansserif";
+ switch to sansserif FI;
+ ELSE out (buffer)
+ FI.
+
+$cmdoki$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "courier"
+ THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI;
+ ELIF buffer = "kassette"
+ THEN IF is courier THEN is courier := FALSE; switch to kassette FI;
+ ELIF buffer = "schwarz"
+ THEN out (""27"r0")
+ ELIF buffer = "rot"
+ THEN out (""27"r1")
+ ELIF buffer = "blau"
+ THEN out (""27"r2")
+ ELIF buffer = "violett"
+ THEN out (""27"r3")
+ ELIF buffer = "gelb"
+ THEN out (""27"r4")
+ ELIF buffer = "orange"
+ THEN out (""27"r5")
+ ELIF buffer = "grün"
+ THEN out (""27"r6")
+ ELSE out (buffer)
+ FI.
+
+$cmdtosh$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELSE out (buffer);
+ FI;.
+
+$cmdstar$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "roman"
+ THEN IF NOT is roman THEN is roman := TRUE; switch to roman FI;
+ ELIF buffer = "font1"
+ THEN IF is roman THEN is roman := FALSE; switch to font1 FI;
+ FI.
+
+$crs$
+ carriage return :
+ x rest := 0;
+ out (""13"").
+
+$move$
+x steps : param1.
+y steps : param2.
+
+move :
+ IF x steps < 0 OR y steps < 0 THEN stop FI;
+ IF x steps > 0 THEN x move FI;
+ IF y steps > 0 THEN y move FI.
+
+$stdmove$
+x move :
+ x rest INCR x steps;
+ high := (x rest) DIV blankbreite;
+ x rest := (x rest) MOD blankbreite;
+ steps := x rest DIV 3;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF steps > 0 AND is slow
+ THEN IF is underline THEN out (" "8"") FI;
+ out (""27"Y" + code (steps) + ""0""); (* 1/360 *)
+ steps TIMESOUT ""0"";
+ x rest := x rest MOD 3
+ FI.
+
+is underline:
+ bit (modification bits,7).
+
+y move :
+ IF y steps > 0
+ THEN high := y steps DIV 255;
+ low := y steps MOD 255;
+ IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; (* 1/180 *)
+ IF low > 0 THEN out (""27"J" + code (low)) FI;
+ FI.
+
+draw :
+ IF x steps < 0 OR y steps <> 0 OR linetype <> 1
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI.
+
+x draw :
+ x rest INCR x steps ;
+ steps := x steps DIV 3 ;
+ IF steps > 0 THEN
+ x rest := x steps MOD 3 ;
+ out (""27"Y");
+ out (code (steps MOD 256));
+ out (code (steps DIV 256));
+ steps TIMESOUT ""1"";
+ FI.
+
+$movep5-7$
+ x move :
+ x rest INCR x steps;
+ IF not is underline
+ THEN simple x move
+ ELSE underline x move
+ FI;
+
+ . not is underline :
+ NOT bit (modification bits, 7)
+
+ . simple x move :
+ high := x rest DIV factor 1;
+ x rest := x rest MOD factor 1;
+ out (""27"\");
+ out (code (high MOD 256));
+ out (code (high DIV 256));
+
+ . underline x move :
+ high := x rest DIV factor 2;
+ x rest := x rest MOD factor 2;
+ IF high < blankbreite
+ THEN stop
+ ELSE low := high MOD 127;
+ high := high DIV 127;
+ IF low >= blankbreite
+ THEN low DECR blankbreite;
+ ELSE high DECR 1;
+ low DECR (blankbreite - 127);
+ FI;
+ IF high > 0
+ THEN out (""27" ");
+ out (code (127 - blankbreite));
+ high TIMESOUT " ";
+ FI;
+ out (""27" ");
+ out (code (low));
+ out (" "27" "0"");
+ FI;
+. y move:
+
+ low := y steps MOD 255;
+ high := y steps DIV 255;
+ IF high > 0 THEN high TIMESOUT (""27"J"255"") FI;
+ IF low > 0 THEN out (""27"J" + code (low)) FI;
+
+. draw :
+ IF x steps < 0 OR y steps <> 0
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI;
+
+ . x draw :
+ x rest INCR x steps;
+ steps := x rest DIV 4;
+ x rest := x rest MOD 4;
+ IF steps > 0
+ THEN low := steps MOD 256;
+ high := steps DIV 256;
+ out (""27"*"39"");
+ out (code (low));
+ out (code (high));
+ steps TIMESOUT dot;
+ FI;
+
+ . dot :
+ IF linetype = underline linetype
+ THEN ""000""000""001""
+ ELSE ""000""000""048""
+ FI.
+
+
+$onoff$
+ modification : param1
+.
+ on :
+ buffer := on string (modification);
+ IF buffer <> ""
+ THEN modification bits := modification bits OR code (buffer);
+ switch to font;
+ ELSE stop
+ FI
+
+.
+ off :
+ buffer := off string (modification);
+ IF buffer <> ""
+ THEN modification bits := modification bits XOR code (buffer);
+ switch to font;
+ ELSE stop
+ FI.
+
+$typep6+$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is courier
+ THEN switch to courier
+ ELSE switch to souvenir
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to courier :
+ out (""27"k"0"") ;
+
+. switch to souvenir :
+ out (""27"k"15"") ;
+END PROC execute;
+
+$typeplq850$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is roman
+ THEN switch to roman
+ ELSE switch to sansserif
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to roman :
+ out (""27"k"0"") ;
+
+. switch to sansserif :
+ out (""27"k"1"") ;
+END PROC execute;
+
+$typeokieps$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ vertical factor := code (buffer SUB 1);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is courier
+ THEN switch to courier
+ ELSE switch to kassette
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ IF vertical factor = 2
+ THEN out (""27"w"1"")
+ ELSE out (""27"w"0"")
+ FI;
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to courier :
+ out (""27"k"0"") ;
+
+. switch to kassette :
+ out (""27"k"127"") ;
+END PROC execute;
+
+$typep5-7$
+ type :
+ font nr := param1;
+ buffer := font string (font nr);
+ factor 1 := code (buffer SUB 1); (* 720 / Mikroschritte pro Inch mit ESC \ *)
+ factor 2 := code (buffer SUB 2); (* 720 / Mikroschritte pro Inch mit ESC Blank *)
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") DIV factor 2;
+ switch to font;
+ IF is nlq THEN switch to nlq FI;
+
+END PROC execute;
+
+
+PROC switch to font :
+
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+END PROC switch to font;
+
+
+PROC switch to nlq :
+
+ IF is pica OR is elite
+ THEN draft factor 1 := factor 1;
+ factor 1 := 4;
+ draft factor 2 := factor 2;
+ IF is pica
+ THEN factor 2 := 4 * factor 2 DIV 6;
+ blankbreite := char pitch (font nr, " ") DIV factor 2;
+ FI;
+ out (""27"x"1"");
+ ELSE out (""27"x"0"");
+ FI;
+
+END PROC switch to nlq;
+
+
+PROC switch to draft :
+
+ IF is pica OR is elite
+ THEN factor 1 := draft factor 1;
+ factor 2 := draft factor 2;
+ out (""27"x"0"");
+ FI;
+
+END PROC switch to draft;
+
+$typetosh$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+ switch to font;
+
+. switch to font :
+ INT VAR master select bits := font bits OR modification bits ;
+ IF bit (master select bits,0)
+ THEN out (""27":")
+ ELSE out (""18"")
+ FI;
+ IF bit (master select bits,1)
+ THEN out (""27"I"2""27"P"1"")
+ ELSE out (""27"P"0"")
+ FI;
+ IF bit (master select bits,2)
+ THEN out (""27""15"")
+ FI;
+ IF bit (master select bits,3)
+ THEN out (""27"E")
+ ELSE out (""27"F")
+ FI;
+ IF bit (master select bits,4)
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI;
+ IF bit (master select bits,5)
+ THEN out (""27"W"1"")
+ ELSE out (""27"W"0"")
+ FI;
+ IF bit (master select bits,6)
+ THEN
+ ELSE
+ FI;
+ IF bit (master select bits,7)
+ THEN out (""27"-"1"")
+ ELSE out (""27"-"0"")
+ FI;
+ out (font text);
+
+
+. switch to nlq :
+ out (""27"I"2"");
+
+. switch to draft :
+ out (""27"I"1"");
+
+END PROC execute;
+
+$typeokiibm$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ vertical factor := code (buffer SUB 1);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is courier
+ THEN switch to courier
+ ELSE switch to kassette
+ FI ;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+ switch to font;
+
+. switch to font :
+ INT VAR master select bits := font bits OR modification bits ;
+ IF bit (master select bits,0)
+ THEN out (""27":")
+ ELSE out (""18"")
+ FI;
+ IF bit (master select bits,1)
+ THEN out (""27"I"2""27"P"1"")
+ ELSE out (""27"P"0"")
+ FI;
+ IF bit (master select bits,2)
+ THEN out (""27""15"")
+ FI;
+ IF bit (master select bits,3)
+ THEN out (""27"E")
+ ELSE out (""27"F")
+ FI;
+ IF bit (master select bits,4)
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI;
+ IF bit (master select bits,5)
+ THEN out (""27"W"1"")
+ ELSE out (""27"W"0"")
+ FI;
+ IF bit (master select bits,6)
+ THEN out(""27"%G")
+ ELSE out(""27"%H")
+ FI;
+ IF bit (master select bits,7)
+ THEN out (""27"-"1"")
+ ELSE out (""27"-"0"")
+ FI;
+ IF vertical factor = 2
+ THEN out (""27""91""64""4""0""0""0""2""0"")
+ ELSE out (""27""91""64""4""0""0""0""1""0"")
+ FI;
+ out (font text);
+
+
+. switch to nlq :
+ out (""27"I"2"");
+
+. switch to draft :
+ out (""27"I"0"");
+
+. switch to courier :
+ out (""27"k"0"") ;
+
+. switch to kassette :
+ out (""27"k"127"") ;
+END PROC execute;
+
+$typebrother$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ vertical factor := code (buffer SUB 1);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+ switch to font;
+
+. switch to font :
+ INT VAR master select bits := font bits OR modification bits ;
+ IF bit (master select bits,0)
+ THEN out (""27":")
+ ELSE out (""18"")
+ FI;
+ IF bit (master select bits,1)
+ THEN out (""27"I"2""27"P"1"")
+ ELSE out (""27"P"0"")
+ FI;
+ IF bit (master select bits,2)
+ THEN out (""27""15"")
+ FI;
+ IF bit (master select bits,3)
+ THEN out (""27"E")
+ ELSE out (""27"F")
+ FI;
+ IF bit (master select bits,4)
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI;
+ IF bit (master select bits,5)
+ THEN out (""27"W"1"")
+ ELSE out (""27"W"0"")
+ FI;
+ IF bit (master select bits,6)
+ THEN
+ ELSE
+ FI;
+ IF bit (master select bits,7)
+ THEN out (""27"-"1"")
+ ELSE out (""27"-"0"")
+ FI;
+ IF vertical factor = 2
+ THEN out (""27""91""64""4""0""0""0""2""0"")
+ ELSE out (""27""91""64""4""0""0""0""1""0"")
+ FI;
+ out (font text);
+
+. switch to nlq :
+ out (""27"I"2"");
+
+. switch to draft :
+ out (""27"I"0"");
+
+END PROC execute;
+
+$typestar$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is roman
+ THEN switch to roman
+ ELSE switch to font1
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to roman :
+ out (""27"k"0"") ;
+
+. switch to font1 :
+ out (""27"k"1"") ;
+END PROC execute;
+
+
+
+$printerlq1500$
+PACKET printer driver
+
+(**************************************************************************)
+(* Stand : 29.07.86 *)
+(* EPSON LQ-1500 Version : 4 *)
+(* Autor : Rudolf Ruland *)
+(* geändert am 15.12.88 hjh *)
+(**************************************************************************)
+
+ DEFINES printer,
+ open,
+ close,
+ execute,
+
+ paper size,
+ std quality:
+
+LET
+(* underline = 1,
+ bold = 2,
+ italics = 4,
+ reverse = 8, *)
+
+ underline linetype = 1,
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1,
+ c write cmd = 2,
+ c carriage return = 3,
+ c move = 4,
+ c draw = 5,
+ c on = 6,
+ c off = 7,
+ c type = 8;
+
+INT VAR rest, high, low, factor;
+BOOL VAR is nlq, factor was 6, condensed;
+REAL VAR x size, y size;
+TEXT VAR std quality name, buffer;
+
+(*********************************************************************)
+
+paper size (13.6 * 2.54, 12.0 * 2.54);
+std quality ("draft");
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+
+PROC std quality (TEXT CONST quality) :
+
+ IF quality = "nlq" OR quality = "draft"
+ THEN std quality name := quality;
+ ELSE errorstop ("unzulaessige Betriebsart")
+ FI;
+
+END PROC std quality;
+
+TEXT PROC std quality : std quality name END PROC std quality;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ factor := 0;
+ factor was 6 := FALSE;
+ condensed := FALSE;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ y steps := (y steps DIV 30) * 30;
+ out (""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* Amerikanischer Zeichensatz *)
+ out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ x start := 0;
+ y start := 0;
+ rest := 0;
+ out (""13"");
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+END SELECT;
+
+.
+ close document :
+
+
+. remaining y steps : param1
+.
+ close page :
+ IF remaining y steps > 0 THEN out (""12"") FI
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ out subtext (string, from, to)
+
+.
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN is nlq := TRUE;
+ near letter quality;
+ ELIF buffer = "draft"
+ THEN is nlq := FALSE;
+ draft quality;
+ ELSE out (buffer);
+ FI;
+
+ . near letter quality :
+ IF factor = 6
+ THEN factor was 6 := TRUE;
+ factor := 4;
+ ELSE factor was 6 := FALSE;
+ FI;
+ IF condensed
+ THEN out (""27"x"0"")
+ ELSE out (""27"x"1"")
+ FI;
+
+ . draft quality :
+ IF factor was 6
+ THEN factor was 6 := FALSE;
+ factor := 6;
+ FI;
+ out (""27"x"0"");
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ rest := 0;
+ out (""13"");
+
+
+. x steps : param1
+. y steps : param2
+.
+ move :
+ IF x steps < 0 OR y steps < 0
+ THEN stop
+ ELIF x steps > 0
+ THEN x move
+ ELIF y steps > 0
+ THEN y move
+ FI;
+
+ . x move :
+ high := (x steps + rest) DIV factor;
+ rest := (x steps + rest) MOD factor;
+ out (""27"\");
+ out (code (high MOD 256));
+ out (code (high DIV 256));
+
+ . y move :
+ high := y steps DIV 255;
+ low := y steps MOD 255;
+ IF high > 0 THEN high TIMESOUT ""27"J"255"" FI;
+ IF low > 0 THEN out (""27"J"); out (code (low)) FI;
+
+.
+ draw :
+ IF x steps < 0 OR y steps <> 0 OR linetype <> underline linetype
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI;
+
+ . x draw :
+ high := (x steps + rest) DIV 6;
+ rest := (x steps + rest) MOD 6;
+ IF high > 0
+ THEN low := high MOD 255;
+ high := high DIV 255;
+ out (""27"V");
+ out (code (low));
+ out (""27"*"1""1""0""1""27"V"0"");
+ FOR low FROM 1 UPTO high
+ REP out (""27"V"255""27"*"1""1""0""1""27"V"0"") PER;
+ FI;
+
+
+. modification : param1
+.
+ on :
+ IF on string (modification) <> ""
+ THEN out (on string (modification))
+ ELSE stop
+ FI
+
+.
+ off :
+ IF off string (modification) <> ""
+ THEN out (off string (modification))
+ ELSE stop
+ FI
+
+
+. font nr : param1
+.
+ type :
+ buffer := font string (font nr);
+ out (buffer);
+ factor := pitch factor;
+ IF is nlq THEN near letter quality FI;
+
+ . pitch factor : (* Mikroschritt *)
+ INT CONST font bits := code (buffer SUB 3);
+ IF bit (font bits, 1)
+ THEN condensed := FALSE; 2 (* proportional 1/360 Inch *)
+ ELIF pos (buffer, ""27"x"1"") <> 0
+ THEN condensed := FALSE; 4 (* near letter 1/180 Inch *)
+ ELIF bit (font bits, 2)
+ THEN condensed := TRUE; 3 (* condensed 1/240 Inch *)
+ ELIF bit (font bits, 0)
+ THEN condensed := FALSE; 4 (* elite 1/180 Inch *)
+ ELSE condensed := FALSE; 6 (* pica 1/120 Inch *)
+ FI
+
+END PROC execute;
+
+
+$end$
+INT VAR reply; DATASPACE VAR ds; FILE VAR file;
+
+PROC printer:
+
+ disable stop;
+ continue (server channel);
+ check error (error message);
+ ds := nilspace;
+ REP forget (ds);
+ execute print;
+ IF is error AND online THEN put error; clear error; FI;
+ PER;
+END PROC printer;
+
+PROC execute print:
+
+ LET ack = 0, fetch code = 11, file type = 1003;
+ enable stop;
+ ds := nilspace;
+ call (father, fetch code, ds, reply);
+ IF reply = ack CAND type (ds) = file type
+ THEN file := sequential file (input, ds);
+ print (file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+END PROC execute print;
+
+PROC check error(TEXT CONST message):
+
+ IF is error
+ THEN clear error; rename myself (message);
+ IF is error THEN end(myself) FI;
+ pause (9000); end(myself);
+ FI;
+END PROC check error;
+
+END PACKET printerdriver
+
+
diff --git a/system/printer-24nadel/0.9/src/printer.24.nadel b/system/printer-24nadel/0.9/src/printer.24.nadel
new file mode 100644
index 0000000..579f67f
--- /dev/null
+++ b/system/printer-24nadel/0.9/src/printer.24.nadel
@@ -0,0 +1,776 @@
+
+(*************************************************************************)
+(* Installationsprogramm für Stand : 3. 1.89 *)
+(* 24-Nadel Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+PACKET driver inst 24
+
+
+ DEFINES treiber einrichten:
+
+
+LET up = ""3""13""5"",
+
+ generator name = "printer.24.nadel",
+
+ description file name = "beschreibungen24",
+ module file name = "module24";
+
+
+INT VAR pr channel,
+ quality,
+ paper format number,
+ service option;
+TEXT VAR fonttab name :: "",
+ driver name :: "";
+TEXT VAR inp;
+BOOL VAR was esc;
+
+treiber einrichten
+
+PROC treiber einrichten:
+
+ treiber einrichten (0)
+END PROC treiber einrichten;
+
+PROC treiber einrichten (INT CONST service opt):
+
+ ask for print channel;
+ main menu;
+ IF installed
+ THEN generate printer spool
+ ELSE inform about restart
+ FI.
+
+ ask for printchannel:
+ inits;
+ page;
+ headline ("Druckerkanal - Einstellung");
+ cursor (1, 15);
+ putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit");
+ putline (" 'serverchannel (Kanalnummer)' in der Task """ +
+ name (myself) + """");
+ putline (" verändert werden.");
+ REP
+ cursor (1, 10);
+ put (""5"EUMEL-Kanalnummer des Druckerkanals:");
+ get (pr channel);
+ disable stop;
+ serverchannel (pr channel);
+ BOOL VAR no error :: NOT is error;
+ IF is error
+ THEN cursor (1, 7);
+ put error;
+ putline ("Eingabe korrigiert wiederholen!")
+ FI;
+ clear error;
+ enable stop
+ UNTIL no error PER.
+
+ inits:
+ line;
+ IF single task
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+ FI;
+ command dialogue (TRUE);
+ IF name (myself) <> "PRINTER"
+ THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ +
+ name (myself) + """ !");
+ IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?")
+ THEN rename myself ("PRINTER")
+ FI
+ FI;
+ INT VAR choice;
+ service option := service opt.
+
+ single task: (pcb (9) AND 255) = 1.
+
+ main menu:
+ BOOL VAR installed :: FALSE;
+ REP
+ show main menu;
+ get choice;
+ treat choice
+ UNTIL was esc OR installed PER.
+
+ show main menu:
+ page;
+ headline("Hauptmenü 24-Nadel-Drucker");
+ putline (" 1. Brother");
+ putline (" 2. Epson");
+ putline (" 3. NEC");
+ putline (" 4. OKI");
+ putline (" 5. Toshiba").
+
+ get choice:
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Installation abbrechen");
+ ask user (5).
+
+ treat choice:
+ SELECT int (inp) OF
+ CASE 1: brother menu
+ CASE 2: epson menu
+ CASE 3: nec menu
+ CASE 4: oki menu
+ CASE 5: toshiba menu
+ END SELECT.
+
+
+ brother menu:
+ page;
+ headline ("brother - Menü");
+ putline (" 1. M-1724 L");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ brother m1724l inst
+ FI.
+
+ brother m1724l inst:
+ putline ("brother M-1724 L");
+ line;
+ putline ("Wählen Sie folgende DIP-Schalter Optionen:");
+ putline ("Emulationsmodus IBM Proprinter XL ");
+ putline ("Automatischer Zeilenvorschub Nein ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.brother");
+ generate ("brotherm1724l");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ toshiba menu:
+ page;
+ headline ("TOSHIBA - Menü");
+ putline (" 1. P 321");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ toshiba p321 inst
+ FI.
+
+ toshiba p321 inst:
+ putline ("TOSHIBA P 321");
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S3-8 S3-7 S3-5 übrige Schalter");
+ putline ("OFF OFF *) egal ");
+ putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug");
+ show control options ("std speed, paper feed");
+ show material options("slow, fast");
+ show command options ("nlq, draft");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.toshiba.p321");
+ generate ("toshp321");
+ adjust papersize;
+ adjust quality;
+ do ("papersize(21.0,30.48)");
+ installed := TRUE;
+ FI.
+
+
+ epson menu:
+ page;
+ headline ("Epson - Menü");
+ putline (" 1. LQ 850");
+ putline (" 2. LQ 1050");
+ putline (" 3. LQ 1500");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (3);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : lq850 inst
+ CASE 2 : lq850 inst
+ CASE 3 : lq1500 inst
+ END SELECT
+ FI.
+
+ lq850 inst:
+ IF choice = 1
+ THEN putline ("Epson LQ 850")
+ ELSE putline ("Epson LQ 1050")
+ FI;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8");
+ putline ("egal egal egal egal egal egal *1) OFF ");
+ putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line;
+ putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8");
+ putline ("egal egal *2) OFF OFF");
+ putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle ");
+ putline (" gesetzt werden (Druckerhandbuch)");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, roman, sansserif");
+ show command options ("draft, nlq, roman, sansserif");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq850");
+ generate ("epsonlq850");
+ adjust quality;
+ adjust papersize;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ lq1500 inst:
+ putline ("EPSON LQ-1500");
+ show control options ("");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq1500");
+ generate ("epsonlq1500");
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ nec menu:
+ page;
+ headline ("NEC - Menü");
+ putline (" 1. PINWRITER P5 ");
+ putline (" 2. PINWRITER P6 ");
+ putline (" 3. PINWRITER P7 ");
+ putline (" 4. PINWRITER P6 PLUS");
+ putline (" 5. PINWRITER P7 PLUS");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (5);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : necp5p7 inst
+ CASE 2 : necp6 inst
+ CASE 3 : necp5p7 inst
+ CASE 4 : necp6plus inst
+ CASE 5 : necp6plus inst
+ END SELECT
+ FI.
+
+ necp5p7 inst:
+ IF choice = 1
+ THEN putline ("NEC PINWRITER P5")
+ ELSE putline ("NEC PINWRITER P7")
+ FI;
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp5p7");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6 inst:
+ putline ("NEC PINWRITER P6 ");
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp6");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6plus inst:
+ IF choice = 4
+ THEN putline ("NEC PINWRITER P6 PLUS")
+ ELSE putline ("NEC PINWRITER P7 PLUS")
+ FI;
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("CR FUNCTION CR ONLY ");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, courier, souvenir");
+ show command options ("draft, nlq, courier, souvenir");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p6+");
+ generate ("necp6+");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE;
+ IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI;
+ FI.
+
+ oki menu:
+ page;
+ headline ("OKI - Menü");
+ putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel");
+ putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel");
+ putline (" 3. MICROLINE 393/393C EPSON-kompatibel");
+ putline (" 4. MICROLINE 393/393C IBM-kompatibel");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (4);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : oki ml390 inst
+ CASE 2 : oki ml390 inst
+ CASE 3 : oki ml393eps inst
+ CASE 4 : oki ml393ibm inst
+ END SELECT
+ FI.
+
+ oki ml390 inst:
+ IF choice = 1
+ THEN putline ("OKI Microline 390") ;
+ ELSE putline ("OKI Microline 391") ;
+ FI;
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE EPSON LQ ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki390/391");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ oki ml393eps inst:
+ putline ("OKI Microline 393 EPSON-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Ceps");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ oki ml393ibm inst:
+ putline ("OKI Microline 393 IBM-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE ASCII ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Cibm");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+
+
+generate printer spool:
+ IF service opt = 0
+ THEN forget (generator name, quiet);
+ forget (driver name, quiet)
+ FI;
+ eumel must advertise;
+ cursor (1, 10);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (2);
+ putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer");
+ putline (" Drucker eingesetzt werden soll.");
+ line (2);
+ put ("Generierung beendet, weiter mit 'SV'");
+ break (quiet);
+ do ("spool manager (PROC printer)").
+
+ inform about restart:
+ page;
+ putline ("Es ist kein Druckertreiber installiert worden!");
+ line;
+ putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline ("mit 'treiber einrichten' erneut aufgerufen werden.");
+ line.
+
+END PROC treiber einrichten;
+
+PROC headline (TEXT CONST header):
+
+ cursor (13,1);
+ putline ("E U M E L - Druckertreiber - Installations - Programm");
+ cursor (40 - LENGTH header DIV 2, 2);
+ put (header);
+ line (2)
+END PROC headline;
+
+PROC ask user (INT CONST max choice):
+
+ TEXT VAR exit;
+ inp := "";
+ REP
+ cursor (1,23);
+ IF inp = ""
+ THEN put ("Ihre Wahl (Nummer eingeben):")
+ ELSE put ("FEHLER! Eingabe korrigieren:")
+ FI;
+ editget (inp, ""27"", "", exit);
+ was esc := exit = ""27"";
+ UNTIL was esc OR ok PER.
+
+ ok:
+ int (inp) > 0 AND int (inp) <= max choice AND last conversion ok.
+END PROC ask user;
+
+PROC show control options (TEXT CONST options):
+
+ line;
+ putline ("Steuerprozeduren in der Task """ + name (myself) + """:");
+ write ("papersize, std quality");
+ IF options <> ""
+ THEN put (",");
+ putline (options)
+ FI
+END PROC show control options;
+
+PROC show material options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche Materialwerte (#material(""..."")#):");
+ putline (options)
+END PROC show material options;
+
+PROC show command options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche direkte Druckeranweisungen (#""...""#):");
+ putline (options)
+END PROC show command options;
+
+PROC ask for quality:
+
+ line (1);
+ putline ("Standard - Druckqualität:");
+ line;
+ REP out (up);
+ IF yes ("Draft Quality (schneller, aber nicht so schön)")
+ THEN quality := 1; LEAVE ask for quality
+ FI;
+ out (up);
+ IF yes ("Near Letter Quality (schöner, aber langsamer)")
+ THEN quality := 2; LEAVE ask for quality
+ FI;
+ PER
+END PROC ask for quality;
+
+PROC adjust quality:
+
+ IF quality = 1
+ THEN do ("std quality (""draft"")")
+ ELSE do ("std quality (""nlq"")")
+ FI
+END PROC adjust quality;
+
+PROC ask for papersize :
+LET up = ""3""13""5"";
+
+ paper format number := paper format ;
+
+ . paper format :
+ line (1);
+ putline ("Papierformat:");
+ line;
+ REP out (up);
+ IF yes ("Endlospapier, 8 Zoll breit")
+ THEN LEAVE paper format WITH 1 FI;
+ out (up);
+ IF yes ("Endlospapier, 13.2 Zoll breit")
+ THEN LEAVE paper format WITH 2 FI;
+ out (up);
+ IF yes ("Einzelblatteinzug, DINA 4")
+ THEN LEAVE paper format WITH 3 FI;
+ PER;
+ 0
+END PROC ask for papersize;
+
+
+PROC adjust papersize:
+
+ SELECT paper format number OF
+ CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 3 : do("papersize (21.0, 29.7)");
+ do ("paper feed (""sheet"")")
+ END SELECT
+
+END PROC adjust papersize;
+
+BOOL PROC all right:
+
+ line (3);
+ cursor (1,23);
+ yes ("Soll der ausgewählte Druckertreiber installiert werden")
+END PROC all right;
+
+PROC get fonttable (TEXT CONST name):
+
+ fonttab name := name;
+ from archive ((description file name & module file name & fonttab name)
+ - all);
+ fonttable (fonttab name);
+ command dialogue (FALSE);
+ save (fonttab name, /"configurator");
+ IF service option = 0
+ THEN forget (fonttab name)
+ FI;
+ command dialogue (TRUE);
+END PROC get fonttable;
+
+PROC from archive (THESAURUS CONST files):
+
+ IF highest entry (files) > 0
+ THEN fetch from archive;
+ release (archive);
+ putline ("Archiv abgemeldet !")
+ FI.
+
+ fetch from archive:
+ THESAURUS VAR thes :: files;
+ REP
+ ask for archive;
+ reserve archive;
+ fetch (thes / ALL archive, archive);
+ thes := thes - all
+ UNTIL highest entry (thes) = 0 PER.
+
+ask for archive:
+ line;
+ putline ("Bitte Archiv mit den Dateien");
+ TEXT VAR buffer;
+ INT VAR index :: 0;
+ REP
+ get (thes, buffer, index);
+ putline (" " + buffer)
+ UNTIL index = 0 PER;
+ putline ("einlegen !");
+ line;
+ putline ("Wenn eingelegt: Taste drücken !");
+ inchar (buffer).
+
+reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop.
+
+END PROC from archive;
+
+THESAURUS OP & (TEXT CONST left, right):
+ THESAURUS VAR result := empty thesaurus;
+ insert (result, left);
+ insert (result, right);
+ result
+END OP &;
+
+THESAURUS OP & (THESAURUS CONST left, TEXT CONST right):
+ THESAURUS VAR result := left;
+ insert (result, right);
+ result
+END OP &;
+
+PROC generate (TEXT CONST name):
+
+ open files;
+ read description;
+ build programme;
+ insert programme;
+ forget files.
+
+ open files:
+ line (5);
+ cursor (1, 20);
+ putline (""4"Bitte warten !");
+ putline (" - Der Treiber wird generiert.");
+ driver name := "printer." + name + "(generiert)";
+ IF exists (driver name)
+ THEN forget (driver name, quiet)
+ FI;
+ FILE VAR des file :: sequential file (modify, description file name),
+ mod file :: sequential file (modify, module file name),
+ driver file :: sequential file (output, driver name).
+
+ read description:
+ to line (des file, 1);
+ col (des file, 1);
+ downety (des file, "$" + name + "$");
+ IF eof (des file)
+ THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" +
+ "Descriptions-File enthalten")
+ FI;
+ TEXT VAR description :: "",
+ record;
+ BOOL VAR done :: FALSE;
+ read record (des file, record);
+ record := subtext (record, col (des file) + LENGTH name + 2);
+ WHILE NOT eof (des file) AND NOT done REP
+ treat record
+ PER.
+
+ treat record:
+ INT VAR dollar pos :: pos (record, "$");
+ IF dollar pos = 0
+ THEN description CAT compress (record);
+ down (des file);
+ read record (des file, record)
+ ELSE description CAT compress (subtext (record, 1, dollar pos - 1));
+ col (des file, dollar pos);
+ done := TRUE;
+ FI.
+
+ build programme:
+ get module name;
+ WHILE still modules REP
+ find module;
+ transfer module;
+ get module name
+ PER.
+
+ get module name:
+ INT VAR semicol pos :: pos (description, ";");
+ TEXT VAR module name;
+ IF semicol pos > 0
+ THEN module name := subtext (description, 1, semicol pos - 1);
+ description := subtext (description, semicol pos + 1)
+ ELSE module name := description;
+ description := ""
+ FI.
+
+ still modules:
+ module name <> "" OR description <> "".
+
+ find module:
+ to line (mod file, 1);
+ col (mod file, 1);
+ downety (mod file, "$" + module name + "$");
+ IF eof (mod file)
+ THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" +
+ "Modul-File enthalten")
+ FI.
+
+ transfer module:
+ done := FALSE;
+ read record (mod file, record);
+ record := subtext (record, col (mod file) + LENGTH module name + 2);
+ WHILE NOT eof (mod file) AND NOT done REP
+ transfer record
+ PER.
+
+ transfer record:
+ dollar pos := pos (record, "$");
+ IF dollar pos = 0
+ THEN write (driver file, compress (record));
+ line (driver file);
+ down (mod file);
+ read record (mod file, record)
+ ELSE write (driver file, compress (subtext (record, 1,
+ dollar pos - 1)));
+ col (mod file, dollar pos);
+ done := TRUE;
+ cout (line no (mod file))
+ FI.
+
+ insert programme:
+ IF online
+ THEN putline (" - Der Treiber wird insertiert.")
+ FI;
+ check off;
+ insert (driver name).
+
+ forget files:
+ IF service option = 0
+ THEN forget (description file name, quiet);
+ forget (module file name, quiet)
+ FI .
+END PROC generate;
+
+END PACKET driver inst 24
+
diff --git a/system/printer-24nadel/schulis-mathe-1.0/doc/readme b/system/printer-24nadel/schulis-mathe-1.0/doc/readme
new file mode 100644
index 0000000..d526aa3
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/doc/readme
@@ -0,0 +1,320 @@
+#type("nlq10")##limit(18.0)##start(1.5,1.0)#
+#head#
+Treiber-Installations-Programm #right#Seite %
+für 24-Nadel-Matrixdrucker #right#23.12.1988
+
+
+#end#
+#on("u")#Dokumentation zum Treiber-Installations-Programm für 24-Nadel-
+Matrixdrucker#off("u")#
+
+#on("u")#Inhalt:#off("u")#
+
+1. Installations- und Gebrauchsanleitung
+2. Druckertreiber-Auswahl
+3. Steuerungsmöglichkeiten und Spezialfeatures
+4. Weitere Hinweise
+
+
+#on("b")#1. Installations- und Gebrauchsanleitung#off("b")#
+
+#on("u")#Einrichten#off("u")#
+So wird das Treiber-Installationsprogramm eingerichtet:
+
+ SV drücken
+
+ nach 'gib supervisor kommando:'
+
+ begin("PRINTER","SYSUR")
+
+ in der Task "PRINTER" (nach 'gib kommando'):
+
+ archive ("std.printer")
+ fetch ("printer.24.nadel",archive)
+ check off
+ insert ("printer.24.nadel")
+
+Das Programm wird dann insertiert.
+
+#on("u")#Druckerkanal#off("u")#
+Hiernach wird die Kanalnummer des Druckers erfragt. Wenn der Drucker
+über Parallelschnittstelle betrieben wird, ist die Kanalnummer
+meistens 15.
+
+#on("u")#Menüsystem#off("u")#
+Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern.
+Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste
+der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier
+den passenden Typ aus!
+Das Installationsprogramm zeigt nun einige Informationen zu dem ange­
+wählten Drucker. Besonders zu beachten sind hierbei #on("u")#Angaben zur Konfi­
+guration des Druckers#off("u")# (z.B. DIP-Schalter). Der Drucker muß unbedingt
+wie angegeben konfiguriert werden, wenn er mit dem ausgewählten Trei­
+ber betrieben werden soll.
+
+Hinweise zu Konfigurationsangaben:
+1. Die Angabe 'egal' bedeutet, daß die Einstellung für die Funktion
+ des Treibers keine Bedeutung hat. Dennoch solte der Anwender darauf
+ achten, welche Funktion die Schalter haben (Druckerhandbuch!). So
+ ist es zum Beispiel immer empfehlenswert, den Papierende-Sensor zu
+ aktivieren, damit der Drucker nach Papierende nicht auf der Walze
+ weiterdruckt.
+2. Die Konfigurationsangaben beziehen sich immer auf genau den ausge­
+ wählten Druckertyp. Wenn Sie den Treiber mit einem anderen Drucker
+ als den ausgewählten verwenden, dann beachten Sie folgende Regeln
+ für die Konfiguration:
+ - Der Drucker muß auf eine passende Emulation konfiguriert werden.
+ - Der Drucker darf bei einem Carriage Return (Code 13) keinen Zei­
+ lenvorschub durchführen.
+ - Der Drucker darf die Perforation #on("u")#nicht#off("u")# automatisch überspringen.
+
+ - Auf Seitenlängen und internationale Zeichensätze müssen Sie nicht
+ achten.
+
+(Hinweise zur Auswahl des richtigen Treibers gibt Abschnitt 2)
+
+Nach den Konfigurationsangaben werden Steuerungsmöglichkeiten des
+ausgewählten Treibers angezeigt. (Siehe hierzu Abschnitt 3)
+
+Falls der Treiber bestimmte grundsätzliche Betriebsmöglichkeiten er­
+laubt (z.B. DRAFT/NLQ, Einzelblatteinzug), werden Sie danach gefragt,
+welche Möglichkeit standardmäßig gewählt werden soll. diese Vorein­
+stellungen können nachträglich in der Task "PRINTER" mit den entspre­
+chenden Steuerprozeduren neu gesetzt werden. Außerdem können bestimmte
+Einstellungen noch für jedes einzelne Dokument (d.h. für jede Druck­
+datei) gewählt ('material'-Anweisung) oder sogar innerhalb eines Doku­
+ments verändert werden (direkte Druckeranweisung \#"..."\#).
+Über die Steuerungsmöglichkeiten informiert Abschnitt 3 ausführlicher.
+
+
+#on("b")#2. Druckertreiber-Auswahl#off("b")#
+
+#on("u")#Verwendung nicht im Menü enthaltener Drucker#off("u")#
+Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden, soll­
+ten Sie zunächst versuchen, ob ein Treiber für einen anderen Drucker
+des gleichen Herstellers mit Ihrem Drucker korrekt arbeitet.
+Falls dies nicht funktioniert oder der Hersteller überhaupt nicht im
+Menü erscheint, müssen Sie herausfinden (Druckerhandbuch, -händler!),
+welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist.
+(Viele Drucker verfügen über EPSON LQ-1000 oder IBM Grafikdrucker bzw.
+Proprinter-Eumulationen.)
+Eine der beiden Anpassungen 'EPSON LQ-1050' oder 'OKI ML-393
+IBM-kompatibel' müßte immer einen (Minimal-) Betrieb ermöglichen (wobei die
+Verwendung der Proportionalschrift bzw. der doppelt hohen Schriften u. U.
+nicht funktioniert).
+
+
+#on("b")#3. Steuerungsmöglichkeiten und Spezialfeatures#off("b")#
+
+Einige Treiber bieten bestimmte Einstellungsmöglichkeiten (z.B.
+DRAFT/NLQ) und/oder Spezialfeatures (z.B. Farbdruck).
+Die Einstellungen können über
+- Steuerprozeduren
+- Materialanweisungen bzw.
+- direkte Druckeranweisungen
+vorgenommen werden.
+
+#on("u")#Steuerprozeduren#off("u")#
+setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten
+sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER")
+aufgerufen werden. #on("b")#Gültig werden die Änderungen erst, wenn danach in
+der Druckspooltask das Kommando 'start' gegeben wird!#off("b")#
+
+PROC papersize (REAL CONST breite, länge)
+ Dient zur Einstellung der Größe der physikalisch beschreibbaren
+ Fläche.
+ Beispiel: papersize (20.32, 30.48)
+ (Standardeinstellung für Endlospapier 8 Zoll breit und
+ 12 Zoll lang)
+
+PROC papersize
+ Informationsprozedur
+
+PROC top margin (REAL CONST margin)
+ Falls der Drucker es nicht erlaubt, direkt am Blattanfang zu druk­
+ ken (zum Beispiel wegen eines Einzelblatteinzugs), muß mit dieser
+ Prozedur die Länge des oberen Randes, den der Drucker nicht be­
+ drucken kann, in cm angegeben werden.
+ Beispiel: top margin (2.0)
+ (Teilt dem Druckertreiber mit, daß die ersten 2 cm
+ nicht bedruckbar sind.)
+
+REAL PROC top margin
+ Informationsprozedur
+
+PROC std speed (TEXT CONST speed)
+ Parameter: slow, fast
+ Wahl zwischen Positionierung in Mikroschritten (slow) oder in
+ Blanks (fast).
+ Beispiel: std speed ("slow")
+
+TEXR PROC std speed
+ Informationsprozedur
+
+PROC std quality (TEXT CONST quality)
+ übliche Parameter: draft, nlq
+ Wahl zwischen Datenverarbeitungs-Qualität und Schönschrift-
+ Qualität
+ Beispiel: std quality ("draft")
+
+TEXT PROC std quality
+ Informationsprozedur
+
+PROC std typeface (TEXT CONST typeface)
+ übliche Parameter: roman, sansserif, courier
+ Wahl zwischen verschiedenen NLQ-Schriftarten (nur sichtbar im
+ NLQ-Modus, das heißt 'std typeface' schaltet nicht auf NLQ).
+ Beispiel: std typeface ("roman")
+
+TEXT PROC std typeface
+ Informationsprozedur
+
+PROC paper feed (TEXT CONST name)
+ übliche Parameter: tractor, sheet, schacht1, schacht2
+ Wählt Endlospapier oder Einzelblatteinzug und ggf. Schachtnummer.
+ Beispiel: paper feed ("sheet")
+
+TEXT PROC paper feed
+ Informationsprozedur
+
+
+#on("u")#Materialanweisungen \#material("...")\##off("u")#
+müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und
+setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben
+für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge­
+stellten Standardwerten. Diese werden durch die Materialanweisung aber
+nicht geändert.)
+
+Beispiel: \#material("nlq")\#
+ sorgt bei entsprechendem Treiber dafür, daß das gesamte
+ Dokument in Schönschrift-Qualität ausgedruckt wird, egal
+ wie 'std quality' eingestellt ist.
+
+#on("b")#Es darf in einer Datei nur eine Materialanweisung stehen!#off("b")# Sollen meh­
+rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung
+erscheinen. Beispiel: \#material("sheet;draft")\#
+
+
+#on("u")#direkte Druckeranweisungen \#"..."\##off("u")#
+gelten ab der Position, an der sie in der Datei auftreten. Sie haben
+(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und
+Materialeinstellungen.
+
+Beispiel: \#"draft"\#
+ schaltet (bei entsprechendem Treiber) auf Datenverar­
+ beitungs-Qualität, egal welche Standardeinstellung vorliegt
+ und welche Materialanweisung gegeben wurde.
+
+#on("b")#In einer Druckeranweisung darf nur eine Einstellung vorgenommen
+werden.#off("b")# Also: \#"nlq"\#\#"sansserif"\#
+
+
+#on("u")#Wichtig#off("u")#
+- Achten Sie bei Materialanweisungen und direkten Druckeranweisungen
+ besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben
+ berücksichtigt! Also: \#"nlq"\# und keinesfalls \#"NLQ"\#!!!
+- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und
+ nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann
+ daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse
+ erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen
+ Reihenfolge an den Drucker sendet, als er in der Datei steht, die
+ mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B.
+ für beide Spalten) unerwünscht erhalten bleibt.
+
+
+#on("u")#Tabelle#off("u")#
+Die Tabelle soll einen Anhaltspunkt dafür geben, wie welche Einstel­
+lungen erfolgen können.
+
+#type("17")#
+ Steuerprozeduren Materialanweisungen direkte Druckeranweisungen
+
+#on("u")#                                                                                          #off("u")#
+
+Positionierung std speed slow, fast ------
+ slow, fast
+
+Qualität std quality z.B. draft, nlq z.B. draft, nlq
+ z.B. draft, nlq
+
+Schriftart std typeface z.B. roman, z.B. roman,
+(nur bei NLQ) z.B. roman, sansserif, courier sansserif, courier
+ sansserif, courier
+
+Einzelblatt- paper feed z.B. schacht1, z.B. schacht1,
+einzug z.B. tractor, schacht2 schacht2
+ sheet,
+ schacht1, schacht2
+
+Farbdruck ------ ------ z.B. schwarz,
+ rot, blau,
+ violett, gelb
+ orange, grün
+
+
+
+#type("nlq10")##on("b")#4. Weitere Hinweise#off("b")#
+
+#on("u")#Zeichensatzänderungen gegenüber früheren Versionen#off("u")#
+In den Fonttabellen früherer Druckertreiber-Versionen wurden oberhalb
+des Codes 127 einige internationale Zeichen zur Verfügung gestellt
+(und zwar in Anlehnung an den Agfa-Laserdrucker-Zeichensatz).
+Bei den Treibern der vorliegenden Version gilt folgendes:
+- Wie bisher wird der volle im Benutzerhandbuch festgelegte EUMEL-
+ Zeichensatz (sofern möglich) unterstützt.
+- Der Code 252 liefert das Paragraphzeichen.
+- Alle übrigen (vom EUMEL-Zeichensatz nicht definierten) Zeichencodes
+ oberhalb 127 liefern, sofern möglich, die entsprechenden Zeichen des
+ IBM-Grafikzeichensatzes.
+
+
+#on("u")#Hinweis zu Proportionalschriften#off("u")#
+Bei Proportionalschriften kann die Modifikation \#on("i")\# zu Problemen
+führen (z.B. beim Blocksatz), wenn die kursiven Zeichen andere
+Proportionalbreiten haben.
+
+#on("u")#Hinweis zur Modifikation on/off("b") bzw. on/off("r")#off("u")#
+Die meisten 24-Nadel Drucker verfügen sowohl über einen horizontalen als
+auch über einen vertikalen Schattendruck. Diese beiden Druckarten können
+mit der Modifikation on("b") (bold) bzw. on("r") (eigentlich für reverse
+gedacht) eingeschaltet werden.
+
+#on("u")#Hinweis zur Benutzung von Einzelblatteinzügen#off("u")#
+Bei der Benutzung von Einzelblatteinzügen müssen folgende Einstel­
+lungen vorgenommen werden (vgl. auch Abschnitt 3!):
+
+ Am Drucker:
+1. Sie müssen Ihren Drucker auf die Option Einzelblatteinzug
+ schalten (siehe Druckerhandbuch!).
+
+ In der Druckspooltask (meist 'PRINTER'):
+2. Falls der Druckertreiber die Steuerprozedur 'paper feed' zur Verfü­
+ gung stellt, müssen Sie mit 'paperfeed ("sheet")' oder (für
+ 2-Schacht-Einzüge) mit 'paperfeed ("schacht1")' bzw. 'paperfeed
+ ("schacht2")' den Druckertreiber auf Einzelblatteinzug umschalten.
+3. Falls Sie eine andere Papierlänge als 12 Zoll (=30.48 cm) verwen­
+ den, müssen Sie die neuen Papiermaße mit 'papersize' in cm einstel­
+ len.
+ Beispiel: papersize (21.0, 29.7)
+ (für DIN A4-Blätter)
+4. Falls der Drucker mit dem Einzelblatteinzug nicht direkt am Blatt­
+ anfang drucken kann, sondern ein gewisser oberer Rand bleibt, muß
+ mit 'top margin' die Länge des nicht bedruckbaren Randes in cm dem
+ Druckertreiber mitgeteilt werden.
+ Beispiel: top margin (1.5)
+ (Wie groß der obere Rand ist, kann festgestellt werden, indem eine
+ Datei mit \#start(0.0,0.0)\# ausgedruckt wird.)
+
+ Wurde mit 'top margin' dem Treiber die Größe der nicht bedruckbaren
+ Fläche mitgeteilt, so ist darauf zu achten, daß in den Druckdateien
+ ein genügend großer y-Wert für die Startposition eingestellt wird
+ ('start'-Anweisung). Andernfalls kommt es bei der Ausgabe in der
+ ersten Zeile zu Überschreibungen.
+
+
+#on("b")#5. Die Änderungen, die Sie in der Druckspooltask vorgenommen haben
+ werden erst wirksam, wenn das Spool-Kommando 'start' gegeben wird.#off("b")#
+
+
+
+
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/beschreibungen24 b/system/printer-24nadel/schulis-mathe-1.0/src/beschreibungen24
new file mode 100644
index 0000000..e3d2fa9
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/beschreibungen24
@@ -0,0 +1,62 @@
+
+(*************************************************************************)
+(* Stand : 3. 1.89 *)
+(* Beschreibungen-Datei für 24-Nadel-Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+$necp5p7$
+begin;headnecp5p7;declarations;feed;
+open;opendoch;opendocp5p7;openpagep5-7;close;closepage;
+execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end
+
+$necp6$
+begin;headnecp6;declarations;feed;
+open;opendoch;opendocp6;openpagep5-7;close;closepage;
+execute;cmdp5-7;crs;move;movep5-7;onoff;typep5-7;end
+
+$necp6+$
+begin;headnecp6+;declarations;speed;topmargin;typefacep6+;feed;
+open;opendoch;initspeed;opendocp6+;openpage;close;closepage;
+execute;cmdp6+;crs;move;stdmove;onoff;typep6+;end
+
+$epsonlq850$
+begin;headlq850;declarations;speed;topmargin;typefacelq850;feed;
+open;opendoch;initspeed;opendoclq850;openpage;close;closepage;
+execute;cmdlq850;crs;move;stdmove;onoff;typeplq850;end
+
+$epsonlq1500$
+printerlq1500;end
+
+$oki390/391$
+begin;headoki390/391;declarations;speed;topmargin;typefaceoki;feedschacht;
+open;opendoch;initspeed;opendocokieps;openpage;close;closepage;
+execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end
+
+$oki393/393Ceps$
+begin;headoki393/393Ceps;declarations;speed;topmargin;typefaceoki;feedschacht;
+open;opendoch;initspeed;opendocokieps;openpage;close;closepage;
+execute;cmdoki;crs;move;stdmove;onoff;typeokieps;end
+
+$oki393/393Cibm$
+begin;headoki393/393Cibm;declarations;speed;topmargin;typefaceoki;feedschacht;
+open;opendoch;initspeed;opendocokiibm;openpage;close;closepage;
+execute;cmdoki;crs;move;stdmove;onoff;typeokiibm;end
+
+$toshp321$
+begin;headtoshp321;declarations;speed;feed;
+open;opendochtosh;initspeed;opendoctosh;openpagetosh;close;closepagetosh;
+execute;cmdtosh;crs;move;stdmove;onoff;typetosh;end
+
+$starnb24$
+begin;headstarnb24;declarations;speed;topmargin;typefacestar;feedschacht;
+open;opendoch;initspeed;opendocstar;openpage;close;closepage;
+execute;cmdstar;crs;move;stdmove;onoff;typestar;end
+
+$brotherm1724l$
+begin;headbrotherm1724l;declarations;speed;topmargin;feed;
+open;opendoch;initspeed;opendocbrother;openpage;close;closepage;
+execute;cmdtosh;crs;move;stdmove;onoff;typebrother;end
+
+
+
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.brother b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.brother
new file mode 100644
index 0000000..2251e18
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.brother
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq1500 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq1500
new file mode 100644
index 0000000..1b4c6a6
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq1500
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq850 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq850
new file mode 100644
index 0000000..7a6d2f0
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.epson.lq850
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5
new file mode 100644
index 0000000..9910da6
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5.new b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5.new
new file mode 100644
index 0000000..9804bd5
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p5.new
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p6+ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p6+
new file mode 100644
index 0000000..b209e81
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.nec.p6+
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.oki b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.oki
new file mode 100644
index 0000000..2251e18
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.oki
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.toshiba.p321 b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.toshiba.p321
new file mode 100644
index 0000000..452afca
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/fonttab.toshiba.p321
Binary files differ
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/inserter b/system/printer-24nadel/schulis-mathe-1.0/src/inserter
new file mode 100644
index 0000000..1a165e0
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/inserter
@@ -0,0 +1,793 @@
+
+(*************************************************************************)
+(* Installationsprogramm für Stand : 3. 1.89 *)
+(* 24-Nadel Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+PACKET driver inst 24
+
+
+ DEFINES treiber einrichten:
+
+
+LET up = ""3""13""5"",
+
+ generator name = "printer.24.nadel",
+
+ description file name = "beschreibungen24",
+ module file name = "module24";
+
+
+INT VAR pr channel,
+ quality,
+ paper format number,
+ service option;
+TEXT VAR fonttab name :: "",
+ driver name :: "";
+TEXT VAR inp;
+BOOL VAR was esc;
+
+treiber einrichten
+
+PROC treiber einrichten:
+
+ treiber einrichten (0)
+END PROC treiber einrichten;
+
+PROC treiber einrichten (INT CONST service opt):
+
+ ask for print channel;
+ main menu;
+ IF installed
+ THEN generate printer spool
+ ELSE inform about restart
+ FI.
+
+ ask for printchannel:
+ inits;
+ page;
+ headline ("Druckerkanal - Einstellung");
+ cursor (1, 15);
+ putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit");
+ putline (" 'serverchannel (Kanalnummer)' in der Task """ +
+ name (myself) + """");
+ putline (" verändert werden.");
+ REP
+ cursor (1, 10);
+ put (""5"EUMEL-Kanalnummer des Druckerkanals:");
+ get (pr channel);
+ disable stop;
+ serverchannel (pr channel);
+ BOOL VAR no error :: NOT is error;
+ clear error;
+ no error := no error CAND
+ (pr channel <> channel (myself)) CAND
+ (pr channel > 1) CAND
+ (pr channel < 17);
+
+ IF NOT no error
+ THEN cursor (1, 7);
+ put error;
+ putline ("Eingabe korrigiert wiederholen!")
+ FI;
+ enable stop
+ UNTIL no error PER;
+ IF exists task ("canal " + text (pr channel))
+ THEN end (/ ("canal " + text (pr channel)));
+ FI;
+
+. inits:
+ line;
+ IF single task
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+ FI;
+ command dialogue (TRUE);
+ IF name (myself) <> "PRINTER"
+ THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ +
+ name (myself) + """ !");
+ IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?")
+ THEN rename myself ("PRINTER")
+ FI
+ FI;
+ INT VAR choice;
+ service option := service opt.
+
+ single task: (pcb (9) AND 255) = 1.
+
+ main menu:
+ BOOL VAR installed :: FALSE;
+ REP
+ show main menu;
+ get choice;
+ treat choice
+ UNTIL was esc OR installed PER.
+
+ show main menu:
+ page;
+ headline("Hauptmenü 24-Nadel-Drucker");
+ putline (" 1. Brother");
+ putline (" 2. Epson");
+ putline (" 3. NEC");
+ putline (" 4. OKI");
+ putline (" 5. Toshiba").
+
+ get choice:
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Installation abbrechen");
+ ask user (5).
+
+ treat choice:
+ SELECT int (inp) OF
+ CASE 1: brother menu
+ CASE 2: epson menu
+ CASE 3: nec menu
+ CASE 4: oki menu
+ CASE 5: toshiba menu
+ END SELECT.
+
+
+ brother menu:
+ page;
+ headline ("brother - Menü");
+ putline (" 1. M-1724 L");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ brother m1724l inst
+ FI.
+
+ brother m1724l inst:
+ putline ("brother M-1724 L");
+ line;
+ putline ("Wählen Sie folgende DIP-Schalter Optionen:");
+ putline ("Emulationsmodus IBM Proprinter XL ");
+ putline ("Automatischer Zeilenvorschub Nein ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.brother");
+ generate ("brotherm1724l");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ toshiba menu:
+ page;
+ headline ("TOSHIBA - Menü");
+ putline (" 1. P 321");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ toshiba p321 inst
+ FI.
+
+ toshiba p321 inst:
+ putline ("TOSHIBA P 321");
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S3-8 S3-7 S3-5 übrige Schalter");
+ putline ("OFF OFF *) egal ");
+ putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug");
+ show control options ("std speed, paper feed");
+ show material options("slow, fast");
+ show command options ("nlq, draft");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.toshiba.p321");
+ generate ("toshp321");
+ adjust papersize;
+ adjust quality;
+ do ("papersize(21.0,30.48)");
+ installed := TRUE;
+ FI.
+
+
+ epson menu:
+ page;
+ headline ("Epson - Menü");
+ putline (" 1. LQ 850");
+ putline (" 2. LQ 1050");
+ putline (" 3. LQ 1500");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (3);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : lq850 inst
+ CASE 2 : lq850 inst
+ CASE 3 : lq1500 inst
+ END SELECT
+ FI.
+
+ lq850 inst:
+ IF choice = 1
+ THEN putline ("Epson LQ 850")
+ ELSE putline ("Epson LQ 1050")
+ FI;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8");
+ putline ("egal egal egal egal egal egal *1) OFF ");
+ putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line;
+ putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8");
+ putline ("egal egal *2) OFF OFF");
+ putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle ");
+ putline (" gesetzt werden (Druckerhandbuch)");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, roman, sansserif");
+ show command options ("draft, nlq, roman, sansserif");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq850");
+ generate ("epsonlq850");
+ adjust quality;
+ adjust papersize;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ lq1500 inst:
+ putline ("EPSON LQ-1500");
+ show control options ("");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq1500");
+ generate ("epsonlq1500");
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ nec menu:
+ page;
+ headline ("NEC - Menü");
+ putline (" 1. PINWRITER P5 ");
+ putline (" 2. PINWRITER P6 ");
+ putline (" 3. PINWRITER P7 ");
+ putline (" 4. PINWRITER P6 PLUS");
+ putline (" 5. PINWRITER P7 PLUS");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (5);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : necp5p7 inst
+ CASE 2 : necp6 inst
+ CASE 3 : necp5p7 inst
+ CASE 4 : necp6plus inst
+ CASE 5 : necp6plus inst
+ END SELECT
+ FI.
+
+ necp5p7 inst:
+ IF choice = 1
+ THEN putline ("NEC PINWRITER P5")
+ ELSE putline ("NEC PINWRITER P7")
+ FI;
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp5p7");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6 inst:
+ putline ("NEC PINWRITER P6 ");
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp6");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6plus inst:
+ IF choice = 4
+ THEN putline ("NEC PINWRITER P6 PLUS")
+ ELSE putline ("NEC PINWRITER P7 PLUS")
+ FI;
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("CR FUNCTION CR ONLY ");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, courier, souvenir");
+ show command options ("draft, nlq, courier, souvenir");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p6+");
+ generate ("necp6+");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE;
+ IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI;
+ FI.
+
+ oki menu:
+ page;
+ headline ("OKI - Menü");
+ putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel");
+ putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel");
+ putline (" 3. MICROLINE 393/393C EPSON-kompatibel");
+ putline (" 4. MICROLINE 393/393C IBM-kompatibel");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (4);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : oki ml390 inst
+ CASE 2 : oki ml390 inst
+ CASE 3 : oki ml393eps inst
+ CASE 4 : oki ml393ibm inst
+ END SELECT
+ FI.
+
+ oki ml390 inst:
+ IF choice = 1
+ THEN putline ("OKI Microline 390") ;
+ ELSE putline ("OKI Microline 391") ;
+ FI;
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE EPSON LQ ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki390/391");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ oki ml393eps inst:
+ putline ("OKI Microline 393 EPSON-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Ceps");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ oki ml393ibm inst:
+ putline ("OKI Microline 393 IBM-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE ASCII ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Cibm");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+
+
+generate printer spool:
+ IF service opt = 0
+ THEN forget (generator name, quiet);
+ forget (driver name, quiet)
+ FI;
+ eumel must advertise;
+ cursor (1, 10);
+(* putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (2);
+ putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer");
+ putline (" Drucker eingesetzt werden soll.");
+ line (2);
+*)
+(* put ("Generierung beendet, weiter mit 'SV'");
+ break (quiet);
+*)
+ putline (" Generierung beendet.");
+ putline (" Weiter: Bitte Taste drücken");
+ WHILE incharety <> "" REP ENDREP;
+ REP UNTIL incharety <> "" ENDREP;
+ unlink;
+ do ("spool manager (PROC printer)").
+
+ inform about restart:
+ page;
+ putline ("Es ist kein Druckertreiber installiert worden!");
+ line;
+ putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline ("mit 'treiber einrichten' erneut aufgerufen werden.");
+ line;
+ pause(50);
+ unlink.
+
+END PROC treiber einrichten;
+
+PROC headline (TEXT CONST header):
+
+ cursor (13,1);
+ putline ("E U M E L - Druckertreiber - Installations - Programm");
+ cursor (40 - LENGTH header DIV 2, 2);
+ put (header);
+ line (2)
+END PROC headline;
+
+PROC ask user (INT CONST max choice):
+
+ TEXT VAR exit;
+ inp := "";
+ REP
+ cursor (1,23);
+ IF inp = ""
+ THEN put ("Ihre Wahl (Nummer eingeben):")
+ ELSE put ("FEHLER! Eingabe korrigieren:")
+ FI;
+ editget (inp, ""27"", "", exit);
+ was esc := exit = ""27"";
+ UNTIL was esc OR ok PER.
+
+ ok:
+ int (inp) > 0 AND int (inp) <= max choice AND last conversion ok.
+END PROC ask user;
+
+PROC show control options (TEXT CONST options):
+
+ line;
+ putline ("Steuerprozeduren in der Task """ + name (myself) + """:");
+ write ("papersize, std quality");
+ IF options <> ""
+ THEN put (",");
+ putline (options)
+ FI
+END PROC show control options;
+
+PROC show material options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche Materialwerte (#material(""..."")#):");
+ putline (options)
+END PROC show material options;
+
+PROC show command options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche direkte Druckeranweisungen (#""...""#):");
+ putline (options)
+END PROC show command options;
+
+PROC ask for quality:
+
+ line (1);
+ putline ("Standard - Druckqualität:");
+ line;
+ REP out (up);
+ IF yes ("Draft Quality (schneller, aber nicht so schön)")
+ THEN quality := 1; LEAVE ask for quality
+ FI;
+ out (up);
+ IF yes ("Near Letter Quality (schöner, aber langsamer)")
+ THEN quality := 2; LEAVE ask for quality
+ FI;
+ PER
+END PROC ask for quality;
+
+PROC adjust quality:
+
+ IF quality = 1
+ THEN do ("std quality (""draft"")")
+ ELSE do ("std quality (""nlq"")")
+ FI
+END PROC adjust quality;
+
+PROC ask for papersize :
+LET up = ""3""13""5"";
+
+ paper format number := paper format ;
+
+ . paper format :
+ line (1);
+ putline ("Papierformat:");
+ line;
+ REP out (up);
+ IF yes ("Endlospapier, 8 Zoll breit")
+ THEN LEAVE paper format WITH 1 FI;
+ out (up);
+ IF yes ("Endlospapier, 13.2 Zoll breit")
+ THEN LEAVE paper format WITH 2 FI;
+ out (up);
+ IF yes ("Einzelblatteinzug, DINA 4")
+ THEN LEAVE paper format WITH 3 FI;
+ PER;
+ 0
+END PROC ask for papersize;
+
+
+PROC adjust papersize:
+
+ SELECT paper format number OF
+ CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 3 : do("papersize (21.0, 29.7)");
+ do ("paper feed (""sheet"")")
+ END SELECT
+
+END PROC adjust papersize;
+
+BOOL PROC all right:
+
+ line (3);
+ cursor (1,23);
+ yes ("Soll der ausgewählte Druckertreiber installiert werden")
+END PROC all right;
+
+PROC get fonttable (TEXT CONST name):
+
+ fonttab name := name;
+ from archive ((description file name & module file name & fonttab name)
+ - all);
+ fonttable (fonttab name);
+ command dialogue (FALSE);
+ save (fonttab name, /"configurator");
+ IF service option = 0
+ THEN forget (fonttab name)
+ FI;
+ command dialogue (TRUE);
+END PROC get fonttable;
+
+PROC from archive (THESAURUS CONST files):
+
+ IF highest entry (files) > 0
+ THEN fetch from archive;
+ release (archive);
+ putline ("Archiv abgemeldet !")
+ FI.
+
+ fetch from archive:
+ THESAURUS VAR thes :: files;
+ REP
+ ask for archive;
+ reserve archive;
+ fetch (thes / ALL archive, archive);
+ thes := thes - all
+ UNTIL highest entry (thes) = 0 PER.
+
+ask for archive:
+ TEXT VAR buffer;
+(*line;
+ putline ("Bitte Archiv mit den Dateien");
+ INT VAR index :: 0;
+ REP
+ get (thes, buffer, index);
+ putline (" " + buffer)
+ UNTIL index = 0 PER;
+ putline ("einlegen !");
+ line;
+ putline ("Wenn eingelegt: Taste drücken !");
+ inchar (buffer)*).
+
+reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop.
+
+END PROC from archive;
+
+THESAURUS OP & (TEXT CONST left, right):
+ THESAURUS VAR result := empty thesaurus;
+ insert (result, left);
+ insert (result, right);
+ result
+END OP &;
+
+THESAURUS OP & (THESAURUS CONST left, TEXT CONST right):
+ THESAURUS VAR result := left;
+ insert (result, right);
+ result
+END OP &;
+
+PROC generate (TEXT CONST name):
+
+ open files;
+ read description;
+ build programme;
+ insert programme;
+ forget files.
+
+ open files:
+ line (5);
+ cursor (1, 20);
+ putline (""4"Bitte warten !");
+ putline (" - Der Treiber wird generiert.");
+ driver name := "printer." + name + "(generiert)";
+ IF exists (driver name)
+ THEN forget (driver name, quiet)
+ FI;
+ FILE VAR des file :: sequential file (modify, description file name),
+ mod file :: sequential file (modify, module file name),
+ driver file :: sequential file (output, driver name).
+
+ read description:
+ to line (des file, 1);
+ col (des file, 1);
+ downety (des file, "$" + name + "$");
+ IF eof (des file)
+ THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" +
+ "Descriptions-File enthalten")
+ FI;
+ TEXT VAR description :: "",
+ record;
+ BOOL VAR done :: FALSE;
+ read record (des file, record);
+ record := subtext (record, col (des file) + LENGTH name + 2);
+ WHILE NOT eof (des file) AND NOT done REP
+ treat record
+ PER.
+
+ treat record:
+ INT VAR dollar pos :: pos (record, "$");
+ IF dollar pos = 0
+ THEN description CAT compress (record);
+ down (des file);
+ read record (des file, record)
+ ELSE description CAT compress (subtext (record, 1, dollar pos - 1));
+ col (des file, dollar pos);
+ done := TRUE;
+ FI.
+
+ build programme:
+ get module name;
+ WHILE still modules REP
+ find module;
+ transfer module;
+ get module name
+ PER.
+
+ get module name:
+ INT VAR semicol pos :: pos (description, ";");
+ TEXT VAR module name;
+ IF semicol pos > 0
+ THEN module name := subtext (description, 1, semicol pos - 1);
+ description := subtext (description, semicol pos + 1)
+ ELSE module name := description;
+ description := ""
+ FI.
+
+ still modules:
+ module name <> "" OR description <> "".
+
+ find module:
+ to line (mod file, 1);
+ col (mod file, 1);
+ downety (mod file, "$" + module name + "$");
+ IF eof (mod file)
+ THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" +
+ "Modul-File enthalten")
+ FI.
+
+ transfer module:
+ done := FALSE;
+ read record (mod file, record);
+ record := subtext (record, col (mod file) + LENGTH module name + 2);
+ WHILE NOT eof (mod file) AND NOT done REP
+ transfer record
+ PER.
+
+ transfer record:
+ dollar pos := pos (record, "$");
+ IF dollar pos = 0
+ THEN write (driver file, compress (record));
+ line (driver file);
+ down (mod file);
+ read record (mod file, record)
+ ELSE write (driver file, compress (subtext (record, 1,
+ dollar pos - 1)));
+ col (mod file, dollar pos);
+ done := TRUE;
+ cout (line no (mod file))
+ FI.
+
+ insert programme:
+ IF online
+ THEN putline (" - Der Treiber wird insertiert.")
+ FI;
+ check off;
+ insert (driver name).
+
+ forget files:
+ IF service option = 0
+ THEN forget (description file name, quiet);
+ forget (module file name, quiet)
+ FI .
+END PROC generate;
+
+END PACKET driver inst 24
+
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/module24 b/system/printer-24nadel/schulis-mathe-1.0/src/module24
new file mode 100644
index 0000000..a4957c2
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/module24
@@ -0,0 +1,1554 @@
+
+(*************************************************************************)
+(* Stand : 03. 1.89 *)
+(* Module-Datei für 24-Nadel-Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+$begin$
+PACKET printer driver
+
+ DEFINES printer,
+ open,
+ close,
+ execute,
+ paper size,
+ std quality,
+
+$headnecp6$ paper feed:
+(* Treiber fuer NEC P6, automatisch generiert *)
+LET underline linetype = 1;
+INT VAR factor 1, factor 2, draft factor 1, draft factor 2;
+
+$headnecp5p7$ paper feed:
+(* Treiber fuer NEC P5, P7 , automatisch generiert *)
+LET underline linetype = 1;
+INT VAR factor 1, factor 2, draft factor 1, draft factor 2;
+
+$headnecp6+$ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+(* Treiber für NEC P6 plus/P7 plus ,automatisch generiert *)
+
+
+$headlq850$ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+(* Treiber für EPSON LQ-850/1050 ,automatisch generiert *)
+
+$headbrotherm1724l$
+ std speed,
+ top margin,
+ paper feed:
+INT VAR vertical factor := 1;
+(* Treiber für BROTHER M-1724L in IBM-Emulation, automatisch generiert *)
+
+$headoki390/391$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+INT VAR vertical factor := 1;
+(* Treiber für OKI MIKROLINE 390/391 ,automatisch generiert *)
+
+$headoki393/393Ceps$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+INT VAR vertical factor := 1;
+(* Treiber für OKI MIKROLINE 393/393C EPSON-kompatibel, automatisch generiert *)
+
+$headoki393/393Cibm$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+INT VAR vertical factor := 1;
+(* Treiber für OKI MIKROLINE 393/393C IBM-kompatibel, automatisch generiert *)
+
+$headtoshp321$ std speed,
+ paper feed:
+(* Treiber für TOSHIBA P321, automatisch generiert *)
+
+$headstarnb24$
+ std speed,
+ top margin,
+ paper feed,
+ std typeface:
+(* Treiber für STAR NB 24-10/15 in Standard Betriebsart automatisch generiert *)
+
+$declarations$
+INT VAR font nr, font bits, modification bits,
+ blankbreite, x rest, high, low, steps;
+REAL VAR x size, y size;
+TEXT VAR buffer :: "";
+BOOL VAR is nlq ;
+TEXT VAR font text :: "";
+TEXT VAR std quality name :: "draft";
+
+. is pica : font bits = 0
+. is elite : font bits = 1
+.;
+
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+END PROC paper size;
+
+papersize (20.32, 30.48);
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+END PROC paper size;
+
+
+
+PROC std quality (TEXT CONST quality) :
+
+ IF quality = "nlq" OR quality = "draft"
+ THEN std quality name := quality
+ ELSE errorstop ("unzulässige Qualitätsbezeichnung")
+ FI
+END PROC std quality;
+
+TEXT PROC std quality :
+
+ std quality name
+END PROC std quality;
+
+
+$topmargin$
+REAL VAR y margin := 0.0 ;
+
+PROC top margin (REAL CONST margin):
+
+ y margin := margin
+END PROC top margin;
+
+REAL PROC top margin:
+
+ y margin
+END PROC top margin;
+
+
+$speed$
+BOOL VAR is slow :: TRUE;
+TEXT VAR std speed name :: "slow";
+
+PROC std speed (TEXT CONST speed) :
+
+ IF speed = "fast" OR speed = "slow"
+ THEN std speed name := speed
+ ELSE errorstop ("unzulässige Geschwindigkeit")
+ FI
+END PROC std speed;
+
+TEXT PROC std speed :
+
+std speed name
+END PROC std speed;
+
+
+$typefacelq850$
+TEXT VAR act typeface name :: "";
+TEXT VAR std typeface name :: "";
+
+. is roman:
+ act typeface name = "roman".
+. is sansserif:
+ act typeface name = "sansserif"
+.;
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "roman" OR typeface = "sansserif"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+
+
+$typefacep6+$
+BOOL VAR is courier :: TRUE;
+TEXT VAR std typeface name :: "courier";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "courier" OR typeface = "souvenir"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+$typefaceoki$
+BOOL VAR is courier ;
+TEXT VAR std typeface name :: "";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "courier" OR typeface = "kassette"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+$typefacestar$
+BOOL VAR is roman ;
+TEXT VAR std typeface name :: "";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "roman" OR typeface = "font1"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface :
+
+ std typeface name
+END PROC std typeface;
+
+$feed$
+BOOL VAR is sheet feed :: FALSE;
+
+PROC paper feed (TEXT CONST feeder) :
+
+ IF feeder = "sheet"
+ THEN is sheet feed := TRUE
+ ELIF feeder = "tractor"
+ THEN is sheet feed := FALSE
+ ELSE errorstop ("unzulässige Einzugsart")
+ FI
+END PROC paper feed;
+
+TEXT PROC paper feed:
+ IF is sheet feed
+ THEN "sheet"
+ ELSE "tractor"
+ FI
+END PROC paper feed;
+
+$feedschacht$
+BOOL VAR is sheet feed :: FALSE;
+TEXT VAR feeder name :: "tractor";
+
+PROC paper feed (TEXT CONST feeder) :
+
+ IF feeder = "tractor"
+ THEN feeder name := "tractor";
+ is sheet feed := FALSE
+ ELIF feeder = "sheet" OR feeder = "schacht1"
+ THEN feeder name := "schacht1" ;
+ is sheet feed := TRUE
+ ELIF feeder = "schacht2"
+ THEN feeder name := "schacht2" ;
+ is sheet feed := TRUE
+ ELSE errorstop ("unzulässige Einzugsart")
+ FI
+END PROC paper feed;
+
+TEXT PROC paper feed: feeder name END PROC paper feed;
+
+$open$
+PROC open (INT CONST op code, INT VAR param1, param2):
+
+ SELECT op code OF
+ CASE 1: open document(param1,param2)
+ CASE 2: open page (param1,param2)
+ END SELECT.
+END PROC open ;
+
+
+$opendoch$
+PROC open document (INT VAR x steps,y steps):
+ modification bits := 0;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ y steps := (y steps DIV 30) * 30;
+
+$opendochtosh$
+PROC open document (INT VAR x steps,y steps):
+ modification bits := 0;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ y steps := (y steps DIV 36) * 36;
+
+$initspeed$
+ IF pos (material, "slow") <> 0
+ THEN is slow := TRUE;
+ ELIF pos (material, "fast") <> 0
+ THEN is slow := FALSE;
+ ELSE is slow := std speed name = "slow"
+ FI;
+
+$opendocp6+$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ FI;
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN is courier := TRUE ;
+ ELIF pos (material, "souvenir") <> 0
+ THEN is courier := FALSE ;
+ ELSE is courier := std typeface name = "courier"
+ FI;
+END PROC open document ;
+
+$opendocp5p7$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* Amerikanischer Zeichensatz *)
+ out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ center paper ;
+ FI;
+
+ . center paper :
+ INT CONST x steps in chars := x steps DIV x step conversion (2.54 / 10.0),
+ left margin := (136 - x steps in chars) DIV 2;
+ out (""27"P");
+ out (""27"l"); out (code (left margin + 1));
+END PROC open document ;
+
+$opendocp6$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* Amerikanischer Zeichensatz *)
+ out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ FI;
+END PROC open document ;
+
+$opendoclq850$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN out (""27""25"4"); (* Sheetmode ein *)
+ FI;
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "roman") <> 0
+ THEN act typeface name := "roman"
+ ELIF pos (material, "sansserif") <> 0
+ THEN act typeface name := "sansserif"
+ ELSE act typeface name := std typeface name
+ FI;
+END PROC open document ;
+
+$opendocokieps$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"27"R"0""); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN IF feeder name = "schacht2"
+ THEN out (""27""25"2")
+ ELSE out (""27""25"1")
+ FI
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN is courier := TRUE ;
+ ELIF pos (material, "kassette") <> 0
+ THEN is courier := FALSE ;
+ ELSE is courier := std typeface name = "courier"
+ FI;
+END PROC open document ;
+
+$opendoctosh$
+ out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *)
+ out (""27"6"); (* Zeichensatz *)
+ out (""27"A"12""27"2") ;
+ out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+END PROC open document ;
+
+$opendocbrother$
+ out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *)
+ out (""27"6" + ""27"R"0""); (* Zeichensatz II ascii *)
+ out (""27"A"10""27"2") ; (* Zeilenabstand *)
+ out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *)
+ IF is sheet feed
+ THEN out (""27""25"4")
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+END PROC open document ;
+
+$opendocokiibm$
+ out (""24""27"5"0""27"4"27"O"); (* Reset des Druckers *)
+ out (""27"6" + ""27"!"64""); (* Zeichensatz II ascii *)
+ out (""27""91""92""4""0""0""0""180""); (* 1/180 *)
+ out (""27"A"12""27"2") ; (* Zeilenabstand *)
+ out (""27"C" + code (y steps DIV 36)); (* Formularlaenge *)
+ IF is sheet feed
+ THEN IF feeder name = "schacht2"
+ THEN out (""27""25"2")
+ ELSE out (""27""25"1")
+ FI
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN is courier := TRUE ;
+ ELIF pos (material, "kassette") <> 0
+ THEN is courier := FALSE ;
+ ELSE is courier := std typeface name = "courier"
+ FI;
+END PROC open document ;
+
+$opendocstar$
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* amerikanischer Zeichensatz *)
+ out (""27"O");
+ out (""27"2" + ""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ IF is sheet feed
+ THEN IF feeder name = "schacht2"
+ THEN out (""27""25"2")
+ ELSE out (""27""25"1")
+ FI
+ FI; (* Sheetmode ein *)
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ IF pos (material, "roman") <> 0
+ THEN is roman := TRUE ;
+ ELIF pos (material, "font1") <> 0
+ THEN is roman := FALSE ;
+ ELSE is roman := std typeface name = "roman"
+ FI;
+END PROC open document ;
+
+$openpagetosh$
+PROC open page (INT VAR x start , y start):
+
+ x start := 0;
+ IF is sheet feed
+ THEN y start := y step conversion (2.54) (* 1 Inch *)
+ ELSE y start := 0;
+ FI;
+ x rest := 0;
+ out (""13"");
+END PROC open page;
+
+$openpage$
+PROC open page (INT VAR x start , y start):
+
+ x start := 0 ;
+ y start := y step conversion (y margin) ;
+ x rest := 0;
+ out (""13"").
+END PROC open page;
+
+$openpagep5-7$
+PROC open page (INT VAR x start , y start):
+
+ x start := 0;
+ IF is sheet feed
+ THEN y start := y step conversion (8.466667e-1) (* 2/6 Inch *)
+ ELSE y start := 0;
+ FI;
+ x rest := 0;
+ out (""13"");
+END PROC open page;
+
+$close$
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+ SELECT op code OF
+ CASE 1: close document
+ CASE 2: close page (param1)
+ END SELECT.
+
+close document :
+.
+END PROC close ;
+
+$closepage$
+PROC close page (INT CONST remaining y steps) :
+ IF remaining y steps > 0
+ THEN out (""12"")
+ ELIF is sheet feed
+ THEN out (""27""25"R")
+ FI;
+END PROC close page;
+
+$closepagetosh$
+PROC close page (INT CONST remaining y steps) :
+ IF is sheet feed
+ THEN out (""12"")
+ ELIF remaining y steps > 0
+ THEN out (""12"")
+ FI;
+END PROC close page;
+
+$execute$
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE 1: write text
+ CASE 2: write cmd
+ CASE 3: carriage return
+ CASE 4: move
+ CASE 5: draw
+ CASE 6: on
+ CASE 7: off
+ CASE 8: type
+END SELECT.
+
+from : param1.
+to : param2.
+
+ write text :
+ out subtext (string, from, to).
+
+$cmdp6+$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "courier"
+ THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI;
+ ELIF buffer = "souvenir"
+ THEN IF is courier THEN is courier := FALSE; switch to souvenir FI;
+ ELIF buffer = "schwarz"
+ THEN out (""27"r0")
+ ELIF buffer = "rot"
+ THEN out (""27"r1")
+ ELIF buffer = "blau"
+ THEN out (""27"r2")
+ ELIF buffer = "violett"
+ THEN out (""27"r3")
+ ELIF buffer = "gelb"
+ THEN out (""27"r4")
+ ELIF buffer = "orange"
+ THEN out (""27"r5")
+ ELIF buffer = "grün"
+ THEN out (""27"r6")
+ ELSE out (buffer)
+ FI.
+
+$cmdp5-7$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN switch to nlq FI;
+ is nlq := TRUE;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN switch to draft FI;
+ is nlq := FALSE;
+ ELSE out (buffer);
+ FI;.
+
+$cmdlq850$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "roman"
+ THEN IF NOT is roman THEN act typeface name := "roman" ;
+ switch to roman FI;
+ ELIF buffer = "sansserif"
+ THEN IF NOT is sansserif THEN act typeface name := "sansserif";
+ switch to sansserif FI;
+ ELSE out (buffer)
+ FI.
+
+$cmdoki$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "courier"
+ THEN IF NOT is courier THEN is courier := TRUE; switch to courier FI;
+ ELIF buffer = "kassette"
+ THEN IF is courier THEN is courier := FALSE; switch to kassette FI;
+ ELIF buffer = "schwarz"
+ THEN out (""27"r0")
+ ELIF buffer = "rot"
+ THEN out (""27"r1")
+ ELIF buffer = "blau"
+ THEN out (""27"r2")
+ ELIF buffer = "violett"
+ THEN out (""27"r3")
+ ELIF buffer = "gelb"
+ THEN out (""27"r4")
+ ELIF buffer = "orange"
+ THEN out (""27"r5")
+ ELIF buffer = "grün"
+ THEN out (""27"r6")
+ ELSE out (buffer)
+ FI.
+
+$cmdtosh$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELSE out (buffer);
+ FI;.
+
+$cmdstar$
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN IF NOT is nlq THEN is nlq := TRUE; switch to nlq FI;
+ ELIF buffer = "draft"
+ THEN IF is nlq THEN is nlq := FALSE; switch to draft FI;
+ ELIF buffer = "roman"
+ THEN IF NOT is roman THEN is roman := TRUE; switch to roman FI;
+ ELIF buffer = "font1"
+ THEN IF is roman THEN is roman := FALSE; switch to font1 FI;
+ FI.
+
+$crs$
+ carriage return :
+ x rest := 0;
+ out (""13"").
+
+$move$
+x steps : param1.
+y steps : param2.
+
+move :
+ IF x steps < 0 OR y steps < 0 THEN stop FI;
+ IF x steps > 0 THEN x move FI;
+ IF y steps > 0 THEN y move FI.
+
+$stdmove$
+x move :
+ x rest INCR x steps;
+ high := (x rest) DIV blankbreite;
+ x rest := (x rest) MOD blankbreite;
+ steps := x rest DIV 3;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF steps > 0 AND is slow
+ THEN IF is underline THEN out (" "8"") FI;
+ out (""27"Y" + code (steps) + ""0""); (* 1/360 *)
+ steps TIMESOUT ""0"";
+ x rest := x rest MOD 3
+ FI.
+
+is underline:
+ bit (modification bits,7).
+
+y move :
+ IF y steps > 0
+ THEN high := y steps DIV 255;
+ low := y steps MOD 255;
+ IF high > 0 THEN high TIMESOUT ""27"J"255"" FI; (* 1/180 *)
+ IF low > 0 THEN out (""27"J" + code (low)) FI;
+ FI.
+
+draw :
+ IF x steps < 0 OR y steps <> 0 OR linetype <> 1
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI.
+
+x draw :
+ x rest INCR x steps ;
+ steps := x steps DIV 3 ;
+ IF steps > 0 THEN
+ x rest := x steps MOD 3 ;
+ out (""27"Y");
+ out (code (steps MOD 256));
+ out (code (steps DIV 256));
+ steps TIMESOUT ""1"";
+ FI.
+
+$movep5-7$
+ x move :
+ x rest INCR x steps;
+ IF not is underline
+ THEN simple x move
+ ELSE underline x move
+ FI;
+
+ . not is underline :
+ NOT bit (modification bits, 7)
+
+ . simple x move :
+ high := x rest DIV factor 1;
+ x rest := x rest MOD factor 1;
+ out (""27"\");
+ out (code (high MOD 256));
+ out (code (high DIV 256));
+
+ . underline x move :
+ high := x rest DIV factor 2;
+ x rest := x rest MOD factor 2;
+ IF high < blankbreite
+ THEN stop
+ ELSE low := high MOD 127;
+ high := high DIV 127;
+ IF low >= blankbreite
+ THEN low DECR blankbreite;
+ ELSE high DECR 1;
+ low DECR (blankbreite - 127);
+ FI;
+ IF high > 0
+ THEN out (""27" ");
+ out (code (127 - blankbreite));
+ high TIMESOUT " ";
+ FI;
+ out (""27" ");
+ out (code (low));
+ out (" "27" "0"");
+ FI;
+. y move:
+
+ low := y steps MOD 255;
+ high := y steps DIV 255;
+ IF high > 0 THEN high TIMESOUT (""27"J"255"") FI;
+ IF low > 0 THEN out (""27"J" + code (low)) FI;
+
+. draw :
+ IF x steps < 0 OR y steps <> 0
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI;
+
+ . x draw :
+ x rest INCR x steps;
+ steps := x rest DIV 4;
+ x rest := x rest MOD 4;
+ IF steps > 0
+ THEN low := steps MOD 256;
+ high := steps DIV 256;
+ out (""27"*"39"");
+ out (code (low));
+ out (code (high));
+ steps TIMESOUT dot;
+ FI;
+
+ . dot :
+ IF linetype = underline linetype
+ THEN ""000""000""001""
+ ELSE ""000""000""048""
+ FI.
+
+
+$onoff$
+ modification : param1
+.
+ on :
+ buffer := on string (modification);
+ IF buffer <> ""
+ THEN modification bits := modification bits OR code (buffer);
+ switch to font;
+ ELSE stop
+ FI
+
+.
+ off :
+ buffer := off string (modification);
+ IF buffer <> ""
+ THEN modification bits := modification bits XOR code (buffer);
+ switch to font;
+ ELSE stop
+ FI.
+
+$typep6+$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is courier
+ THEN switch to courier
+ ELSE switch to souvenir
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to courier :
+ out (""27"k"0"") ;
+
+. switch to souvenir :
+ out (""27"k"15"") ;
+END PROC execute;
+
+$typeplq850$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is roman
+ THEN switch to roman
+ ELSE switch to sansserif
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to roman :
+ out (""27"k"0"") ;
+
+. switch to sansserif :
+ out (""27"k"1"") ;
+END PROC execute;
+
+$typeokieps$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ vertical factor := code (buffer SUB 1);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is courier
+ THEN switch to courier
+ ELSE switch to kassette
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ IF vertical factor = 2
+ THEN out (""27"w"1"")
+ ELSE out (""27"w"0"")
+ FI;
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to courier :
+ out (""27"k"0"") ;
+
+. switch to kassette :
+ out (""27"k"127"") ;
+END PROC execute;
+
+$typep5-7$
+ type :
+ font nr := param1;
+ buffer := font string (font nr);
+ factor 1 := code (buffer SUB 1); (* 720 / Mikroschritte pro Inch mit ESC \ *)
+ factor 2 := code (buffer SUB 2); (* 720 / Mikroschritte pro Inch mit ESC Blank *)
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") DIV factor 2;
+ switch to font;
+ IF is nlq THEN switch to nlq FI;
+
+END PROC execute;
+
+
+PROC switch to font :
+
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+END PROC switch to font;
+
+
+PROC switch to nlq :
+
+ IF is pica OR is elite
+ THEN draft factor 1 := factor 1;
+ factor 1 := 4;
+ draft factor 2 := factor 2;
+ IF is pica
+ THEN factor 2 := 4 * factor 2 DIV 6;
+ blankbreite := char pitch (font nr, " ") DIV factor 2;
+ FI;
+ out (""27"x"1"");
+ ELSE out (""27"x"0"");
+ FI;
+
+END PROC switch to nlq;
+
+
+PROC switch to draft :
+
+ IF is pica OR is elite
+ THEN factor 1 := draft factor 1;
+ factor 2 := draft factor 2;
+ out (""27"x"0"");
+ FI;
+
+END PROC switch to draft;
+
+$typetosh$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+ switch to font;
+
+. switch to font :
+ INT VAR master select bits := font bits OR modification bits ;
+ IF bit (master select bits,0)
+ THEN out (""27":")
+ ELSE out (""18"")
+ FI;
+ IF bit (master select bits,1)
+ THEN out (""27"I"2""27"P"1"")
+ ELSE out (""27"P"0"")
+ FI;
+ IF bit (master select bits,2)
+ THEN out (""27""15"")
+ FI;
+ IF bit (master select bits,3)
+ THEN out (""27"E")
+ ELSE out (""27"F")
+ FI;
+ IF bit (master select bits,4)
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI;
+ IF bit (master select bits,5)
+ THEN out (""27"W"1"")
+ ELSE out (""27"W"0"")
+ FI;
+ IF bit (master select bits,6)
+ THEN
+ ELSE
+ FI;
+ IF bit (master select bits,7)
+ THEN out (""27"-"1"")
+ ELSE out (""27"-"0"")
+ FI;
+ out (font text);
+
+
+. switch to nlq :
+ out (""27"I"2"");
+
+. switch to draft :
+ out (""27"I"1"");
+
+END PROC execute;
+
+$typeokiibm$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ vertical factor := code (buffer SUB 1);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is courier
+ THEN switch to courier
+ ELSE switch to kassette
+ FI ;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+ switch to font;
+
+. switch to font :
+ INT VAR master select bits := font bits OR modification bits ;
+ IF bit (master select bits,0)
+ THEN out (""27":")
+ ELSE out (""18"")
+ FI;
+ IF bit (master select bits,1)
+ THEN out (""27"I"2""27"P"1"")
+ ELSE out (""27"P"0"")
+ FI;
+ IF bit (master select bits,2)
+ THEN out (""27""15"")
+ FI;
+ IF bit (master select bits,3)
+ THEN out (""27"E")
+ ELSE out (""27"F")
+ FI;
+ IF bit (master select bits,4)
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI;
+ IF bit (master select bits,5)
+ THEN out (""27"W"1"")
+ ELSE out (""27"W"0"")
+ FI;
+ IF bit (master select bits,6)
+ THEN out(""27"%G")
+ ELSE out(""27"%H")
+ FI;
+ IF bit (master select bits,7)
+ THEN out (""27"-"1"")
+ ELSE out (""27"-"0"")
+ FI;
+ IF vertical factor = 2
+ THEN out (""27""91""64""4""0""0""0""2""0"")
+ ELSE out (""27""91""64""4""0""0""0""1""0"")
+ FI;
+ out (font text);
+
+
+. switch to nlq :
+ out (""27"I"2"");
+
+. switch to draft :
+ out (""27"I"0"");
+
+. switch to courier :
+ out (""27"k"0"") ;
+
+. switch to kassette :
+ out (""27"k"127"") ;
+END PROC execute;
+
+$typebrother$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ vertical factor := code (buffer SUB 1);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+ switch to font;
+
+. switch to font :
+ INT VAR master select bits := font bits OR modification bits ;
+ IF bit (master select bits,0)
+ THEN out (""27":")
+ ELSE out (""18"")
+ FI;
+ IF bit (master select bits,1)
+ THEN out (""27"I"2""27"P"1"")
+ ELSE out (""27"P"0"")
+ FI;
+ IF bit (master select bits,2)
+ THEN out (""27""15"")
+ FI;
+ IF bit (master select bits,3)
+ THEN out (""27"E")
+ ELSE out (""27"F")
+ FI;
+ IF bit (master select bits,4)
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI;
+ IF bit (master select bits,5)
+ THEN out (""27"W"1"")
+ ELSE out (""27"W"0"")
+ FI;
+ IF bit (master select bits,6)
+ THEN
+ ELSE
+ FI;
+ IF bit (master select bits,7)
+ THEN out (""27"-"1"")
+ ELSE out (""27"-"0"")
+ FI;
+ IF vertical factor = 2
+ THEN out (""27""91""64""4""0""0""0""2""0"")
+ ELSE out (""27""91""64""4""0""0""0""1""0"")
+ FI;
+ out (font text);
+
+. switch to nlq :
+ out (""27"I"2"");
+
+. switch to draft :
+ out (""27"I"0"");
+
+END PROC execute;
+
+$typestar$
+ type :
+ font nr := param1 ;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 3);
+ font text := subtext (buffer, 4);
+ blankbreite := char pitch (font nr, " ") ;
+ IF is roman
+ THEN switch to roman
+ ELSE switch to font1
+ FI ;
+ switch to font;
+ IF is nlq
+ THEN switch to nlq
+ ELSE switch to draft
+ FI;
+
+. switch to font :
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+. switch to nlq :
+ out (""27"x"1"");
+
+. switch to draft :
+ out (""27"x"0"");
+
+. switch to roman :
+ out (""27"k"0"") ;
+
+. switch to font1 :
+ out (""27"k"1"") ;
+END PROC execute;
+
+
+
+$printerlq1500$
+PACKET printer driver
+
+(**************************************************************************)
+(* Stand : 29.07.86 *)
+(* EPSON LQ-1500 Version : 4 *)
+(* Autor : Rudolf Ruland *)
+(* geändert am 15.12.88 hjh *)
+(**************************************************************************)
+
+ DEFINES printer,
+ open,
+ close,
+ execute,
+
+ paper size,
+ std quality:
+
+LET
+(* underline = 1,
+ bold = 2,
+ italics = 4,
+ reverse = 8, *)
+
+ underline linetype = 1,
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1,
+ c write cmd = 2,
+ c carriage return = 3,
+ c move = 4,
+ c draw = 5,
+ c on = 6,
+ c off = 7,
+ c type = 8;
+
+INT VAR rest, high, low, factor;
+BOOL VAR is nlq, factor was 6, condensed;
+REAL VAR x size, y size;
+TEXT VAR std quality name, buffer;
+
+(*********************************************************************)
+
+paper size (13.6 * 2.54, 12.0 * 2.54);
+std quality ("draft");
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+
+PROC std quality (TEXT CONST quality) :
+
+ IF quality = "nlq" OR quality = "draft"
+ THEN std quality name := quality;
+ ELSE errorstop ("unzulaessige Betriebsart")
+ FI;
+
+END PROC std quality;
+
+TEXT PROC std quality : std quality name END PROC std quality;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+ factor := 0;
+ factor was 6 := FALSE;
+ condensed := FALSE;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ y steps := (y steps DIV 30) * 30;
+ out (""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""); (* Amerikanischer Zeichensatz *)
+ out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ x start := 0;
+ y start := 0;
+ rest := 0;
+ out (""13"");
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+END SELECT;
+
+.
+ close document :
+
+
+. remaining y steps : param1
+.
+ close page :
+ IF remaining y steps > 0 THEN out (""12"") FI
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ out subtext (string, from, to)
+
+.
+ write cmd :
+ buffer := subtext (string, from, to);
+ IF buffer = "nlq"
+ THEN is nlq := TRUE;
+ near letter quality;
+ ELIF buffer = "draft"
+ THEN is nlq := FALSE;
+ draft quality;
+ ELSE out (buffer);
+ FI;
+
+ . near letter quality :
+ IF factor = 6
+ THEN factor was 6 := TRUE;
+ factor := 4;
+ ELSE factor was 6 := FALSE;
+ FI;
+ IF condensed
+ THEN out (""27"x"0"")
+ ELSE out (""27"x"1"")
+ FI;
+
+ . draft quality :
+ IF factor was 6
+ THEN factor was 6 := FALSE;
+ factor := 6;
+ FI;
+ out (""27"x"0"");
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ rest := 0;
+ out (""13"");
+
+
+. x steps : param1
+. y steps : param2
+.
+ move :
+ IF x steps < 0 OR y steps < 0
+ THEN stop
+ ELIF x steps > 0
+ THEN x move
+ ELIF y steps > 0
+ THEN y move
+ FI;
+
+ . x move :
+ high := (x steps + rest) DIV factor;
+ rest := (x steps + rest) MOD factor;
+ out (""27"\");
+ out (code (high MOD 256));
+ out (code (high DIV 256));
+
+ . y move :
+ high := y steps DIV 255;
+ low := y steps MOD 255;
+ IF high > 0 THEN high TIMESOUT ""27"J"255"" FI;
+ IF low > 0 THEN out (""27"J"); out (code (low)) FI;
+
+.
+ draw :
+ IF x steps < 0 OR y steps <> 0 OR linetype <> underline linetype
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI;
+
+ . x draw :
+ high := (x steps + rest) DIV 6;
+ rest := (x steps + rest) MOD 6;
+ IF high > 0
+ THEN low := high MOD 255;
+ high := high DIV 255;
+ out (""27"V");
+ out (code (low));
+ out (""27"*"1""1""0""1""27"V"0"");
+ FOR low FROM 1 UPTO high
+ REP out (""27"V"255""27"*"1""1""0""1""27"V"0"") PER;
+ FI;
+
+
+. modification : param1
+.
+ on :
+ IF on string (modification) <> ""
+ THEN out (on string (modification))
+ ELSE stop
+ FI
+
+.
+ off :
+ IF off string (modification) <> ""
+ THEN out (off string (modification))
+ ELSE stop
+ FI
+
+
+. font nr : param1
+.
+ type :
+ buffer := font string (font nr);
+ out (buffer);
+ factor := pitch factor;
+ IF is nlq THEN near letter quality FI;
+
+ . pitch factor : (* Mikroschritt *)
+ INT CONST font bits := code (buffer SUB 3);
+ IF bit (font bits, 1)
+ THEN condensed := FALSE; 2 (* proportional 1/360 Inch *)
+ ELIF pos (buffer, ""27"x"1"") <> 0
+ THEN condensed := FALSE; 4 (* near letter 1/180 Inch *)
+ ELIF bit (font bits, 2)
+ THEN condensed := TRUE; 3 (* condensed 1/240 Inch *)
+ ELIF bit (font bits, 0)
+ THEN condensed := FALSE; 4 (* elite 1/180 Inch *)
+ ELSE condensed := FALSE; 6 (* pica 1/120 Inch *)
+ FI
+
+END PROC execute;
+
+
+$end$
+INT VAR reply; DATASPACE VAR ds; FILE VAR file;
+
+PROC printer:
+
+ disable stop;
+ continue (server channel);
+ check error (error message);
+ ds := nilspace;
+ REP forget (ds);
+ execute print;
+ IF is error AND online THEN put error; clear error; FI;
+ PER;
+END PROC printer;
+
+PROC execute print:
+
+ LET ack = 0, fetch code = 11, file type = 1003;
+ enable stop;
+ ds := nilspace;
+ call (father, fetch code, ds, reply);
+ IF reply = ack CAND type (ds) = file type
+ THEN file := sequential file (input, ds);
+ print (file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+END PROC execute print;
+
+PROC check error(TEXT CONST message):
+
+ IF is error
+ THEN clear error; rename myself (message);
+ IF is error THEN end(myself) FI;
+ pause (9000); end(myself);
+ FI;
+END PROC check error;
+
+END PACKET printerdriver
+
+
diff --git a/system/printer-24nadel/schulis-mathe-1.0/src/printer.24.nadel b/system/printer-24nadel/schulis-mathe-1.0/src/printer.24.nadel
new file mode 100644
index 0000000..579f67f
--- /dev/null
+++ b/system/printer-24nadel/schulis-mathe-1.0/src/printer.24.nadel
@@ -0,0 +1,776 @@
+
+(*************************************************************************)
+(* Installationsprogramm für Stand : 3. 1.89 *)
+(* 24-Nadel Drucker Version : 0.9 *)
+(* Autor : hjh *)
+(*************************************************************************)
+
+PACKET driver inst 24
+
+
+ DEFINES treiber einrichten:
+
+
+LET up = ""3""13""5"",
+
+ generator name = "printer.24.nadel",
+
+ description file name = "beschreibungen24",
+ module file name = "module24";
+
+
+INT VAR pr channel,
+ quality,
+ paper format number,
+ service option;
+TEXT VAR fonttab name :: "",
+ driver name :: "";
+TEXT VAR inp;
+BOOL VAR was esc;
+
+treiber einrichten
+
+PROC treiber einrichten:
+
+ treiber einrichten (0)
+END PROC treiber einrichten;
+
+PROC treiber einrichten (INT CONST service opt):
+
+ ask for print channel;
+ main menu;
+ IF installed
+ THEN generate printer spool
+ ELSE inform about restart
+ FI.
+
+ ask for printchannel:
+ inits;
+ page;
+ headline ("Druckerkanal - Einstellung");
+ cursor (1, 15);
+ putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit");
+ putline (" 'serverchannel (Kanalnummer)' in der Task """ +
+ name (myself) + """");
+ putline (" verändert werden.");
+ REP
+ cursor (1, 10);
+ put (""5"EUMEL-Kanalnummer des Druckerkanals:");
+ get (pr channel);
+ disable stop;
+ serverchannel (pr channel);
+ BOOL VAR no error :: NOT is error;
+ IF is error
+ THEN cursor (1, 7);
+ put error;
+ putline ("Eingabe korrigiert wiederholen!")
+ FI;
+ clear error;
+ enable stop
+ UNTIL no error PER.
+
+ inits:
+ line;
+ IF single task
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+ FI;
+ command dialogue (TRUE);
+ IF name (myself) <> "PRINTER"
+ THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ +
+ name (myself) + """ !");
+ IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?")
+ THEN rename myself ("PRINTER")
+ FI
+ FI;
+ INT VAR choice;
+ service option := service opt.
+
+ single task: (pcb (9) AND 255) = 1.
+
+ main menu:
+ BOOL VAR installed :: FALSE;
+ REP
+ show main menu;
+ get choice;
+ treat choice
+ UNTIL was esc OR installed PER.
+
+ show main menu:
+ page;
+ headline("Hauptmenü 24-Nadel-Drucker");
+ putline (" 1. Brother");
+ putline (" 2. Epson");
+ putline (" 3. NEC");
+ putline (" 4. OKI");
+ putline (" 5. Toshiba").
+
+ get choice:
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Installation abbrechen");
+ ask user (5).
+
+ treat choice:
+ SELECT int (inp) OF
+ CASE 1: brother menu
+ CASE 2: epson menu
+ CASE 3: nec menu
+ CASE 4: oki menu
+ CASE 5: toshiba menu
+ END SELECT.
+
+
+ brother menu:
+ page;
+ headline ("brother - Menü");
+ putline (" 1. M-1724 L");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ brother m1724l inst
+ FI.
+
+ brother m1724l inst:
+ putline ("brother M-1724 L");
+ line;
+ putline ("Wählen Sie folgende DIP-Schalter Optionen:");
+ putline ("Emulationsmodus IBM Proprinter XL ");
+ putline ("Automatischer Zeilenvorschub Nein ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.brother");
+ generate ("brotherm1724l");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ toshiba menu:
+ page;
+ headline ("TOSHIBA - Menü");
+ putline (" 1. P 321");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ toshiba p321 inst
+ FI.
+
+ toshiba p321 inst:
+ putline ("TOSHIBA P 321");
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S3-8 S3-7 S3-5 übrige Schalter");
+ putline ("OFF OFF *) egal ");
+ putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug");
+ show control options ("std speed, paper feed");
+ show material options("slow, fast");
+ show command options ("nlq, draft");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.toshiba.p321");
+ generate ("toshp321");
+ adjust papersize;
+ adjust quality;
+ do ("papersize(21.0,30.48)");
+ installed := TRUE;
+ FI.
+
+
+ epson menu:
+ page;
+ headline ("Epson - Menü");
+ putline (" 1. LQ 850");
+ putline (" 2. LQ 1050");
+ putline (" 3. LQ 1500");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (3);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : lq850 inst
+ CASE 2 : lq850 inst
+ CASE 3 : lq1500 inst
+ END SELECT
+ FI.
+
+ lq850 inst:
+ IF choice = 1
+ THEN putline ("Epson LQ 850")
+ ELSE putline ("Epson LQ 1050")
+ FI;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8");
+ putline ("egal egal egal egal egal egal *1) OFF ");
+ putline ("*1) ON: Einzelblatteinzug, OFF: kein Einzug"); line;
+ putline ("SW2-1 SW2-2 SW2-3 SW2-4 SW2-5 SW2-6 SW2-7 SW2-8");
+ putline ("egal egal *2) OFF OFF");
+ putline ("*2) SW2-2 bis SW2-6 müssen je nach Art der Schnittstelle ");
+ putline (" gesetzt werden (Druckerhandbuch)");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, roman, sansserif");
+ show command options ("draft, nlq, roman, sansserif");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq850");
+ generate ("epsonlq850");
+ adjust quality;
+ adjust papersize;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ lq1500 inst:
+ putline ("EPSON LQ-1500");
+ show control options ("");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.epson.lq1500");
+ generate ("epsonlq1500");
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ nec menu:
+ page;
+ headline ("NEC - Menü");
+ putline (" 1. PINWRITER P5 ");
+ putline (" 2. PINWRITER P6 ");
+ putline (" 3. PINWRITER P7 ");
+ putline (" 4. PINWRITER P6 PLUS");
+ putline (" 5. PINWRITER P7 PLUS");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (5);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : necp5p7 inst
+ CASE 2 : necp6 inst
+ CASE 3 : necp5p7 inst
+ CASE 4 : necp6plus inst
+ CASE 5 : necp6plus inst
+ END SELECT
+ FI.
+
+ necp5p7 inst:
+ IF choice = 1
+ THEN putline ("NEC PINWRITER P5")
+ ELSE putline ("NEC PINWRITER P7")
+ FI;
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp5p7");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6 inst:
+ putline ("NEC PINWRITER P6 ");
+ show control options ("paper feed");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq");
+ ask for quality;
+ ask for papersize;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p5.new");
+ generate ("necp6");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ necp6plus inst:
+ IF choice = 4
+ THEN putline ("NEC PINWRITER P6 PLUS")
+ ELSE putline ("NEC PINWRITER P7 PLUS")
+ FI;
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("CR FUNCTION CR ONLY ");
+ show control options ("std speed, top margin, std typeface, paperfeed");
+ show material options ("slow, fast, draft, nlq, courier, souvenir");
+ show command options ("draft, nlq, courier, souvenir");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.nec.p6+");
+ generate ("necp6+");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE;
+ IF choice = 5 THEN do ("papersize (34.544, 30.48)") FI;
+ FI.
+
+ oki menu:
+ page;
+ headline ("OKI - Menü");
+ putline (" 1. MICROLINE 390 IBM-/EPSON-kompatibel");
+ putline (" 2. MICROLINE 391 IBM-/EPSON-kompatibel");
+ putline (" 3. MICROLINE 393/393C EPSON-kompatibel");
+ putline (" 4. MICROLINE 393/393C IBM-kompatibel");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (4);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1 : oki ml390 inst
+ CASE 2 : oki ml390 inst
+ CASE 3 : oki ml393eps inst
+ CASE 4 : oki ml393ibm inst
+ END SELECT
+ FI.
+
+ oki ml390 inst:
+ IF choice = 1
+ THEN putline ("OKI Microline 390") ;
+ ELSE putline ("OKI Microline 391") ;
+ FI;
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE EPSON LQ ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki390/391");
+ adjust papersize;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+ oki ml393eps inst:
+ putline ("OKI Microline 393 EPSON-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Ceps");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+ oki ml393ibm inst:
+ putline ("OKI Microline 393 IBM-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Wählen Sie folgende Optionen im Druckmenü des Druckers:");
+ putline ("EMULATION MODE ASCII ");
+ putline ("AUTO LF NO ");
+ show control options ("paperfeed, std speed, top margin, std typeface");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq, courier, kassette, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for papersize;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.oki");
+ generate ("oki393/393Cibm");
+ adjust papersize;
+ adjust quality;
+ installed := TRUE
+ FI.
+
+
+
+generate printer spool:
+ IF service opt = 0
+ THEN forget (generator name, quiet);
+ forget (driver name, quiet)
+ FI;
+ eumel must advertise;
+ cursor (1, 10);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (2);
+ putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer");
+ putline (" Drucker eingesetzt werden soll.");
+ line (2);
+ put ("Generierung beendet, weiter mit 'SV'");
+ break (quiet);
+ do ("spool manager (PROC printer)").
+
+ inform about restart:
+ page;
+ putline ("Es ist kein Druckertreiber installiert worden!");
+ line;
+ putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline ("mit 'treiber einrichten' erneut aufgerufen werden.");
+ line.
+
+END PROC treiber einrichten;
+
+PROC headline (TEXT CONST header):
+
+ cursor (13,1);
+ putline ("E U M E L - Druckertreiber - Installations - Programm");
+ cursor (40 - LENGTH header DIV 2, 2);
+ put (header);
+ line (2)
+END PROC headline;
+
+PROC ask user (INT CONST max choice):
+
+ TEXT VAR exit;
+ inp := "";
+ REP
+ cursor (1,23);
+ IF inp = ""
+ THEN put ("Ihre Wahl (Nummer eingeben):")
+ ELSE put ("FEHLER! Eingabe korrigieren:")
+ FI;
+ editget (inp, ""27"", "", exit);
+ was esc := exit = ""27"";
+ UNTIL was esc OR ok PER.
+
+ ok:
+ int (inp) > 0 AND int (inp) <= max choice AND last conversion ok.
+END PROC ask user;
+
+PROC show control options (TEXT CONST options):
+
+ line;
+ putline ("Steuerprozeduren in der Task """ + name (myself) + """:");
+ write ("papersize, std quality");
+ IF options <> ""
+ THEN put (",");
+ putline (options)
+ FI
+END PROC show control options;
+
+PROC show material options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche Materialwerte (#material(""..."")#):");
+ putline (options)
+END PROC show material options;
+
+PROC show command options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche direkte Druckeranweisungen (#""...""#):");
+ putline (options)
+END PROC show command options;
+
+PROC ask for quality:
+
+ line (1);
+ putline ("Standard - Druckqualität:");
+ line;
+ REP out (up);
+ IF yes ("Draft Quality (schneller, aber nicht so schön)")
+ THEN quality := 1; LEAVE ask for quality
+ FI;
+ out (up);
+ IF yes ("Near Letter Quality (schöner, aber langsamer)")
+ THEN quality := 2; LEAVE ask for quality
+ FI;
+ PER
+END PROC ask for quality;
+
+PROC adjust quality:
+
+ IF quality = 1
+ THEN do ("std quality (""draft"")")
+ ELSE do ("std quality (""nlq"")")
+ FI
+END PROC adjust quality;
+
+PROC ask for papersize :
+LET up = ""3""13""5"";
+
+ paper format number := paper format ;
+
+ . paper format :
+ line (1);
+ putline ("Papierformat:");
+ line;
+ REP out (up);
+ IF yes ("Endlospapier, 8 Zoll breit")
+ THEN LEAVE paper format WITH 1 FI;
+ out (up);
+ IF yes ("Endlospapier, 13.2 Zoll breit")
+ THEN LEAVE paper format WITH 2 FI;
+ out (up);
+ IF yes ("Einzelblatteinzug, DINA 4")
+ THEN LEAVE paper format WITH 3 FI;
+ PER;
+ 0
+END PROC ask for papersize;
+
+
+PROC adjust papersize:
+
+ SELECT paper format number OF
+ CASE 1 : do("papersize ( 8.0 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 2 : do("papersize (13.2 * 2.54, 12.0 * 2.54)");
+ do ("paper feed (""tractor"")")
+ CASE 3 : do("papersize (21.0, 29.7)");
+ do ("paper feed (""sheet"")")
+ END SELECT
+
+END PROC adjust papersize;
+
+BOOL PROC all right:
+
+ line (3);
+ cursor (1,23);
+ yes ("Soll der ausgewählte Druckertreiber installiert werden")
+END PROC all right;
+
+PROC get fonttable (TEXT CONST name):
+
+ fonttab name := name;
+ from archive ((description file name & module file name & fonttab name)
+ - all);
+ fonttable (fonttab name);
+ command dialogue (FALSE);
+ save (fonttab name, /"configurator");
+ IF service option = 0
+ THEN forget (fonttab name)
+ FI;
+ command dialogue (TRUE);
+END PROC get fonttable;
+
+PROC from archive (THESAURUS CONST files):
+
+ IF highest entry (files) > 0
+ THEN fetch from archive;
+ release (archive);
+ putline ("Archiv abgemeldet !")
+ FI.
+
+ fetch from archive:
+ THESAURUS VAR thes :: files;
+ REP
+ ask for archive;
+ reserve archive;
+ fetch (thes / ALL archive, archive);
+ thes := thes - all
+ UNTIL highest entry (thes) = 0 PER.
+
+ask for archive:
+ line;
+ putline ("Bitte Archiv mit den Dateien");
+ TEXT VAR buffer;
+ INT VAR index :: 0;
+ REP
+ get (thes, buffer, index);
+ putline (" " + buffer)
+ UNTIL index = 0 PER;
+ putline ("einlegen !");
+ line;
+ putline ("Wenn eingelegt: Taste drücken !");
+ inchar (buffer).
+
+reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop.
+
+END PROC from archive;
+
+THESAURUS OP & (TEXT CONST left, right):
+ THESAURUS VAR result := empty thesaurus;
+ insert (result, left);
+ insert (result, right);
+ result
+END OP &;
+
+THESAURUS OP & (THESAURUS CONST left, TEXT CONST right):
+ THESAURUS VAR result := left;
+ insert (result, right);
+ result
+END OP &;
+
+PROC generate (TEXT CONST name):
+
+ open files;
+ read description;
+ build programme;
+ insert programme;
+ forget files.
+
+ open files:
+ line (5);
+ cursor (1, 20);
+ putline (""4"Bitte warten !");
+ putline (" - Der Treiber wird generiert.");
+ driver name := "printer." + name + "(generiert)";
+ IF exists (driver name)
+ THEN forget (driver name, quiet)
+ FI;
+ FILE VAR des file :: sequential file (modify, description file name),
+ mod file :: sequential file (modify, module file name),
+ driver file :: sequential file (output, driver name).
+
+ read description:
+ to line (des file, 1);
+ col (des file, 1);
+ downety (des file, "$" + name + "$");
+ IF eof (des file)
+ THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" +
+ "Descriptions-File enthalten")
+ FI;
+ TEXT VAR description :: "",
+ record;
+ BOOL VAR done :: FALSE;
+ read record (des file, record);
+ record := subtext (record, col (des file) + LENGTH name + 2);
+ WHILE NOT eof (des file) AND NOT done REP
+ treat record
+ PER.
+
+ treat record:
+ INT VAR dollar pos :: pos (record, "$");
+ IF dollar pos = 0
+ THEN description CAT compress (record);
+ down (des file);
+ read record (des file, record)
+ ELSE description CAT compress (subtext (record, 1, dollar pos - 1));
+ col (des file, dollar pos);
+ done := TRUE;
+ FI.
+
+ build programme:
+ get module name;
+ WHILE still modules REP
+ find module;
+ transfer module;
+ get module name
+ PER.
+
+ get module name:
+ INT VAR semicol pos :: pos (description, ";");
+ TEXT VAR module name;
+ IF semicol pos > 0
+ THEN module name := subtext (description, 1, semicol pos - 1);
+ description := subtext (description, semicol pos + 1)
+ ELSE module name := description;
+ description := ""
+ FI.
+
+ still modules:
+ module name <> "" OR description <> "".
+
+ find module:
+ to line (mod file, 1);
+ col (mod file, 1);
+ downety (mod file, "$" + module name + "$");
+ IF eof (mod file)
+ THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" +
+ "Modul-File enthalten")
+ FI.
+
+ transfer module:
+ done := FALSE;
+ read record (mod file, record);
+ record := subtext (record, col (mod file) + LENGTH module name + 2);
+ WHILE NOT eof (mod file) AND NOT done REP
+ transfer record
+ PER.
+
+ transfer record:
+ dollar pos := pos (record, "$");
+ IF dollar pos = 0
+ THEN write (driver file, compress (record));
+ line (driver file);
+ down (mod file);
+ read record (mod file, record)
+ ELSE write (driver file, compress (subtext (record, 1,
+ dollar pos - 1)));
+ col (mod file, dollar pos);
+ done := TRUE;
+ cout (line no (mod file))
+ FI.
+
+ insert programme:
+ IF online
+ THEN putline (" - Der Treiber wird insertiert.")
+ FI;
+ check off;
+ insert (driver name).
+
+ forget files:
+ IF service option = 0
+ THEN forget (description file name, quiet);
+ forget (module file name, quiet)
+ FI .
+END PROC generate;
+
+END PACKET driver inst 24
+
diff --git a/system/printer-24nadel/schulis-sim-3.0 b/system/printer-24nadel/schulis-sim-3.0
new file mode 120000
index 0000000..5ca05f9
--- /dev/null
+++ b/system/printer-24nadel/schulis-sim-3.0
@@ -0,0 +1 @@
+schulis-mathe-1.0/ \ No newline at end of file
diff --git a/system/printer-9nadel/0.9/doc/readme b/system/printer-9nadel/0.9/doc/readme
new file mode 100644
index 0000000..2047abe
--- /dev/null
+++ b/system/printer-9nadel/0.9/doc/readme
@@ -0,0 +1,324 @@
+#type("nlq10")##limit(18.0)##start(1.5,1.0)#
+#head#
+Treiber-Installations-Programm #right#Seite %
+für 9-Nadel-Matrixdrucker #right#23.06.1988
+
+
+#end#
+#on("u")#Dokumentation zum Treiber-Installations-Programm für 9-Nadel-
+Matrixdrucker#off("u")#
+
+#on("u")#Inhalt:#off("u")#
+
+1. Installations- und Gebrauchsanleitung
+2. Druckertreiber-Auswahl
+3. Steuerungsmöglichkeiten und Spezialfeatures
+4. Weitere Hinweise
+
+
+#on("b")#1. Installations- und Gebrauchsanleitung#off("b")#
+
+#on("u")#Einrichten#off("u")#
+So wird das Treiber-Installationsprogramm eingerichtet:
+
+ SV drücken
+
+ nach 'gib supervisor kommando:'
+
+ begin("PRINTER","SYSUR")
+
+ in der Task "PRINTER" (nach 'gib kommando'):
+
+ archive ("std.printer")
+ fetch ("printer.neun.nadel",archive)
+ check off
+ insert ("printer.neun.nadel")
+
+Das Programm wird dann insertiert.
+
+#on("u")#Druckerkanal#off("u")#
+Hiernach wird die Kanalnummer des Druckers erfragt. Wenn der Drucker
+über Parallelschnittstelle betrieben wird, ist die Kanalnummer
+meistens 15.
+
+#on("u")#Menüsystem#off("u")#
+Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern.
+Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste
+der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier
+den passenden Typ aus!
+Das Installationsprogramm zeigt nun einige Informationen zu dem ange­
+wählten Drucker. Besonders zu beachten sind hierbei #on("u")#Angaben zur Konfi­
+guration des Druckers#off("u")# (z.B. DIP-Schalter). Der Drucker muß unbedingt
+wie angegeben konfiguriert werden, wenn er mit dem ausgewählten Trei­
+ber betrieben werden soll.
+
+Hinweise zu Konfigurationsangaben:
+1. Die Angabe 'egal' bedeutet, daß die Einstellung für die Funktion
+ des Treibers keine Bedeutung hat. Dennoch solte der Anwender darauf
+ achten, welche Funktion die Schalter haben (Druckerhandbuch!). So
+ ist es zum Beispiel immer empfehlenswert, den Papierende-Sensor zu
+ aktivieren, damit der Drucker nach Papierende nicht auf der Walze
+ weiterdruckt.
+2. Die Konfigurationsangaben beziehen sich immer auf genau den ausge­
+ wählten Druckertyp. Wenn Sie den Treiber mit einem anderen Drucker
+ als den ausgewählten verwenden, dann beachten Sie folgende Regeln
+ für die Konfiguration:
+ - Der Drucker muß auf eine passende Emulation konfiguriert werden.
+ - Der Drucker darf bei einem Carriage Return (Code 13) keinen Zei­
+ lenvorschub durchführen.
+ - Der Drucker darf die Perforation #on("u")#nicht#off("u")# automatisch überspringen.
+
+ - Auf Seitenlängen und internationale Zeichensätze müssen Sie nicht
+ achten.
+
+(Hinweise zur Auswahl des richtigen Treibers gibt Abschnitt 2)
+
+Nach den Konfigurationsangaben werden Steuerungsmöglichkeiten des
+ausgewählten Treibers angezeigt. (Siehe hierzu Abschnitt 3)
+
+Falls der Treiber bestimmte grundsätzliche Betriebsmöglichkeiten er­
+laubt (z.B. DRAFT/NLQ, Einzelblatteinzug), werden Sie danach gefragt,
+welche Möglichkeit standardmäßig gewählt werden soll. diese Vorein­
+stellungen können nachträglich in der Task "PRINTER" mit den entspre­
+chenden Steuerprozeduren neu gesetzt werden. Außerdem können bestimmte
+Einstellungen noch für jedes einzelne Dokument (d.h. für jede Druck­
+datei) gewählt ('material'-Anweisung) oder sogar innerhalb eines Doku­
+ments verändert werden (direkte Druckeranweisung \#"..."\#).
+Über die Steuerungsmöglichkeiten informiert Abschnitt 3 ausführlicher.
+
+
+#on("b")#2. Druckertreiber-Auswahl#off("b")#
+
+#on("u")#Verwendung nicht im Menü enthaltener Drucker#off("u")#
+Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden, soll­
+ten Sie zunächst versuchen, ob ein Treiber für einen anderen Drucker
+des gleichen Herstellers mit Ihrem Drucker korrekt arbeitet.
+Falls dies nicht funktioniert oder der Hersteller überhaupt nicht im
+Menü erscheint, müssen Sie herausfinden (Druckerhandbuch, -händler!),
+welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist.
+(Viele Drucker verfügen über EPSON FX-85 bzw. FX-800-Emulationen oder
+IBM Grafikdrucker bzw. Proprinter-Eumulationen.)
+Eine der beiden Anpassungen 'EPSON MX' oder 'IBM-Grafikdrucker' müßte
+immer einen (Minimal-) Betrieb ermöglichen.
+
+#on("u")#Hinweise zu den Treibern für FX-80/85-kompatilble Drucker#off("u")#
+Die Treiber für FX-80-bzw. FX-85-kompatible Geräte, die oft auch IBM-
+kompatibel sind, basieren üblicherweise auf den Treibern für EPSON-
+Drucker, weil so einige Schrifttypen (z.B. Proportionalschrift) und
+Modifikationen leichter ausgenutzt werden können. Ein Nachteil liegt
+aber darin, daß beim FX-80 und FX-85 noch die alten EPSON-Zeichensätze
+benutzt werden, die nicht die IBM-üblichen Grafik- und Sonderzeichen
+enthalten.
+Falls für Sie die Benutzung dieser Zeichen vordringlich ist, sollten
+Sie Ihren Drucker (nachdem er auf IBM-Emulation konfiguriert wurde)
+zusammen mit dem Treiber für IBM-Grafikdrucker bzw. -Proprinter ver­
+wenden.
+
+
+#on("b")#3. Steuerungsmöglichkeiten und Spezialfeatures#off("b")#
+
+Einige Treiber bieten bestimmte Einstellungsmöglichkeiten (z.B.
+DRAFT/NLQ) und/oder Spezialfeatures (z.B. Farbdruck).
+Die Einstellungen können über
+- Steuerprozeduren
+- Materialanweisungen bzw.
+- direkte Druckeranweisungen
+vorgenommen werden.
+
+#on("u")#Steuerprozeduren#off("u")#
+setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten
+sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER")
+aufgerufen werden. #on("b")#Gültig werden die Änderungen erst, wenn danach in
+der Druckspooltask das Kommando 'start' gegeben wird!#off("b")#
+
+PROC papersize (REAL CONST breite, länge)
+ Dient zur Einstellung der Größe der physikalisch beschreibbaren
+ Fläche.
+ Beispiel: papersize (20.32, 30.48)
+ (Standardeinstellung für Endlospapier 8 Zoll breit und
+ 12 Zoll lang)
+
+PROC papersize
+ Informationsprozedur
+
+PROC top margin (REAL CONST margin)
+ Falls der Drucker es nicht erlaubt, direkt am Blattanfang zu druk­
+ ken (zum Beispiel wegen eines Einzelblatteinzugs), muß mit dieser
+ Prozedur die Länge des oberen Randes, den der Drucker nicht be­
+ drucken kann, in cm angegeben werden.
+ Beispiel: top margin (2.0)
+ (Teilt dem Druckertreiber mit, daß die ersten 2 cm
+ nicht bedruckbar sind.)
+
+REAL PROC top margin
+ Informationsprozedur
+
+PROC std speed (TEXT CONST speed)
+ Parameter: slow, fast
+ Wahl zwischen Positionierung in Mikroschritten (slow) oder in
+ Blanks (fast).
+ Beispiel: std speed ("slow")
+
+TEXR PROC std speed
+ Informationsprozedur
+
+PROC std quality (TEXT CONST quality)
+ übliche Parameter: draft, nlq
+ Wahl zwischen Datenverarbeitungs-Qualität und Schönschrift-
+ Qualität
+ Beispiel: std quality ("draft")
+
+TEXT PROC std quality
+ Informationsprozedur
+
+PROC std typeface (TEXT CONST typeface)
+ übliche Parameter: roman, sansserif, courier
+ Wahl zwischen verschiedenen NLQ-Schriftarten (nur sichtbar im
+ NLQ-Modus, das heißt 'std typeface' schaltet nicht auf NLQ).
+ Beispiel: std typeface ("roman")
+
+TEXT PROC std typeface
+ Informationsprozedur
+
+PROC paper feed (TEXT CONST name)
+ übliche Parameter: tractor, sheet, schacht1, schacht2
+ Wählt Endlospapier oder Einzelblatteinzug und ggf. Schachtnummer.
+ Beispiel: paper feed ("sheet")
+
+TEXT PROC paper feed
+ Informationsprozedur
+
+
+#on("u")#Materialanweisungen \#material("...")\##off("u")#
+müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und
+setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben
+für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge­
+stellten Standardwerten. Diese werden durch die Materialanweisung aber
+nicht geändert.)
+
+Beispiel: \#material("nlq")\#
+ sorgt bei entsprechendem Treiber dafür, daß das gesamte
+ Dokument in Schönschrift-Qualität ausgedruckt wird, egal
+ wie 'std quality' eingestellt ist.
+
+#on("b")#Es darf in einer Datei nur eine Materialanweisung stehen!#off("b")# Sollen meh­
+rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung
+erscheinen. Beispiel: \#material("sheet;draft")\#
+
+
+#on("u")#direkte Druckeranweisungen \#"..."\##off("u")#
+gelten ab der Position, an der sie in der Datei auftreten. Sie haben
+(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und
+Materialeinstellungen.
+
+Beispiel: \#"draft"\#
+ schaltet (bei entsprechendem Treiber) auf Datenverar­
+ beitungs-Qualität, egal welche Standardeinstellung vorliegt
+ und welche Materialanweisung gegeben wurde.
+
+#on("b")#In einer Druckeranweisung darf nur eine Einstellung vorgenommen
+werden.#off("b")# Also: \#"nlq"\#\#"sansserif"\#
+
+
+#on("u")#Wichtig#off("u")#
+- Achten Sie bei Materialanweisungen und direkten Druckeranweisungen
+ besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben
+ berücksichtigt! Also: \#"nlq"\# und keinesfalls \#"NLQ"\#!!!
+- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und
+ nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann
+ daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse
+ erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen
+ Reihenfolge an den Drucker sendet, als er in der Datei steht, die
+ mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B.
+ für beide Spalten) unerwünscht erhalten bleibt.
+
+
+#on("u")#Tabelle#off("u")#
+Die Tabelle soll einen Anhaltspunkt dafür geben, wie welche Einstel­
+lungen erfolgen können.
+
+#type("17")#
+ Steuerprozeduren Materialanweisungen direkte Druckeranweisungen
+
+#on("u")#                                                                                          #off("u")#
+
+Positionierung std speed slow, fast ------
+ slow, fast
+
+Qualität std quality z.B. draft, nlq z.B. draft, nlq
+ z.B. draft, nlq
+
+Schriftart std typeface z.B. roman, z.B. roman,
+(nur bei NLQ) z.B. roman, sansserif, courier sansserif, courier
+ sansserif, courier
+
+Einzelblatt- paper feed z.B. schacht1, z.B. schacht1,
+einzug z.B. tractor, schacht2 schacht2
+ sheet,
+ schacht1, schacht2
+
+Farbdruck ------ ------ z.B. schwarz,
+ rot, blau,
+ violett, gelb
+ orange, grün
+
+
+
+#type("nlq10")##on("b")#4. Weitere Hinweise#off("b")#
+
+#on("u")#Zeichensatzänderungen gegenüber früheren Versionen#off("u")#
+In den Fonttabellen früherer Druckertreiber-Versionen wurden oberhalb
+des Codes 127 einige internationale Zeichen zur Verfügung gestellt
+(und zwar in Anlehnung an den Agfa-Laserdrucker-Zeichensatz).
+Bei den Treibern der vorliegenden Version gilt folgendes:
+- Wie bisher wird der volle im Benutzerhandbuch festgelegte EUMEL-
+ Zeichensatz (sofern möglich) unterstützt.
+- Der Code 252 liefert das Paragraphzeichen.
+- Alle übrigen (vom EUMEL-Zeichensatz nicht definierten) Zeichencodes
+ oberhalb 127 liefern, sofern möglich, die entsprechenden Zeichen des
+ IBM-Grafikzeichensatzes.
+
+
+#on("u")#Hinweis zu Proportionalschriften#off("u")#
+Bei Proportionalschriften sollte die Modifikation \#on("i")\# nicht
+benutzt werden, da die kursiven Zeichen andere Proportionalbreiten
+haben. Stattdessen sollte auf den schrägen Typ umgeschaltet werden
+(z.B. von "prop10" auf "prop10i").
+
+
+#on("u")#Hinweis zur Benutzung von Einzelblatteinzügen#off("u")#
+Bei der Benutzung von Einzelblatteinzügen müssen folgende Einstel­
+lungen vorgenommen werden (vgl. auch Abschnitt 3!):
+
+ Am Drucker:
+1. Sie müssen Ihren Drucker auf die Option Einzelblatteinzug konfigu­
+ rieren (siehe Druckerhandbuch!).
+
+ In der Druckspooltask (meist 'PRINTER'):
+2. Falls der Druckertreiber die Steuerprozedur 'paper feed' zur Verfü­
+ gung stellt, müssen Sie mit 'paperfeed ("sheet")' oder (für
+ 2-Schacht-Einzüge) mit 'paperfeed ("schacht1")' bzw. 'paperfeed
+ ("schacht2")' den Druckertreiber auf Einzelblatteinzug umschalten.
+3. Falls Sie eine andere Papierlänge als 12 Zoll (=30.48 cm) verwen­
+ den, müssen Sie die neuen Papiermaße mit 'papersize' in cm einstel­
+ len.
+ Beispiel: papersize (21.0, 29.7)
+ (für DIN A4-Blätter)
+4. Falls der Drucker mit dem Einzelblatteinzug nicht direkt am Blatt­
+ anfang drucken kann, sondern ein gewisser oberer Rand bleibt, muß
+ mit 'top margin' die Länge des nicht bedruckbaren Randes in cm dem
+ Druckertreiber mitgeteilt werden.
+ Beispiel: top margin (1.5)
+ (Wie groß der obere Rand ist, kann festgestellt werden, indem eine
+ Datei mit \#start(0.0,0.0)\# ausgedruckt wird.)
+
+ Wurde mit 'top margin' dem Treiber die Größe der nicht bedruckbaren
+ Fläche mitgeteilt, so ist darauf zu achten, daß in den Druckdateien
+ ein genügend großer y-Wert für die Startposition eingestellt wird
+ ('start'-Anweisung). Andernfalls kommt es bei der Ausgabe in der
+ ersten Zeile zu Überschreibungen.
+
+
+#on("b")#5. Die Änderungen, die Sie in der Druckspooltask vorgenommen haben
+ werden erst wirksam, wenn das Spool-Kommando 'start' gegeben wird.#off("b")#
+
diff --git a/system/printer-9nadel/0.9/source-disk b/system/printer-9nadel/0.9/source-disk
new file mode 100644
index 0000000..ddcd852
--- /dev/null
+++ b/system/printer-9nadel/0.9/source-disk
@@ -0,0 +1 @@
+grundpaket/06_std.printer_9_nadel.img
diff --git a/system/printer-9nadel/0.9/src/beschreibungen9 b/system/printer-9nadel/0.9/src/beschreibungen9
new file mode 100644
index 0000000..6a74b88
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/beschreibungen9
@@ -0,0 +1,97 @@
+
+(*************************************************************************)
+(* Stand : 01.10.88 *)
+(* Beschreibungen-Datei für 9-Nadel-Drucker Version : 0.9 *)
+(* Autoren : mov/hjh *)
+(*************************************************************************)
+
+$fx85$
+head;hfx85;decl;speed;openh;opendoch;initspeed;opendocfx85;openpge;betwoc;
+clpge;betwce;cmd;crs;moh;mofx85;ymodr;onoff;tyfx85;end
+
+$fx800$
+head;hfx800;decl;quality;typeface;openh;opendoch;opendocfx800;openpge;betwoc;
+clpge;betwce;cmdfx800;crs;moh;mofx800;ymodr;onoff;tyfx800;end
+
+$mx$
+head;hmx;decl;speed;openh;opendoch;initspeed;opendocmx;openpge;betwoc;clpge;
+betwce;cmd;crs;moh;modrmx;onoff;tymx;end
+
+$lx800$
+head;hlx800;decl;speed;quality;typeface;openh;opendoch;initspeed;
+opendocfx800;openpge;betwoc;clpge;betwce;cmdfx800;crs;moh;mofx85;ymodr;onoff;
+tyfx800;end
+
+$ibmgp$
+head;hgp;decl;speed;openh;opendoch;initspeed;opendocgp;openpge;betwoc;
+clpge;betwce;cmd;crs;moh;mogp;ymodr;onoff;tyfx85;end
+
+$ibmpp$
+head;hpp;decl;speed;quality;openh;opendoch;initspeed;opendocpp;openpge;
+betwoc;clpge;betwce;cmdpp;crs;moh;mofx85;ymodr;onoffpp;tyfx85;end
+
+$okiml182i$
+head;hml182i;decl;speed;quality;openh;opendoch;initspeed;opendocml182i;
+opendocgp;openpge;betwoc;clpge;betwce;cmdml182i;crs;moh;mogp;ymodr;onoff;
+tyohnesmall;end
+
+$okiml192el$
+head;hml192el;decl;speed;feed;openh;opendoch;initspeed;opendocml192el;
+openpgemlsf;betwoc;clmlsf;betwce;cmd;crs;moh;moml192el;ymodr;onoff;tyml192el;
+end
+
+$okiml292el$
+head;hml292el;decl;quality;typeface292;feed;openh;opendoch;opendocml292el;
+openpgemlsf;betwoc;clmlsf;betwce;cmdml292el;crs;moh;mofx800;ymodr;onoff;
+tyml292el;end
+
+$okiml294i$
+head;hml294i;decl;speed;quality;feed;openh;opendoch;initspeed;opendocml294i;
+openpgemlsf;betwoc;clmlsf;betwce;cmdml294i;crs;moh;mofx85;ymodr;ontyml294i;end
+
+$okiml320$
+head;hml320;decl;speed;openh;opendoch;initspeed;opendocml320;
+openpge;betwoc;clpge;betwce;cmd;crs;moh;moml192el;ymodr;onoff;tyml192el;
+end
+
+$starlc10$
+head;hlc10;decl;quality;typefacelc10;openh;opendoch;opendoclc10;openpge;
+betwoc;clpge;betwce;cmdlc10;crs;moh;mofx800;ymodr;onoff;tyfx800;end
+
+$dmp4000$
+head;hdmp4000;decl;speed;openh;opendoch;initspeed;opendocdmp4000;openpge;
+betwoc;clpge;betwce;cmd;crs;moh;mofx85;ymodr;onoff;tyfx85;end
+
+$starnx15$
+head;hnx15;decl;speed;openh;opendoch;initspeed;opendocnx15;openpge;betwoc;
+clpge;betwce;cmd;crs;moh;mofx85;ymodr;onoff;tyfx85;end
+
+$mt230$
+head;hmt230;decl;speed;feedschacht;openh;opendoch;initspeed;opendocmt;
+openpgemtsf;betwoc;clmtsf;betwce;cmdmt230;crs;moh;mofx85;ymodr;onoff;
+tyfx85;end
+
+$mt340$
+head;hmt340;decl;speed;feedschacht;openh;opendoch;initspeed;opendocmt;
+openpgemtsf;betwoc;clmtsf;betwce;cmdmt230;crs;moh;moml192el;ymodr;onoff;
+tyml192el;end
+
+$citi120d$
+head;h120d;decl;openh;opendoch;opendoc120d;openpge;betwoc;
+clpge;betwce;cmd;crs;moh;mofx800;ymodr;onoff;tyfx85;end
+
+$citohc310cxp$
+head;hc310;decl;speed;feedschacht;openh;opendoch;initspeed;opendocc310;
+openpgec310sf;betwoc;clc310sf;betwce;cmdc310;crs;moh;mofx85;ymodr;onoff;
+tyfx85;end
+
+$citohci3500$
+head;hci3500;decl;speed;openh;opendoch;initspeed;opendocgp;openpge;betwoc;
+clpge;betwce;cmd;crs;moh;mogp;ymodr;onoff;tyfx85;end
+
+$fujdx2100$
+head;hdx2100;decl;speed;feed;openh;opendoch;initspeed;opendocdx2100;
+openpge;betwoc;clpge;betwce;cmddx2100;crs;moh;moml192el;ymodr;onoff;tyml192el;
+end
+
+
diff --git a/system/printer-9nadel/0.9/src/fonttab.1 b/system/printer-9nadel/0.9/src/fonttab.1
new file mode 100644
index 0000000..b5d17e6
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.1
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.10 b/system/printer-9nadel/0.9/src/fonttab.10
new file mode 100644
index 0000000..6a13c49
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.10
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.20 b/system/printer-9nadel/0.9/src/fonttab.20
new file mode 100644
index 0000000..7cf0aaf
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.20
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.20.lc b/system/printer-9nadel/0.9/src/fonttab.20.lc
new file mode 100644
index 0000000..ddf4535
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.20.lc
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.20.lx b/system/printer-9nadel/0.9/src/fonttab.20.lx
new file mode 100644
index 0000000..1ce0940
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.20.lx
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.7 b/system/printer-9nadel/0.9/src/fonttab.7
new file mode 100644
index 0000000..676b9a0
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.7
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.7.cxp b/system/printer-9nadel/0.9/src/fonttab.7.cxp
new file mode 100644
index 0000000..0a996f3
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.7.cxp
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.7.fuj b/system/printer-9nadel/0.9/src/fonttab.7.fuj
new file mode 100644
index 0000000..1ed83be
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.7.fuj
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/fonttab.7.mt b/system/printer-9nadel/0.9/src/fonttab.7.mt
new file mode 100644
index 0000000..c816646
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/fonttab.7.mt
Binary files differ
diff --git a/system/printer-9nadel/0.9/src/module9 b/system/printer-9nadel/0.9/src/module9
new file mode 100644
index 0000000..65de1ee
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/module9
@@ -0,0 +1,1099 @@
+
+(*************************************************************************)
+(* Stand : 01.10.88 *)
+(* Module-Datei für 9-Nadel-Drucker Version : 0.9 *)
+(* Autoren : mov/hjh *)
+(*************************************************************************)
+
+$head$
+PACKET printer driver
+
+ DEFINES printer,
+ open,
+ close,
+ execute,
+ paper size,
+ top margin,
+
+$hfx85$ std speed:
+(* Treiber für EPSON FX85/105, automatisch generiert *)
+
+$hfx800$ std quality,
+ std typeface:
+(* Treiber für EPSON FX800/1000, automatisch generiert *)
+BOOL VAR was tall font;
+
+$hmx$ std speed:
+(* Treiber für EPSON MX80/100, Typ III *)
+(* Treiber automatisch generiert *)
+BOOL VAR is condensed, is small;
+
+$hlx800$ std speed,
+ std quality,
+ std typeface:
+(* Treiber für EPSON LX800/1000, automatisch generiert *)
+BOOL VAR was tall font;
+
+$hgp$ std speed:
+(* Treiber für IBM-Grafikdrucker *)
+(* Treiber automatisch generiert *)
+
+$hpp$ std speed,
+ std quality:
+(* Treiber für IBM-Proprinter *)
+(* Treiber automatisch generiert *)
+
+$hml182i$ std speed,
+ std quality:
+(* Treiber für OKI ML182/183 IBM-kompatibel *)
+(* Treiber automatisch generiert *)
+
+$hml192el$ paper feed,
+ std speed:
+(* Treiber für OKI ML192/193 Elite *)
+(* Treiber automatisch generiert *)
+BOOL VAR prop font;
+
+$hml292el$ std quality,
+ std typeface,
+ paper feed:
+(* Treiber für OKI ML292/293 Elite *)
+(* Treiber automatisch generiert *)
+BOOL VAR was tall font;
+
+$hml294i$ std speed,
+ paper feed,
+ std quality:
+(* Treiber für OKI ML294 IBM-kompatibel *)
+(* Treiber automatisch generiert *)
+
+$hml320$ std speed:
+(* Treiber für OKI ML320 IBM/EPSON-kompatibel *)
+(* Treiber automatisch generiert *)
+BOOL VAR prop font;
+
+$hlc10$ std quality,
+ std typeface:
+(* Treiber für Star LC-10 oder LC-10 Colour *)
+(* Treiber automatisch generiert *)
+BOOL VAR was tall font;
+
+$hdmp4000$ std speed:
+(* Treiber für Schneider DMP4000, automatisch generiert *)
+
+$hnx15$ std speed:
+(* Treiber für Star NX-15, ND-10, ND-15, NR-10 und NR-15 *)
+(* Treiber automatisch generiert *)
+
+$hmt230$ paper feed,
+ std speed:
+(* Treiber für Mannesmann-Tally MT 230 *)
+(* Treiber automatisch generiert *)
+
+$hmt340$ paper feed,
+ std speed:
+(* Treiber für Mannesmann-Tally MT 340 *)
+(* Treiber automatisch generiert *)
+BOOL VAR prop font := FALSE;
+
+$h120d$ :
+(* Treiber für Citizen 120-D *)
+(* Treiber automatisch generiert *)
+
+$hc310$ paper feed,
+ std speed:
+(* Treiber für C. Itoh C 310/315 CXP *)
+(* Treiber automatisch generiert *)
+
+$hci3500$ std speed:
+(* Treiber für C. Itoh CI-3500 *)
+(* Treiber automatisch generiert *)
+
+$hdx2100$ paper feed,
+ std speed:
+(* Treiber für Fujitsu DX 2100 *)
+(* Treiber automatisch generiert *)
+BOOL VAR prop font := FALSE ;
+
+$decl$
+INT VAR blankbreite, x rest, y rest, high, low, small, modifikations;
+REAL VAR x size, y size, y margin;
+TEXT VAR buffer :: "";
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+END PROC paper size;
+
+papersize (20.32, 30.48);
+
+PROC top margin (REAL CONST margin):
+
+ y margin := margin
+END PROC top margin;
+
+REAL PROC top margin: y margin END PROC top margin;
+
+top margin (0.0);
+
+$speed$
+BOOL VAR is slow;
+TEXT VAR std speed name :: "slow";
+
+PROC std speed (TEXT CONST speed) :
+
+ IF speed = "fast" OR speed = "slow"
+ THEN std speed name := speed
+ ELSE errorstop ("unzulässige Geschwindigkeit")
+ FI
+END PROC std speed;
+
+TEXT PROC std speed : std speed name END PROC std speed;
+
+$quality$
+TEXT VAR std quality name :: "draft";
+
+PROC std quality (TEXT CONST quality) :
+
+ IF quality = "nlq" OR quality = "draft"
+ THEN std quality name := quality
+ ELSE errorstop ("unzulässige Qualitätsbezeichnung")
+ FI
+END PROC std quality;
+
+TEXT PROC std quality : std quality name END PROC std quality;
+
+$typeface$
+TEXT VAR std typeface name :: "";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "roman" OR typeface = "sansserif"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface : std typeface name END PROC std typeface;
+
+$typeface292$
+TEXT VAR std typeface name :: "";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "courier" OR typeface = "sansserif"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface : std typeface name END PROC std typeface;
+
+$typefacelc10$
+TEXT VAR std typeface name :: "";
+
+PROC std typeface (TEXT CONST typeface) :
+
+ IF typeface = "" OR typeface = "courier" OR typeface = "sansserif"
+ OR typeface = "orator1" OR typeface = "orator2"
+ THEN std typeface name := typeface
+ ELSE errorstop ("unzulässige Schriftart")
+ FI
+END PROC std typeface;
+
+TEXT PROC std typeface : std typeface name END PROC std typeface;
+
+$feed$
+TEXT VAR feeder name :: "tractor";
+
+PROC paper feed (TEXT CONST feeder) :
+
+ IF feeder = "sheet" OR feeder = "tractor"
+ THEN feeder name := feeder
+ ELSE errorstop ("unzulässige Einzugsart")
+ FI
+END PROC paper feed;
+
+TEXT PROC paper feed: feeder name END PROC paper feed;
+
+$feedschacht$
+TEXT VAR act feeder :: "",
+ feeder name :: "tractor";
+
+PROC paper feed (TEXT CONST feeder) :
+
+ IF feeder = "tractor" OR feeder = "schacht1" OR feeder = "schacht2"
+ THEN feeder name := feeder
+ ELIF feeder = "sheet"
+ THEN feeder name := "schacht1"
+ ELSE errorstop ("unzulässige Einzugsart")
+ FI
+END PROC paper feed;
+
+TEXT PROC paper feed: feeder name END PROC paper feed;
+
+$openh$
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE 1: open document
+ CASE 2: open page
+END SELECT.
+
+$opendoch$
+ open document :
+ modifikations := 0;
+ param 1 := x step conversion ( x size );
+ param 2 := y step conversion ( y size );
+$initspeed$
+ IF pos (material, "slow") <> 0
+ THEN is slow := TRUE;
+ ELIF pos (material, "fast") <> 0
+ THEN is slow := FALSE;
+ ELSE is slow := std speed name = "slow"
+ FI;
+$opendocfx85$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"2"27"6");
+ out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *)
+
+$opendocfx800$
+ param 2 := (param 2 DIV 36) * 36;
+ was tall font := TRUE;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"R"0""27"9"27"O"27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ IF pos (material, "nlq") <> 0
+ THEN out (""27"x"1"")
+ ELIF pos (material, "draft") <> 0
+ THEN out (""27"x"0"")
+ ELIF std quality name = "nlq"
+ THEN out (""27"x"1"")
+ ELSE out (""27"x"0"")
+ FI;
+ IF pos (material, "roman") <> 0
+ THEN out (""27"k"0"")
+ ELIF pos (material, "sansserif") <> 0
+ THEN out (""27"k"1"")
+ ELIF std typeface name = "roman"
+ THEN out (""27"k"0"")
+ ELIF std typeface name = "sansserif"
+ THEN out (""27"k"1"")
+ FI.
+
+$opendocmx$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27"R"0""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"9"27"O").
+
+$opendocgp$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27"6"); (* Zeichensatz 2 *)
+ out (""18""27"F"27"H"27"W"0""27"T"27"-"0""); (* Modifikationen rücksetzen *)
+ out (""27"9"27"O"27"A"12""27"2");
+ out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *)
+
+$opendocpp$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27"6"); (* Zeichensatz 2 *)
+ out (""18""27"F"27"W"0""27"T"27"-"0""); (* Modifikationen rücksetzen *)
+ out (""27"9"27"O"27"A"12""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ IF pos (material, "nlq") <> 0
+ THEN out (""27"G")
+ ELIF pos (material, "draft") <> 0
+ THEN out (""27"H")
+ ELIF std quality name = "nlq"
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI.
+
+$opendocml182i$
+ IF pos (material, "nlq") <> 0
+ THEN out (""27"I3")
+ ELIF pos (material, "draft") <> 0
+ THEN out (""27"I1")
+ ELIF std quality name = "nlq"
+ THEN out (""27"I3")
+ ELSE out (""27"I1")
+ FI;
+ out (""27"N"0""); (* Kein Sprung über Perf. *)
+
+$opendocml192el$
+ param 2 := (param 2 DIV 36) * 36;
+ prop font := FALSE;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"6"); (* Erweiterung des Zeichensatzes *)
+ out (""27"9"27"O"27"x"0"").
+
+$opendocml292el$
+ param 2 := (param 2 DIV 36) * 36;
+ was tall font := TRUE;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"9"27"O"27"r0");
+ IF pos (material, "nlq") <> 0
+ THEN out (""27"x"1"")
+ ELIF pos (material, "draft") <> 0
+ THEN out (""27"x"0"")
+ ELIF std quality name = "nlq"
+ THEN out (""27"x"1"")
+ ELSE out (""27"x"0"")
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN out (""27"k"0"")
+ ELIF pos (material, "sansserif") <> 0
+ THEN out (""27"k"1"")
+ ELIF std typeface name = "courier"
+ THEN out (""27"k"0"")
+ ELIF std typeface name = "sansserif"
+ THEN out (""27"k"1"")
+ FI.
+
+$opendocml294i$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27"6"); (* Zeichensatz 2 *)
+ out (""18""27"F"27"W0"27"T"27"-0"27"%H"); (* Modifikationen rücksetzen *)
+ out (""27"9"27"O"27"A"12""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ IF pos (material, "nlq") <> 0
+ THEN out (""27"G")
+ ELIF pos (material, "draft") <> 0
+ THEN out (""27"H")
+ ELIF std quality name = "nlq"
+ THEN out (""27"G")
+ ELSE out (""27"H")
+ FI.
+
+$opendocml320$
+ param 2 := (param 2 DIV 36) * 36;
+ prop font := FALSE;
+ out (""27"{"99""27"{"40""); (* Umschaltung auf EPSON-Emulation *)
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"6"); (* Erweiterung des Zeichensatzes *)
+ out (""27"9"27"O"27"x"0"").
+
+$opendoclc10$
+ param 2 := (param 2 DIV 36) * 36;
+ was tall font := TRUE;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"t"1""27"6"); (* Zeichentabelle 4 (Grafik) *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"9"27"r"0"");
+ IF pos (material, "nlq") <> 0
+ THEN out (""27"x"1"")
+ ELIF pos (material, "draft") <> 0
+ THEN out (""27"x"0"")
+ ELIF std quality name = "nlq"
+ THEN out (""27"x"1"")
+ ELSE out (""27"x"0"")
+ FI;
+ IF pos (material, "courier") <> 0
+ THEN out (""27"k"0"")
+ ELIF pos (material, "sansserif") <> 0
+ THEN out (""27"k"1"")
+ ELIF pos (material, "orator1") <> 0
+ THEN out (""27"k"2"")
+ ELIF pos (material, "orator2") <> 0
+ THEN out (""27"k"3"")
+ ELIF std typeface name = "courier"
+ THEN out (""27"k"0"")
+ ELIF std typeface name = "sansserif"
+ THEN out (""27"k"1"")
+ ELIF std typeface name = "orator1"
+ THEN out (""27"k"2"")
+ ELIF std typeface name = "orator2"
+ THEN out (""27"k"3"")
+ FI.
+
+$opendocnx15$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"6"); (* Erweiterung des Zeichensatzes *)
+ out (""27"9"27"x"0"").
+
+$opendocdmp4000$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"m"0""27"R"0""27"9"27"O"27"2"27"6");
+ out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *)
+
+$opendocmt$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"O"27"x"0""27"r"0""27"6");
+ IF feeder name = "tractor"
+ THEN act feeder := feeder name;
+ out (""27"[5{")
+ ELSE out (""27"[0{");
+ IF pos (material, "schacht1") <> 0
+ THEN act feeder := "schacht1"
+ ELIF pos (material, "schacht2") <> 0
+ THEN act feeder := "schacht2"
+ ELSE act feeder := feeder name
+ FI
+ FI.
+
+$opendocdx2100$
+param 2 := (param 2 DIV 36) * 36;
+out (""24""27""64""); (* Reset des Druckers *)
+out (""27"R"0""); (* US-Zeichensatz *)
+out (""27"2" + ""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+out (""27"N"0""); (* skip perforation *)
+out (""27"x"0"" + ""27"r"0""). (* draft und black *)
+
+
+$opendoc120d$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"9"27"O"27"x0"27"2");
+ out (""27"C" + code (param 2 DIV 36)). (* Formularlaenge *)
+
+$opendocc310$
+ param 2 := (param 2 DIV 36) * 36;
+ out (""27""64""27""64""); (* Reset des Druckers *)
+ out (""27"R"0""27"2");
+ out (""27"C" + code (param 2 DIV 36)); (* Formularlaenge *)
+ out (""27"O"27"x"0""27"r"0""27"6");
+ IF feeder name = "tractor"
+ THEN act feeder := feeder name;
+ ELSE IF pos (material, "schacht1") <> 0
+ THEN act feeder := "schacht1"
+ ELIF pos (material, "schacht2") <> 0
+ THEN act feeder := "schacht2"
+ ELSE act feeder := feeder name
+ FI
+ FI.
+
+$openpge$
+ open page :
+ param 1 := 0;
+ param 2 := y step conversion (y margin);
+ x rest := 0;
+ y rest := 0;
+ small := 0;
+ out (""13"").
+$openpgemlsf$
+ open page :
+ param 1 := 0;
+ param 2 := 0;
+ x rest := 0;
+ y rest := 0;
+ small := 0;
+ IF feeder name = "sheet" THEN out (""12"") FI;
+ out (""13"").
+$openpgemtsf$
+ open page :
+ param 1 := 0;
+ param 2 := 0;
+ x rest := 0;
+ y rest := 0;
+ small := 0;
+ IF feeder name = "schacht1"
+ THEN out (""27"[21{"12"")
+ ELIF feeder name = "schacht2"
+ THEN out (""27"[22{"12"")
+ FI;
+ out (""13"").
+
+$openpgec310sf$
+ open page :
+ param 1 := 0;
+ param 2 := 0;
+ x rest := 0;
+ y rest := 0;
+ small := 0;
+ IF feeder name = "schacht1"
+ THEN out (""27""25"1"12"")
+ ELIF feeder name = "schacht2"
+ THEN out (""27""25"2"12"")
+ FI;
+ out (""13"").
+
+$betwoc$
+END PROC open;
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE 1: close document
+ CASE 2: close page
+END SELECT.
+close document :
+$clpge$
+. close page :
+ IF param 1 > 0 THEN out (""12"") FI.
+$clmlsf$
+.close page :
+ IF feeder name = "sheet"
+ THEN out (""27""25""3"")
+ ELIF param 1 > 0
+ THEN out (""12"")
+ FI.
+$clmtsf$
+.close page :
+ IF feeder name <> "tractor"
+ THEN out (""27"[2J")
+ ELIF param 1 > 0
+ THEN out (""12"")
+ FI.
+$clc310sf$
+.close page :
+ IF feeder name = "sheet"
+ THEN out (""27""25"R")
+ ELIF param 1 > 0
+ THEN out (""12"")
+ FI.
+
+$betwce$
+END PROC close;
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE 1: write text
+ CASE 2: write cmd
+ CASE 3: carriage return
+ CASE 4: move
+ CASE 5: draw
+ CASE 6: on
+ CASE 7: off
+ CASE 8: type
+END SELECT.
+
+is underline: bit (modifikations, 0).
+is bold : bit (modifikations, 1).
+is italics : bit (modifikations, 2).
+
+ write text :
+ out subtext (string, param 1, param 2).
+$cmd$
+ write cmd :
+ out subtext (string, param 1, param 2).
+$cmdfx800$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF buffer = "draft"
+ THEN out (""27"x"0"")
+ ELIF buffer = "nlq"
+ THEN out (""27"x"1"")
+ ELIF buffer = "roman"
+ THEN out (""27"k"0"")
+ ELIF buffer = "sansserif"
+ THEN out (""27"k"1"")
+ ELSE out (buffer)
+ FI.
+$cmdpp$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF buffer = "draft"
+ THEN out (""27"H")
+ ELIF buffer = "nlq"
+ THEN out (""27"G")
+ ELSE out (buffer)
+ FI.
+$cmdml182i$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF buffer = "draft"
+ THEN out (""27"I1")
+ ELIF buffer = "nlq"
+ THEN out (""27"I3")
+ ELSE out (buffer)
+ FI.
+$cmdml292el$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF buffer = "draft"
+ THEN out (""27"x"0"")
+ ELIF buffer = "nlq"
+ THEN out (""27"x"1"")
+ ELIF buffer = "courier"
+ THEN out (""27"k"0"")
+ ELIF buffer = "sansserif"
+ THEN out (""27"k"1"")
+ ELIF buffer = "schwarz"
+ THEN out (""27"r0")
+ ELIF buffer = "rot"
+ THEN out (""27"r1")
+ ELIF buffer = "blau"
+ THEN out (""27"r2")
+ ELIF buffer = "violett"
+ THEN out (""27"r3")
+ ELIF buffer = "gelb"
+ THEN out (""27"r4")
+ ELIF buffer = "orange"
+ THEN out (""27"r5")
+ ELIF buffer = "grün"
+ THEN out (""27"r6")
+ ELSE out (buffer)
+ FI.
+$cmdml294i$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF buffer = "draft"
+ THEN out (""27"H")
+ ELIF buffer = "nlq"
+ THEN out (""27"G")
+ ELIF buffer = "schwarz"
+ THEN out (""27"r0")
+ ELIF buffer = "rot"
+ THEN out (""27"r1")
+ ELIF buffer = "blau"
+ THEN out (""27"r2")
+ ELIF buffer = "violett"
+ THEN out (""27"r3")
+ ELIF buffer = "gelb"
+ THEN out (""27"r4")
+ ELIF buffer = "orange"
+ THEN out (""27"r5")
+ ELIF buffer = "grün"
+ THEN out (""27"r6")
+ ELSE out (buffer)
+ FI.
+$cmdlc10$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF buffer = "draft"
+ THEN out (""27"x"0"")
+ ELIF buffer = "nlq"
+ THEN out (""27"x"1"")
+ ELIF buffer = "courier"
+ THEN out (""27"k"0"")
+ ELIF buffer = "sansserif"
+ THEN out (""27"k"1"")
+ ELIF buffer = "orator1"
+ THEN out (""27"k"2"")
+ ELIF buffer = "orator2"
+ THEN out (""27"k"3"")
+ ELIF buffer = "schwarz"
+ THEN out (""27"r"0"")
+ ELIF buffer = "rot"
+ THEN out (""27"r"1"")
+ ELIF buffer = "blau"
+ THEN out (""27"r"2"")
+ ELIF buffer = "violett"
+ THEN out (""27"r"3"")
+ ELIF buffer = "gelb"
+ THEN out (""27"r"4"")
+ ELIF buffer = "orange"
+ THEN out (""27"r"5"")
+ ELIF buffer = "grün"
+ THEN out (""27"r"6"")
+ ELSE out (buffer)
+ FI.
+$cmdmt230$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF feeder name <> "tractor"
+ THEN IF buffer = "schacht1" OR buffer = "schacht2"
+ THEN act feeder := buffer
+ FI
+ ELIF buffer = "schwarz"
+ THEN out (""27"r"0"")
+ ELIF buffer = "magenta"
+ THEN out (""27"r"1"")
+ ELIF buffer = "cyan"
+ THEN out (""27"r"2"")
+ ELIF buffer = "blau"
+ THEN out (""27"r"3"")
+ ELIF buffer = "gelb"
+ THEN out (""27"r"4"")
+ ELIF buffer = "rot"
+ THEN out (""27"r"5"")
+ ELIF buffer = "grün"
+ THEN out (""27"r"6"")
+ ELSE out (buffer)
+ FI.
+
+$cmdc310$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF feeder name <> "tractor"
+ THEN IF buffer = "schacht1" OR buffer = "schacht2"
+ THEN act feeder := buffer
+ FI
+ ELIF buffer = "schwarz"
+ THEN out (""27"r"0"")
+ ELIF buffer = "rot"
+ THEN out (""27"r"1"")
+ ELIF buffer = "blau"
+ THEN out (""27"r"2"")
+ ELIF buffer = "violett"
+ THEN out (""27"r"3"")
+ ELIF buffer = "gelb"
+ THEN out (""27"r"4"")
+ ELIF buffer = "orange"
+ THEN out (""27"r"5"")
+ ELIF buffer = "grün"
+ THEN out (""27"r"6"")
+ ELSE out (buffer)
+ FI.
+
+$cmddx2100$
+ write cmd :
+ buffer := subtext (string, param 1, param 2);
+ IF buffer = "schwarz"
+ THEN out (""27"r"0"")
+ ELIF buffer = "rot"
+ THEN out (""27"r"1"")
+ ELIF buffer = "blau"
+ THEN out (""27"r"2"")
+ ELIF buffer = "violett"
+ THEN out (""27"r"3"")
+ ELIF buffer = "gelb"
+ THEN out (""27"r"4"")
+ ELIF buffer = "orange"
+ THEN out (""27"r"5"")
+ ELIF buffer = "grün"
+ THEN out (""27"r"6"")
+ ELSE out (buffer)
+ FI.
+
+$crs$
+ carriage return :
+ y rest INCR small;
+ x rest := 0;
+ small := 0;
+ out (""13"").
+$moh$
+x steps : param1.
+y steps : param2.
+
+move :
+ IF x steps < 0 OR y steps < 0 THEN stop FI;
+ IF x steps > 0 THEN x move FI;
+ IF y steps > 0 THEN y move FI.
+
+$mofx85$
+x move :
+ high := (x steps + x rest) DIV blankbreite;
+ x rest := (x steps + x rest) MOD blankbreite;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF x rest > 0 AND is slow
+ THEN IF is underline THEN out (" "8"") FI;
+ out (""27"Y"+ code (x rest) + ""0"");
+ x rest TIMESOUT ""0"";
+ x rest := 0
+ FI.
+
+
+$mofx800$
+x move :
+ IF is underline
+ THEN underline x move
+ ELSE simple x move
+ FI.
+
+underline x move:
+ high := (x steps + x rest) DIV blankbreite;
+ low := (x steps + x rest) MOD blankbreite;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF low > 0
+ THEN out (" "8""27"\"+ code (low) + ""0"")
+ FI.
+
+simple x move:
+ out (""27"\");
+ out (code (x steps MOD 256));
+ out (code (x steps DIV 256)).
+
+$modrmx$
+x move :
+ high := (x steps + x rest) DIV blankbreite;
+ low := (x steps + x rest) MOD blankbreite;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF low > 0 AND is slow
+ THEN IF is underline THEN out ("_"8"") FI;
+ IF is condensed
+ THEN high := low;
+ low := 0;
+ out (""27"L"+ code (high) + ""0"");
+ ELSE high := low DIV 2;
+ low := low MOD 2;
+ out (""27"K"+ code (high) + ""0"");
+ FI;
+ high TIMESOUT ""0"";
+ IF is small
+ THEN out (""27"S"1"");
+ small DECR 1;
+ FI;
+ FI;
+ x rest := low.
+
+y move :
+ y rest INCR y steps;
+ IF y rest > 0
+ THEN high := y rest DIV 255;
+ low := y rest MOD 255;
+ IF high > 0 THEN high TIMESOUT ""27"J"255"" FI;
+ IF low > 0 THEN out (""27"J"); out (code (low)) FI;
+ y rest := 0
+ FI.
+
+draw :
+ IF x steps < 0 OR y steps <> 0 OR linetype <> 1
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI.
+
+x draw :
+ out (""27"L");
+ out (code (x steps MOD 256));
+ out (code (x steps DIV 256));
+ x steps TIMESOUT ""1"";
+ IF is small THEN out (""27"S"1"") FI.
+
+$mogp$
+x move :
+ high := (x steps + x rest) DIV blankbreite;
+ x rest := (x steps + x rest) MOD blankbreite;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF x rest > 0 AND is slow
+ THEN IF is underline
+ THEN out (" "13""27"Y");
+ out (code (x pos MOD 256));
+ out (code (x pos DIV 256));
+ x pos TIMESOUT ""0""
+ ELSE out (""27"Y"+ code (x rest) + ""0"");
+ x rest TIMESOUT ""0""
+ FI;
+ x rest := 0
+ FI.
+
+$moml192el$
+x move :
+ high := (x steps + x rest) DIV blankbreite;
+ x rest := (x steps + x rest) MOD blankbreite;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF x rest > 0 AND is slow
+ THEN IF is underline THEN
+ IF prop font THEN
+ out (""27"p"0"" + " "8"" + ""27"p"1"")
+ ELSE
+ out (" "8"")
+ FI;
+ FI;
+ out (""27"Y"+ code (x rest) + ""0"");
+ x rest TIMESOUT ""0"";
+ x rest := 0
+ FI.
+
+$ymodr$
+y move :
+ y rest INCR y steps;
+ IF y rest > 0
+ THEN high := y rest DIV 255;
+ low := y rest MOD 255;
+ IF high > 0 THEN high TIMESOUT ""27"J"255"" FI;
+ IF low > 0 THEN out (""27"J"); out (code (low)) FI;
+ y rest := 0
+ FI.
+
+draw :
+ IF x steps < 0 OR y steps <> 0 OR linetype <> 1
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI.
+
+x draw :
+ out (""27"Y");
+ out (code (x steps MOD 256));
+ out (code (x steps DIV 256));
+ x steps TIMESOUT ""1"".
+
+$onoff$
+ on :
+ IF on string (param 1) <> ""
+ THEN out (on string (param 1));
+ modifikations := modifikations OR param 1
+ ELSE stop
+ FI.
+
+ off :
+ IF off string (param 1) <> ""
+ THEN out (off string (param 1));
+ modifikations := modifikations AND (param 1 XOR -1)
+ ELSE stop
+ FI.
+
+$onoffpp$
+ on :
+ IF on string (param 1) <> "" AND param 1 <> 2
+ THEN out (on string (param 1));
+ modifikations := modifikations OR param 1
+ ELSE stop
+ FI.
+
+ off :
+ IF off string (param 1) <> "" AND param 1 <> 2
+ THEN out (off string (param 1));
+ modifikations := modifikations AND (param 1 XOR -1)
+ ELSE stop
+ FI.
+
+$tyfx85$
+ type :
+ buffer := font string (param 1);
+ out (buffer);
+ restore modifikations;
+ blankbreite := char pitch (param 1, " ");
+ IF pos (buffer, ""27"S") <> 0 THEN small DECR 1 FI.
+
+$tyfx800$
+ type :
+ buffer := font string (param 1);
+ IF was tall font
+ THEN out (""27"w"0"")
+ FI;
+ out (buffer);
+ restore modifikations;
+ blankbreite := char pitch (param 1, " ");
+ was tall font := pos (buffer, ""27"w"1"") <> 0.
+
+$tymx$
+ type :
+ buffer := font string (param 1);
+ blankbreite := char pitch (param 1, " ");
+ is condensed := pos (buffer, ""15"") <> 0;
+ IF pos (buffer, ""27"S") <> 0
+ THEN small DECR 1;
+ is small := TRUE;
+ ELSE is small := FALSE;
+ FI;
+ out (buffer);
+ restore modifikations.
+
+$tyohnesmall$
+ type :
+ buffer := font string (param 1);
+ out (buffer);
+ restore modifikations;
+ blankbreite := char pitch (param 1, " ").
+
+$tyml192el$
+ type :
+ buffer := font string (param 1);
+ out (buffer);
+ restore modifikations;
+ blankbreite := char pitch (param 1, " ");
+ prop font := pos (buffer, ""27"p"1"") <> 0;
+ IF pos (buffer, ""27"S") <> 0 THEN small DECR 1 FI.
+
+$tyml292el$
+ type :
+ buffer := font string (param 1);
+ IF was tall font
+ THEN out (""27""31"0"27"U0")
+ FI;
+ was tall font := pos (buffer, ""27"w"1"") <> 0;
+ change all (buffer, ""27"w"0"", ""27""31"0"27"U0");
+ change all (buffer, ""27"w"1"", ""27""31"1"27"U1");
+ out (buffer);
+ restore modifikations;
+ blankbreite := char pitch (param 1, " ").
+
+$ontyml294i$
+ on :
+ IF on string (param 1) <> "" AND param 1 <> 2
+ THEN out (on string (param 1));
+ modifikations := modifikations OR param 1
+ ELIF param 1 = 4
+ THEN out (""27"%G");
+ modifikations := modifikations OR param 1
+ ELSE stop
+ FI.
+
+ off :
+ IF off string (param 1) <> "" AND param 1 <> 2
+ THEN out (off string (param 1));
+ modifikations := modifikations AND (param 1 XOR -1)
+ ELIF param 1 = 4
+ THEN out (""27"%H");
+ modifikations := modifikations AND (param 1 XOR -1)
+ ELSE stop
+ FI.
+
+ type :
+ buffer := font string (param 1);
+ out (buffer);
+ IF is underline THEN out (on string (1)) FI;
+ IF is bold THEN out (on string (2)) FI;
+ IF is italics THEN out (""27"%G") FI;
+ blankbreite := char pitch (param 1, " ");
+ IF pos (buffer, ""27"S") <> 0 THEN small DECR 1 FI.
+
+$end$
+ restore modifikations:
+ IF is underline THEN out (on string (1)) FI;
+ IF is bold THEN out (on string (2)) FI;
+ IF is italics THEN out (on string (4)) FI.
+
+END PROC execute;
+
+INT VAR reply; DATASPACE VAR ds; FILE VAR file;
+
+PROC printer:
+
+ disable stop;
+ continue (server channel);
+ check error (error message);
+ ds := nilspace;
+ REP forget (ds);
+ execute print;
+ IF is error AND online THEN put error; clear error; FI;
+ PER;
+END PROC printer;
+
+PROC execute print:
+
+ LET ack = 0, fetch code = 11, file type = 1003;
+ enable stop;
+ ds := nilspace;
+ call (father, fetch code, ds, reply);
+ IF reply = ack CAND type (ds) = file type
+ THEN file := sequential file (input, ds);
+ print (file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+END PROC execute print;
+
+PROC check error(TEXT CONST message):
+
+ IF is error
+ THEN clear error; rename myself (message);
+ IF is error THEN end(myself) FI;
+ pause (9000); end(myself);
+ FI;
+END PROC check error;
+
+END PACKET printerdriver
+
+
diff --git a/system/printer-9nadel/0.9/src/printer.neun.nadel b/system/printer-9nadel/0.9/src/printer.neun.nadel
new file mode 100644
index 0000000..00f698b
--- /dev/null
+++ b/system/printer-9nadel/0.9/src/printer.neun.nadel
@@ -0,0 +1,1129 @@
+PACKET driver inst 9 (* Autoren : mov/hjh *)
+ (* Stand : 01.10.88 *)
+
+ DEFINES druckerkanal,
+ treiber einrichten:
+
+
+LET up = ""3""13""5"",
+
+ generator name = "printer.neun.nadel",
+
+ description file name = "beschreibungen9",
+ module file name = "module9";
+
+
+INT VAR pr channel,
+ positioning,
+ quality,
+ sheet feeder,
+ service option;
+TEXT VAR fonttab name :: "",
+ driver name :: "";
+TEXT VAR inp;
+BOOL VAR was esc;
+
+
+PROC druckerkanal (INT CONST channel) :
+
+ serverchannel (channel)
+
+END PROC druckerkanal;
+
+INT PROC druckerkanal : pr channel END PROC druckerkanal;
+
+
+PROC treiber einrichten:
+
+ treiber einrichten (0)
+END PROC treiber einrichten;
+
+PROC treiber einrichten (INT CONST service opt):
+
+ ask for print channel;
+ main menu;
+ IF installed
+ THEN generate printer spool
+ ELSE inform about restart
+ FI.
+
+ ask for printchannel:
+ inits;
+ page;
+ headline ("Druckerkanal - Einstellung");
+ cursor (1, 15);
+ putline ("Hinweis: Die Druckerkanalnummer kann auch nachträglich mit");
+ putline (" 'druckerkanal (Kanalnummer)' in der Task """ +
+ name (myself) + """");
+ putline (" verändert werden.");
+ REP
+ cursor (1, 10);
+ put (""5"EUMEL-Kanalnummer des Druckerkanals:");
+ get (pr channel);
+ disable stop;
+ druckerkanal (pr channel);
+ BOOL VAR no error :: NOT is error;
+ IF is error
+ THEN cursor (1, 7);
+ put error;
+ putline ("Eingabe korrigiert wiederholen!")
+ FI;
+ clear error;
+ enable stop
+ UNTIL no error PER.
+
+ inits:
+ line;
+ IF single task
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+ FI;
+ command dialogue (TRUE);
+ IF name (myself) <> "PRINTER"
+ THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ +
+ name (myself) + """ !");
+ IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?")
+ THEN rename myself ("PRINTER")
+ FI
+ FI;
+ INT VAR choice;
+ service option := service opt.
+
+ single task: (pcb (9) AND 255) = 1.
+
+ main menu:
+ BOOL VAR installed :: FALSE;
+ REP
+ show main menu;
+ get choice;
+ treat choice
+ UNTIL was esc OR installed PER.
+
+ show main menu:
+ page;
+ headline ("Hauptmenü 9-Nadel-Drucker");
+ putline (" 1. Brother");
+ putline (" 2. Citizen");
+ putline (" 3. C. Itoh");
+ putline (" 4. Epson");
+ putline (" 5. Fujitsu");
+ putline (" 6. IBM");
+ putline (" 7. Mannesmann - Tally");
+ putline (" 8. OKI");
+ putline (" 9. Schneider");
+ putline ("10. Star").
+
+ get choice:
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Installation abbrechen");
+ ask user (10).
+
+ treat choice:
+ SELECT int (inp) OF
+ CASE 1: brother menu
+ CASE 2: citizen menu
+ CASE 3: c itoh menu
+ CASE 4: epson menu
+ CASE 5: fujitsu menu
+ CASE 6: ibm menu
+ CASE 7: mannesmann menu
+ CASE 8: oki menu
+ CASE 9: schneider menu
+ CASE 10: star menu
+ END SELECT.
+
+
+ brother menu:.
+
+ citizen menu:
+ page;
+ headline ("Citizen - Menü");
+ putline (" 1. 120-D");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ citi120d inst
+ FI.
+
+ citi120d inst:
+ putline ("Citizen 120-D");
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S1 S2 S3 S4 S5 S6 S7 S8");
+ putline ("egal OFF OFF egal egal egal egal egal");
+ show control options ("");
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("citi120d");
+ installed := TRUE
+ FI.
+
+ c itoh menu:
+ page;
+ headline ("C. Itoh - Menü");
+ putline (" 1. C 310 CXP");
+ putline (" 2. C 315 CXP");
+ putline (" 3. CI-3500");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (3);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ IF choice = 3
+ THEN ci3500 inst
+ ELSE c310 inst
+ FI
+ FI.
+
+ c310 inst:
+ IF choice = 1
+ THEN putline ("C. Itoh C 310 CXP")
+ ELSE putline ("C. Itoh C 315 CXP")
+ FI;
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):");
+ putline ("- 00: Epson-Modus (02)");
+ putline ("- 22: nur Wagenrücklauf (01)");
+ show control options ("std speed, paperfeed");
+ show material options ("slow, fast, schacht1, schacht2");
+ show command options ("schacht1, schacht2, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for positioning;
+ ask for paper feed;
+ IF all right
+ THEN get fonttable ("fonttab.7.cxp");
+ generate ("citohc310cxp");
+ adjust positioning;
+ adjust paper feed;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ ci3500 inst:
+ putline ("C. Itoh CI-3500");
+ line;
+ putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):");
+ putline ("- 26: nur Wagenrücklauf (1)");
+ putline ("- 49: 17,1 Zeichen pro Zoll (17)");
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.10");
+ generate ("citohci3500");
+ adjust positioning;
+ installed := TRUE
+ FI.
+
+ epson menu:
+ page;
+ headline ("Epson - Menü");
+ putline (" 1. MX 80 Typ III");
+ putline (" 2. MX 100 Typ III");
+ putline (" 3. LX 800");
+ putline (" 4. LX 1000");
+ putline (" 5. FX 85");
+ putline (" 6. FX 105");
+ putline (" 7. FX 800 oder FX 850");
+ putline (" 8. FX 1000 oder FX 1050");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (8);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1, 2: mx80 inst
+ CASE 3, 4: lx800 inst
+ CASE 5, 6: fx85 inst
+ CASE 7, 8: fx800 inst
+ END SELECT
+ FI.
+
+ mx80 inst:
+ IF choice = 1
+ THEN putline ("Epson MX 80 Typ III")
+ ELSE putline ("Epson MX 100 Typ III")
+ FI;
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.1");
+ generate ("mx");
+ adjust positioning;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ lx800 inst:
+ IF choice = 3
+ THEN putline ("Epson LX 800")
+ ELSE putline ("Epson LX 1000")
+ FI;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4");
+ putline ("egal egal egal egal egal egal egal egal egal *) OFF OFF");
+ putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug");
+ show control options ("std speed, std quality, std typeface");
+ show material options ("slow, fast, draft, nlq, roman, sansserif");
+ show command options ("draft, nlq, roman, sansserif");
+ ask for positioning;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.20.lx");
+ generate ("lx800");
+ adjust positioning;
+ adjust quality;
+ IF choice = 4 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ fx85 inst:
+ IF choice = 5
+ THEN putline ("Epson FX 85")
+ ELSE putline ("Epson FX 105")
+ FI;
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4");
+ putline ("egal egal egal ON egal egal egal egal egal egal OFF OFF");
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("fx85");
+ adjust positioning;
+ IF choice = 6 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ fx800 inst:
+ IF choice = 7
+ THEN putline ("Epson FX 800 oder FX 850")
+ ELSE putline ("Epson FX 1000 oder FX 1050")
+ FI;
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4");
+ putline ("egal egal egal ON egal egal egal egal egal *) OFF OFF");
+ putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug");
+ show control options ("std quality, std typeface");
+ show material options ("draft, nlq, roman, sansserif");
+ show command options ("draft, nlq, roman, sansserif");
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.20");
+ generate ("fx800");
+ adjust quality;
+ IF choice = 8 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ fujitsu menu:
+ page;
+ headline ("Fujitsu - Menü");
+ putline (" 1. DX 2100");
+ putline (" 2. DX 2200");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (2);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1,2 : dx2100 inst
+ END SELECT
+ FI.
+
+ dx2100 inst:
+ IF choice = 1
+ THEN putline ("Fujitsu DX 2100")
+ ELSE putline ("Fujitsu DX 2200")
+ FI;
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("SW1-1 SW1-2 SW1-3 SW1-4 SW1-5 SW1-6 SW1-7 SW1-8 SW2-1 SW2-2 SW2-3 SW2-4");
+ putline ("egal egal egal egal egal egal egal egal egal *) OFF OFF");
+ putline ("*) ON: Einzelblatteinzug, OFF: kein Einzug");
+ show control options ("std speed, paper feed");
+ show material options ("slow, fast");
+ show command options ("schwarz, rot, blau, violett, gelb, rot, grün");
+ ask for positioning;
+ ask for paper feed;
+ IF all right
+ THEN get fonttable ("fonttab.7.fuj");
+ generate ("fujdx2100");
+ adjust positioning;
+ adjust paper feed;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+
+
+ ibm menu:
+ page;
+ headline ("IBM - Menü");
+ putline (" 1. Grafikdrucker (""80 Zeichen breit"")");
+ putline (" 2. Grafikdrucker (""136 Zeichen breit"")");
+ putline (" 3. Proprinter/Grafikdrucker II (""80 Zeichen breit"")");
+ putline (" 4. Proprinter/Grafikdrucker II (""136 Zeichen breit"")");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (4);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ IF choice = 1 OR choice = 2
+ THEN ibmgp inst
+ ELSE ibmpp inst
+ FI
+ FI.
+
+ ibmgp inst:
+ IF choice = 1
+ THEN putline ("IBM Grafikdrucker (""80 Zeichen breit"")")
+ ELSE putline ("IBM Grafikdrucker (""136 Zeichen breit"")")
+ FI;
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.10");
+ generate ("ibmgp");
+ adjust positioning;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ ibmpp inst:
+ IF choice = 3
+ THEN putline ("IBM Proprinter/Grafikdrucker II (""80 Zeichen breit"")")
+ ELSE putline ("IBM Proprinter/Grafikdrucker II (""136 Zeichen breit"")")
+ FI;
+ show control options ("std speed, std quality");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq");
+ ask for positioning;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.10");
+ generate ("ibmpp");
+ adjust positioning;
+ adjust quality;
+ IF choice = 4 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ mannesmann menu:
+ page;
+ headline ("Mannesmann - Tally - Menü");
+ putline (" 1. MT 230");
+ putline (" 2. MT 340");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (2);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ IF choice = 1
+ THEN mt230 inst
+ ELSE mt340 inst
+ FI
+ FI.
+
+ mt230 inst:
+ putline ("Mannesmann-Tally MT 230");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Der Drucker muß auf den ANSI+EPSON - Modus eingestellt werden.");
+ putline ("(Siehe: MT 230 Anwenderhandbuch, S. 4-145)");
+ show control options ("std speed, paperfeed");
+ show material options ("slow, fast, schacht1, schacht2");
+ show command options ("schacht1, schacht2, schwarz, magenta, cyan, blau, gelb, rot, grün");
+ ask for positioning;
+ ask for paper feed;
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("mt230");
+ adjust positioning;
+ adjust paper feed;
+ do ("papersize (39.37, 30.48)");
+ installed := TRUE
+ FI.
+
+ mt340 inst:
+ putline ("Mannesmann-Tally MT 340");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Der Drucker muß auf den ANSI+EPSON - Modus eingestellt werden.");
+ putline ("(Siehe: MT 340 Anwenderhandbuch, S. 4-104)");
+ show control options ("std speed, paperfeed");
+ show material options ("slow, fast, schacht1, schacht2");
+ show command options ("schacht1, schacht2, schwarz, magenta, cyan, blau, gelb, rot, grün");
+ ask for positioning;
+ ask for paper feed;
+ IF all right
+ THEN get fonttable ("fonttab.7.mt");
+ generate ("mt340");
+ adjust positioning;
+ adjust paper feed;
+ do ("papersize (39.37, 30.48)");
+ installed := TRUE
+ FI.
+
+ oki menu:
+ page;
+ headline ("OKI - Menü");
+ putline (" 1. MICROLINE 182 IBM-kompatibel");
+ putline (" 2. MICROLINE 183 IBM-kompatibel");
+ putline (" 3. MICROLINE 192 ELITE");
+ putline (" 4. MICROLINE 193 ELITE");
+ putline (" 5. MICROLINE 292 ELITE");
+ putline (" 6. MICROLINE 293 ELITE");
+ putline (" 7. MICROLINE 294 IBM-kompatibel");
+ putline (" 8. MICROLINE 320");
+ putline (" 9. MICROLINE 321");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (9);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ SELECT choice OF
+ CASE 1, 2: ml182i inst
+ CASE 3, 4: ml192el inst
+ CASE 5, 6: ml292el inst
+ CASE 7 : ml294i inst
+ CASE 8, 9: ml320 inst
+ END SELECT
+ FI.
+
+ ml182i inst:
+ IF choice = 1
+ THEN putline ("OKI Microline 182 IBM-kompatibel")
+ ELSE putline ("OKI Microline 183 IBM-kompatibel")
+ FI;
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S-1 S-2 S-3 S-4 S-5 S-6 S-7 S-8");
+ putline ("egal egal OFF egal egal OFF egal OFF");
+ show control options ("std speed, std quality");
+ show material options ("slow, fast, draft, nlq");
+ show command options ("draft, nlq");
+ ask for positioning;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.10");
+ generate ("okiml182i");
+ adjust positioning;
+ adjust quality;
+ IF choice = 2 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ ml192el inst:
+ IF choice = 3
+ THEN putline ("OKI Microline 192 ELITE (IBM/EPSON-kompatibel)")
+ ELSE putline ("OKI Microline 193 ELITE (IBM/EPSON-kompatibel)")
+ FI;
+ line;
+ putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):");
+ putline ("- 13: Automatic Line Feed: Nein");
+ putline ("- 18: Compatibility: EPSON FX");
+ putline ("(Außerdem: Jumper SP5 in Position 'B')");
+ show control options ("std speed, paperfeed");
+ show material options ("slow, fast");
+ ask for positioning;
+ ask for paper feed;
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("okiml192el");
+ adjust positioning;
+ adjust paper feed;
+ IF choice = 4 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ ml292el inst:
+ IF choice = 5
+ THEN putline ("OKI Microline 292 ELITE (IBM/EPSON-kompatibel)")
+ ELSE putline ("OKI Microline 293 ELITE (IBM/EPSON-kompatibel)")
+ FI;
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):");
+ putline ("- Automatic Line Feed: NO");
+ putline ("- Compatibility: EPSON EX");
+ putline ("(Außerdem: Jumper SP5 in Position 'B')");
+ show control options ("paperfeed, std quality, std typeface");
+ show material options ("draft, nlq, courier, sansserif");
+ show command options ("draft, nlq, courier, sansserif");
+ putline ("schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for paper feed;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.20");
+ generate ("okiml292el");
+ adjust paper feed;
+ adjust quality;
+ IF choice = 6 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ ml294i inst:
+ putline ("OKI Microline 294 IBM-kompatibel");
+ putline ("Der Druckertreiber unterstützt auch den Farbdruck mit entsprechendem");
+ putline ("Farbband.");
+ line;
+ putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):");
+ putline ("- Proportional Spacing: NO");
+ putline ("- Automatic Line Feed: NO");
+ putline ("- Compatibility: PROPRINTER XL");
+ show control options ("paperfeed, std quality");
+ show material options ("draft, nlq");
+ show command options ("draft, nlq, schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for paper feed;
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.10");
+ generate ("okiml294i");
+ adjust paper feed;
+ adjust quality;
+ do ("papersize (34.544, 30.48)");
+ installed := TRUE
+ FI.
+
+ ml320 inst:
+ IF choice = 8
+ THEN putline ("OKI Microline 320 IBM/EPSON-kompatibel")
+ ELSE putline ("OKI Microline 321 IBM/EPSON-kompatibel")
+ FI;
+ line;
+ putline ("Der Drucker muß so konfiguriert sein (Druckmenü des Druckers):");
+ putline ("- Automatic Line Feed: Nein");
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("okiml320");
+ adjust positioning;
+ IF choice = 9 THEN do ("papersize (34.544, 30.48)") FI;
+ installed := TRUE
+ FI.
+
+ schneider menu:
+ page;
+ headline ("Schneider - Menü");
+ putline (" 1. DMP 4000");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (1);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ dmp4000 inst
+ FI.
+
+ dmp4000 inst:
+ putline ("Schneider DMP 4000");
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("DS1-4 übrige Schalter");
+ putline (" OFF egal");
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("dmp4000");
+ adjust positioning;
+ do ("papersize (39.37, 30.48)");
+ installed := TRUE
+ FI.
+
+ star menu:
+ page;
+ headline ("Star - Menü");
+ putline (" 1. LC-10 (auch LC-10 Colour)");
+ putline (" 2. NX-15");
+ putline (" 3. ND-10");
+ putline (" 4. ND-15");
+ putline (" 5. NR-10");
+ putline (" 6. NR-15");
+ cursor (1,24);
+ put ("CR: Eingabe ESC: Zurück zum Hauptmenü");
+ ask user (6);
+ page;
+ choice := int (inp);
+ IF was esc
+ THEN was esc := FALSE
+ ELSE headline ("");
+ putline ("Druckertyp:");
+ IF choice = 1
+ THEN lc10 inst
+ ELIF choice = 2
+ THEN nx15 inst
+ ELSE nd10 inst
+ FI
+ FI.
+
+ lc10 inst:
+ putline ("Star LC-10 oder LC-10 Colour");
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S1-1 S1-2 S1-3 S1-4 S1-5 S1-6 S1-7 S1-8 S2-1 S2-2 S2-3 S2-4");
+ putline ("egal egal egal *) egal EIN egal EIN egal egal egal egal");
+ putline ("*) AUS: Einzelblatteinzug, EIN: kein Einzug");
+ show control options ("std quality, std typeface");
+ show material options ("draft, nlq, courier, sansserif, orator1, orator2");
+ show command options ("draft, nlq, courier, sansserif, orator1, orator2");
+ putline ("schwarz, rot, blau, violett, gelb, orange, grün");
+ ask for quality;
+ IF all right
+ THEN get fonttable ("fonttab.20.lc");
+ generate ("starlc10");
+ adjust quality;
+ do ("papersize (21.0, 30.48)");
+ installed := TRUE
+ FI.
+
+ nx15 inst:
+ putline ("Star NX-15");
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S1-4 S1-8 S2-5 übrige Schalter");
+ putline ("EIN EIN EIN egal");
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("starnx15");
+ adjust positioning;
+ do ("papersize (36.0, 30.48)");
+ installed := TRUE
+ FI.
+
+ nd10 inst:
+ IF choice = 3
+ THEN putline ("Star ND-10");
+ ELIF choice = 4
+ THEN putline ("Star ND-15");
+ ELIF choice = 5
+ THEN putline ("Star NR-10");
+ ELSE putline ("Star NR-15");
+ FI;
+ line;
+ putline ("Die DIP-Schalter müssen so eingestellt sein:");
+ putline ("S1-5 S1-6 S2-2 übrige Schalter");
+ putline ("EIN EIN EIN egal");
+ show control options ("std speed");
+ show material options ("slow, fast");
+ ask for positioning;
+ IF all right
+ THEN get fonttable ("fonttab.7");
+ generate ("starnx15");
+ adjust positioning;
+ IF choice = 3 OR choice = 5
+ THEN do ("papersize (21.0, 30.48)")
+ ELSE do ("papersize (36.0, 30.48)")
+ FI;
+ installed := TRUE
+ FI.
+
+generate printer spool:
+ IF service opt = 0
+ THEN forget (generator name, quiet);
+ forget (driver name, quiet)
+ FI;
+ eumel must advertise;
+ cursor (1, 10);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (2);
+ putline ("Hinweis: Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline (" mit 'treiber einrichten' aufgerufen werden, wenn ein anderer");
+ putline (" Drucker eingesetzt werden soll.");
+ line (2);
+ put ("Generierung beendet, weiter mit 'SV'");
+ break (quiet);
+ do ("spool manager (PROC printer)").
+
+ inform about restart:
+ page;
+ putline ("Es ist kein Druckertreiber installiert worden!");
+ line;
+ putline ("Dieses Installationsprogramm kann in der Task """ + name (myself) + """");
+ putline ("mit 'treiber einrichten' erneut aufgerufen werden.");
+ line.
+
+END PROC treiber einrichten;
+
+PROC headline (TEXT CONST header):
+
+ cursor (13,1);
+ putline ("E U M E L - Druckertreiber - Installations - Programm");
+ cursor (40 - LENGTH header DIV 2, 2);
+ put (header);
+ line (2)
+END PROC headline;
+
+PROC ask user (INT CONST max choice):
+
+ TEXT VAR exit;
+ inp := "";
+ REP
+ cursor (1,23);
+ IF inp = ""
+ THEN put ("Ihre Wahl (Nummer eingeben):")
+ ELSE put ("FEHLER! Eingabe korrigieren:")
+ FI;
+ editget (inp, ""27"", "", exit);
+ was esc := exit = ""27"";
+ UNTIL was esc OR ok PER.
+
+ ok:
+ int (inp) > 0 AND int (inp) <= max choice AND last conversion ok.
+END PROC ask user;
+
+PROC show control options (TEXT CONST options):
+
+ line;
+ putline ("Steuerprozeduren in der Task """ + name (myself) + """:");
+ write ("papersize, top margin");
+ IF options <> ""
+ THEN put (",");
+ putline (options)
+ FI
+END PROC show control options;
+
+PROC show material options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche Materialwerte (#material(""..."")#):");
+ putline (options)
+END PROC show material options;
+
+PROC show command options (TEXT CONST options):
+
+ line;
+ putline ("Mögliche direkte Druckeranweisungen (#""...""#):");
+ putline (options)
+END PROC show command options;
+
+PROC ask for positioning:
+
+ line (2);
+ putline ("Positionierung in x-Richtung:");
+ line;
+ REP out (up);
+ IF yes ("in Mikroschritten (genauer, aber langsamer)")
+ THEN positioning := 1; LEAVE ask for positioning
+ FI;
+ out (up);
+ IF yes ("in Blanks (schneller, aber ungenauer)")
+ THEN positioning := 2; LEAVE ask for positioning
+ FI;
+ PER
+END PROC ask for positioning;
+
+PROC ask for quality:
+
+ line (2);
+ putline ("Standard - Druckqualität:");
+ line;
+ REP out (up);
+ IF yes ("Draft Quality (schneller, aber nicht so schön)")
+ THEN quality := 1; LEAVE ask for quality
+ FI;
+ out (up);
+ IF yes ("Near Letter Quality (schöner, aber langsamer)")
+ THEN quality := 2; LEAVE ask for quality
+ FI;
+ PER
+END PROC ask for quality;
+
+PROC ask for paper feed:
+
+ line (2);
+ putline ("Einzelblatteinzug:");
+ line;
+ REP out (up);
+ IF yes ("kein Einzelblatteinzug vorhanden")
+ THEN sheet feeder := 0; LEAVE ask for paper feed
+ FI;
+ out (up);
+ IF yes ("Einzelblatteinzug vorhanden")
+ THEN sheet feeder := 1; LEAVE ask for paper feed
+ FI;
+ PER
+END PROC ask for paper feed;
+
+BOOL PROC all right:
+
+ line (3);
+ cursor (1,23);
+ yes ("Soll der ausgewählte Druckertreiber installiert werden")
+END PROC all right;
+
+PROC get fonttable (TEXT CONST name):
+
+ fonttab name := name;
+ from archive ((description file name & module file name & fonttab name)
+ - all);
+ fonttable (fonttab name);
+ command dialogue (FALSE);
+ save (fonttab name, /"configurator");
+ IF service option = 0
+ THEN forget (fonttab name)
+ FI;
+ command dialogue (TRUE);
+END PROC get fonttable;
+
+PROC from archive (THESAURUS CONST files):
+
+ IF highest entry (files) > 0
+ THEN fetch from archive;
+ release (archive);
+ putline ("Archiv abgemeldet !")
+ FI.
+
+ fetch from archive:
+ THESAURUS VAR thes :: files;
+ REP
+ ask for archive;
+ reserve archive;
+ fetch (thes / ALL archive, archive);
+ thes := thes - all
+ UNTIL highest entry (thes) = 0 PER.
+
+ask for archive:
+ line;
+ putline ("Bitte Archiv mit den Dateien");
+ TEXT VAR buffer;
+ INT VAR index :: 0;
+ REP
+ get (thes, buffer, index);
+ putline (" " + buffer)
+ UNTIL index = 0 PER;
+ putline ("einlegen !");
+ line;
+ putline ("Wenn eingelegt: Taste drücken !");
+ inchar (buffer).
+
+reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop.
+
+END PROC from archive;
+
+THESAURUS OP & (TEXT CONST left, right):
+ THESAURUS VAR result := empty thesaurus;
+ insert (result, left);
+ insert (result, right);
+ result
+END OP &;
+
+THESAURUS OP & (THESAURUS CONST left, TEXT CONST right):
+ THESAURUS VAR result := left;
+ insert (result, right);
+ result
+END OP &;
+
+PROC generate (TEXT CONST name):
+
+ open files;
+ read description;
+ build programme;
+ insert programme;
+ forget files.
+
+ open files:
+ line (5);
+ cursor (1, 20);
+ putline (""4"Bitte warten !");
+ putline (" - Der Treiber wird generiert.");
+ driver name := "printer." + name + "(generiert)";
+ IF exists (driver name)
+ THEN forget (driver name, quiet)
+ FI;
+ FILE VAR des file :: sequential file (modify, description file name),
+ mod file :: sequential file (modify, module file name),
+ driver file :: sequential file (output, driver name).
+
+ read description:
+ to line (des file, 1);
+ col (des file, 1);
+ downety (des file, "$" + name + "$");
+ IF eof (des file)
+ THEN errorstop ("Beschreibung von """ + name + """ nicht im"13""10"" +
+ "Descriptions-File enthalten")
+ FI;
+ TEXT VAR description :: "",
+ record;
+ BOOL VAR done :: FALSE;
+ read record (des file, record);
+ record := subtext (record, col (des file) + LENGTH name + 2);
+ WHILE NOT eof (des file) AND NOT done REP
+ treat record
+ PER.
+
+ treat record:
+ INT VAR dollar pos :: pos (record, "$");
+ IF dollar pos = 0
+ THEN description CAT compress (record);
+ down (des file);
+ read record (des file, record)
+ ELSE description CAT compress (subtext (record, 1, dollar pos - 1));
+ col (des file, dollar pos);
+ done := TRUE;
+ FI.
+
+ build programme:
+ get module name;
+ WHILE still modules REP
+ find module;
+ transfer module;
+ get module name
+ PER.
+
+ get module name:
+ INT VAR semicol pos :: pos (description, ";");
+ TEXT VAR module name;
+ IF semicol pos > 0
+ THEN module name := subtext (description, 1, semicol pos - 1);
+ description := subtext (description, semicol pos + 1)
+ ELSE module name := description;
+ description := ""
+ FI.
+
+ still modules:
+ module name <> "" OR description <> "".
+
+ find module:
+ to line (mod file, 1);
+ col (mod file, 1);
+ downety (mod file, "$" + module name + "$");
+ IF eof (mod file)
+ THEN errorstop ("Modul """ + module name + """ nicht im"13""10"" +
+ "Modul-File enthalten")
+ FI.
+
+ transfer module:
+ done := FALSE;
+ read record (mod file, record);
+ record := subtext (record, col (mod file) + LENGTH module name + 2);
+ WHILE NOT eof (mod file) AND NOT done REP
+ transfer record
+ PER.
+
+ transfer record:
+ dollar pos := pos (record, "$");
+ IF dollar pos = 0
+ THEN write (driver file, compress (record));
+ line (driver file);
+ down (mod file);
+ read record (mod file, record)
+ ELSE write (driver file, compress (subtext (record, 1,
+ dollar pos - 1)));
+ col (mod file, dollar pos);
+ done := TRUE;
+ cout (line no (mod file))
+ FI.
+
+ insert programme:
+ IF online
+ THEN putline (" - Der Treiber wird insertiert.")
+ FI;
+ check off;
+ insert (driver name).
+
+ forget files:
+ IF service option = 0
+ THEN forget (description file name, quiet);
+ forget (module file name, quiet)
+ FI.
+END PROC generate;
+
+PROC adjust positioning:
+
+ IF positioning = 1
+ THEN do ("std speed (""slow"")")
+ ELSE do ("std speed (""fast"")")
+ FI
+END PROC adjust positioning;
+
+PROC adjust quality:
+
+ IF quality = 1
+ THEN do ("std quality (""draft"")")
+ ELSE do ("std quality (""nlq"")")
+ FI
+END PROC adjust quality;
+
+PROC adjust paper feed:
+
+ IF sheet feeder = 1
+ THEN do ("paper feed (""sheet"")")
+ ELSE do ("paper feed (""tractor"")")
+ FI
+END PROC adjust paperfeed;
+
+treiber einrichten
+
+END PACKET driver inst 9
+
diff --git a/system/printer-laser/4/doc/readme b/system/printer-laser/4/doc/readme
new file mode 100644
index 0000000..019d75c
--- /dev/null
+++ b/system/printer-laser/4/doc/readme
@@ -0,0 +1,155 @@
+Treiber-Installations-Programm für Laserdrucker 21. 2.1989
+
+
+1. Installations- und Gebrauchsanleitung
+
+Einrichten
+So wird das Treiber-Installationsprogramm eingerichtet:
+
+ Richten Sie die Task PRINTER als Sohn von SYSUR ein :
+
+ begin ("PRINTER", "SYSUR")
+
+ Geben Sie in der Task PRINTER nacheinander folgende Kommandos
+ ein, die Sie jeweils mit der ENTER-Taste bestätigen:
+
+ archive ("std.printer")
+ fetch("laser.inserter",archive)
+ insert ("laser.inserter")
+
+Das Programm wird dann insertiert.
+
+
+Menüsystem
+Das Installationsprogramm zeigt nun eine Liste von Druckerherstellern.
+Wählen Sie den Hersteller Ihres Druckers aus! Hiernach wird eine Liste
+der unterstützten Drucker dieses Herstellers gezeigt. Wählen Sie hier
+den passenden Typ aus!
+Das Installationsprogramm fragt nun nach der Art der Druckerschnittstelle.
+Die Druckerhardware muß wie hier angegeben konfiguriert sein, wenn sie
+mit dem ausgewählten Treiber betrieben werden soll.
+
+Das Installationsprogramm kann mit 'treiber einrichten' erneut aufgerufen
+werden. Die Druckerschnittstelle kann mit 'printer setup' nachträglich
+umkonfiguriert werden.
+
+2. Druckertreiber-Auswahl
+
+Verwendung nicht im Menü enthaltener Drucker
+Für den Fall, daß Sie genau Ihren Drucker im Menü nicht finden,
+müssen Sie herausfinden (Druckerhandbuch, -händler!),
+welchen Drucker Ihr Drucker emuliert oder welchem er ähnlich ist.
+(Die meisten Laserdrucker verfügen über eine HP-Laserjet Emulation).
+
+
+3. Steuerungsmöglichkeiten und Spezialfeatures
+
+Einige Treiber bieten bestimmte Einstellungsmöglichkeiten.
+Die Einstellungen können über
+- Steuerprozeduren
+- Materialanweisungen bzw.
+- direkte Druckeranweisungen
+vorgenommen werden.
+
+Steuerprozeduren
+setzen Einstellungen, die für alle Dokumente (Druckdateien) gelten
+sollen. Die Prozeduren müssen in der Druckspooltask (meist: "PRINTER")
+aufgerufen werden. Vor Aufruf der Prozeduren muß das Spoolkommando
+'stop spool' gegeben werden!
+
+
+
+PROC papersize (REAL CONST breite, länge)
+ Dient zur Einstellung der Größe der physikalisch beschreibbaren
+ Fläche.
+ Beispiel: papersize (21.0, 29.7)
+ (Standardeinstellung für DIN A4 Format)
+
+PROC papersize
+ Informationsprozedur
+
+Die Änderungen, die Sie in der Druckspooltask vorgenommen haben
+werden erst wirksam, nachdem das Spool-Kommando 'start spool' ge­
+geben und die Druckspooltask verlassen wurde.
+
+
+
+Materialanweisungen \#material("...")\#
+müssen in der Druckdatei vor dem ersten druckbaren Zeichen stehen und
+setzen Einstellungen für eine ganze Datei. (Materialanweisungen haben
+für die jeweilige Datei Vorrang vor den durch Steuerprozeduren einge­
+stellten Standardwerten. Diese werden durch die Materialanweisung aber
+nicht geändert.)
+
+Beispiel: \#material("landscape")\# oder \#material("quer")\#
+ Der Druckertreiber stellt sich auf Querdruck ein. Für das
+ Papierformat werden die
+ durch papersize eingestellten Werte vertauscht angenommen.
+ Es sollten nur Schrifttypen verwendet werden, die auch im
+ Landscape-Modus vorhanden sind.
+
+
+- Es darf in einer Datei nur eine Materialanweisung stehen! Sollen meh­
+ rere Einstellungen vorgenommen werden, müssen sie in einer Anweisung
+ erscheinen. Beispiel: \#material("quer;2")\#
+
+- Achten Sie bei Materialanweisungen
+ besonders auf korrekte Schreibweise! Es werden nur Kleinbuchstaben
+ berücksichtigt! Also: \#"quer"\# und keinesfalls \#"QUER"\#!!!
+
+- Bei Laserdruckern gebräuchliche Materialanweisungen sind:
+ - landscape (quer)
+ - manual
+ - tray
+
+direkte Druckeranweisungen \#"..."\#
+gelten ab der Position, an der sie in der Datei auftreten. Sie haben
+(sofern sie erlaubt sind,) Vorrang vor Standardeinstellungen und
+Materialeinstellungen.
+
+
+- Direkte Druckeranweisungen werden vom EUMEL-Drucker ignoriert und
+ nur vom Druckertreiber in eine Kommando-Sequenz umgesetzt. Es kann
+ daher vorkommen, daß (z.B. bei Spaltendruck) unerwartete Ergebnisse
+ erscheinen, weil der EUMEL-Drucker dann den Text in einer anderen
+ Reihenfolge an den Drucker sendet, als er in der Datei steht, die
+ mit dem direkten Druckerkommando gesetzte Modifikation aber (z.B.
+ für beide Spalten) unerwünscht erhalten bleibt. Direkte
+ Druckeranweisungen, die das Schriftformat verändern,
+ sollten grundsätzlich nicht gegeben werden.
+
+
+4. Spezialfeatures:
+
+Die Druckertreiber für die Drucker APPLE-Laserwriter und NEC LC-08
+verfügen über Anweisungen zum Zeichnen einer Linie, Box oder eines Kuchen-
+stücks, die als direkte Druckeranweisungen in ELAN-Syntax gegeben werden
+müssen.
+Folgende Anweisungen stehen zur Verfügung:
+
+PROC line (REAL CONST x offset, y offset, width, height, line width) :
+
+PROC x line (REAL CONST x offset, y offset, width, line width) :
+
+PROC y line (REAL CONST x offset, y offset, height, line width) :
+
+PROC box (REAL CONST x offset, y offset, width, height, line width, pattern):
+
+PROC box shade (REAL CONST x offset, y offset, width, height, pattern) :
+
+PROC box frame (REAL CONST x offset, y offset, width, height, line width) :
+
+PROC cake (REAL CONST x offset, y offset, radius, start angle, sweep angle,
+ line width, pattern) :
+
+PROC cake shade (REAL CONST x offset, y offset, radius, start angle,
+ sweep angle, pattern) :
+
+PROC cake frame (REAL CONST x offset, y offset, radius, start angle,
+ sweep angle, line width) :
+
+
+
+
+
+
diff --git a/system/printer-laser/4/source-disk b/system/printer-laser/4/source-disk
new file mode 100644
index 0000000..d21e78b
--- /dev/null
+++ b/system/printer-laser/4/source-disk
@@ -0,0 +1 @@
+grundpaket/08_std.printer_laser.img
diff --git a/system/printer-laser/4/src/fonttab.apple.laserwriter b/system/printer-laser/4/src/fonttab.apple.laserwriter
new file mode 100644
index 0000000..bee2d6a
--- /dev/null
+++ b/system/printer-laser/4/src/fonttab.apple.laserwriter
Binary files differ
diff --git a/system/printer-laser/4/src/fonttab.canon.lbp-8 b/system/printer-laser/4/src/fonttab.canon.lbp-8
new file mode 100644
index 0000000..45314ac
--- /dev/null
+++ b/system/printer-laser/4/src/fonttab.canon.lbp-8
Binary files differ
diff --git a/system/printer-laser/4/src/fonttab.epson.sq b/system/printer-laser/4/src/fonttab.epson.sq
new file mode 100644
index 0000000..a3f7af3
--- /dev/null
+++ b/system/printer-laser/4/src/fonttab.epson.sq
Binary files differ
diff --git a/system/printer-laser/4/src/fonttab.hp.laserjet b/system/printer-laser/4/src/fonttab.hp.laserjet
new file mode 100644
index 0000000..4082e46
--- /dev/null
+++ b/system/printer-laser/4/src/fonttab.hp.laserjet
Binary files differ
diff --git a/system/printer-laser/4/src/fonttab.kyocera.f-1010 b/system/printer-laser/4/src/fonttab.kyocera.f-1010
new file mode 100644
index 0000000..9c3fbda
--- /dev/null
+++ b/system/printer-laser/4/src/fonttab.kyocera.f-1010
Binary files differ
diff --git a/system/printer-laser/4/src/fonttab.nec.lc-08 b/system/printer-laser/4/src/fonttab.nec.lc-08
new file mode 100644
index 0000000..f032953
--- /dev/null
+++ b/system/printer-laser/4/src/fonttab.nec.lc-08
Binary files differ
diff --git a/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic1 b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic1
new file mode 100644
index 0000000..fae8c09
--- /dev/null
+++ b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic1
@@ -0,0 +1,30 @@
+#"!"82"! "#
+#"CMNT 'dyn1.6 '; GENF 10220, 'DYNAMIC1', 22, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.6.i '; GENF 10224, 'DYNAMIC1', 22, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.8 '; GENF 10280, 'DYNAMIC1', 28, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.8.i '; GENF 10284, 'DYNAMIC1', 28, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.10 '; GENF 10340, 'DYNAMIC1', 34, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.10.i'; GENF 10344, 'DYNAMIC1', 34, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.12 '; GENF 10420, 'DYNAMIC1', 42, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.12.i'; GENF 10424, 'DYNAMIC1', 42, 32, 126, 32, 0.94, 0.3, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.14 '; GENF 10500, 'DYNAMIC1', 50, 32, 126, 32, 0.94, 0.0, 0, 0, 0.0, 0.0; "#
+#"CMNT 'dyn1.14.b'; GENF 10502, 'DYNAMIC1', 50, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "#
+#"CMNT 'dyn1.18.b'; GENF 10682, 'DYNAMIC1', 68, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "#
+#"CMNT 'dyn1.24.b'; GENF 10922, 'DYNAMIC1', 92, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "#
+#"CMNT 'dyn1.36.b'; GENF 11322, 'DYNAMIC1', 132, 32, 126, 32, 1.04, 0.0, 0, 0, 5.0, 3.0; "#
+#"MAP 0, 0; EXIT;"#
+
+#type ("dyn1.6") #\#type("dyn1.6")\#
+#type ("dyn1.6.i") #\#type("dyn1.6.i")\#
+#type ("dyn1.8") #\#type("dyn1.8")\#
+#type ("dyn1.8.i") #\#type("dyn1.8.i")\#
+#type ("dyn1.10") #\#type("dyn1.10")\#
+#type ("dyn1.10.i")#\#type("dyn1.10.i")\#
+#type ("dyn1.12") #\#type("dyn1.12")\#
+#type ("dyn1.12.i")#\#type("dyn1.12.i")\#
+#type ("dyn1.14") #\#type("dyn1.14")\#
+#type ("dyn1.14.b")#\#type("dyn1.14.b")\#
+#type ("dyn1.18.b")#\#type("dyn1.18.b")\#
+#type ("dyn1.24.b")#\#type("dyn1.24.b")\#
+#type ("dyn1.36.b")#\#type("dyn1.36.b")\#
+
diff --git a/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic2 b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic2
new file mode 100644
index 0000000..f425a7f
--- /dev/null
+++ b/system/printer-laser/4/src/genfont.kyocera.f-1010.dynamic2
@@ -0,0 +1,30 @@
+#"!"82"! "#
+#"CMNT 'dyn2.6 '; GENF 20200, 'DYNAMIC2', 20, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.6.i '; GENF 20204, 'DYNAMIC2', 20, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.8 '; GENF 20260, 'DYNAMIC2', 26, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.8.i '; GENF 20264, 'DYNAMIC2', 26, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.10 '; GENF 20320, 'DYNAMIC2', 32, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.10.i'; GENF 20324, 'DYNAMIC2', 32, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.12 '; GENF 20400, 'DYNAMIC2', 40, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.12.i'; GENF 20404, 'DYNAMIC2', 40, 32, 126, 32, 0.94, 0.3, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.14 '; GENF 20480, 'DYNAMIC2', 48, 32, 126, 32, 0.94, 0.0, 0, 0, 2.0, 0.0; "#
+#"CMNT 'dyn2.14.b'; GENF 20482, 'DYNAMIC2', 48, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "#
+#"CMNT 'dyn2.18.b'; GENF 20662, 'DYNAMIC2', 66, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "#
+#"CMNT 'dyn2.24.b'; GENF 20902, 'DYNAMIC2', 90, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "#
+#"CMNT 'dyn2.36.b'; GENF 21302, 'DYNAMIC2', 130, 32, 126, 32, 0.99, 0.0, 0, 0, 5.0, 3.0; "#
+#"MAP 0, 0; EXIT;"#
+
+#type ("dyn2.6") #\#type("dyn2.6")\#
+#type ("dyn2.6.i") #\#type("dyn2.6.i")\#
+#type ("dyn2.8") #\#type("dyn2.8")\#
+#type ("dyn2.8.i") #\#type("dyn2.8.i")\#
+#type ("dyn2.10") #\#type("dyn2.10")\#
+#type ("dyn2.10.i")#\#type("dyn2.10.i")\#
+#type ("dyn2.12") #\#type("dyn2.12")\#
+#type ("dyn2.12.i")#\#type("dyn2.12.i")\#
+#type ("dyn2.14") #\#type("dyn2.14")\#
+#type ("dyn2.14.b")#\#type("dyn2.14.b")\#
+#type ("dyn2.18.b")#\#type("dyn2.18.b")\#
+#type ("dyn2.24.b")#\#type("dyn2.24.b")\#
+#type ("dyn2.36.b")#\#type("dyn2.36.b")\#
+
diff --git a/system/printer-laser/4/src/laser.inserter b/system/printer-laser/4/src/laser.inserter
new file mode 100644
index 0000000..c28766f
--- /dev/null
+++ b/system/printer-laser/4/src/laser.inserter
@@ -0,0 +1,275 @@
+PACKET laserdrucker inserter DEFINES treiber einrichten :
+
+(**************************************************************************)
+(* Installationsprogramm Stand : 12.12.88 *)
+(* für Tintenstrahl- Version : 0.9 *)
+(* und Laserdrucker Autor : hjh *)
+(**************************************************************************)
+
+LET anzahl firmen = 6 ;
+LET apple = "APPLE" ,
+ canon = "CANON" ,
+ epson = "EPSON" ,
+ hp = "HEWLETT PACKARD" ,
+ kyo = "KYOCERA" ,
+ nec = "NEC" ;
+
+THESAURUS VAR firmen := empty thesaurus ;
+
+INT VAR i ;
+ROW anzahl firmen THESAURUS VAR drucker ;
+FOR i FROM 1 UPTO anzahl firmen REP
+ drucker (i) := empty thesaurus
+PER ;
+ROW anzahl firmen THESAURUS VAR printer ;
+FOR i FROM 1 UPTO anzahl firmen REP
+ printer (i) := empty thesaurus
+PER ;
+ROW anzahl firmen THESAURUS VAR fonttables ;
+FOR i FROM 1 UPTO anzahl firmen REP
+ fonttables (i) := empty thesaurus
+PER ;
+
+liste (apple,"LASERWRITER","printer.apple.laserwriter","fonttab.apple.laserwriter");
+liste (canon , "LBP-8" ,"printer.canon.lbp-8" ,"fonttab.canon.lbp-8");
+liste (epson , "SQ 2500" ,"printer.epson.sq" ,"fonttab.epson.sq");
+liste (hp , "HP LASERJET" ,"printer.hp.laserjet" ,"fonttab.hp.laserjet");
+liste (hp , "HP LASERJET+" ,"printer.hp.laserjet" ,"fonttab.hp.laserjet");
+liste (kyo , "F-1010" ,"printer.kyocera.f-1010" ,"fonttab.kyocera.f-1010");
+liste (kyo , "F-2200" ,"printer.kyocera.f-1010" ,"fonttab.kyocera.f-1010");
+liste (nec , "SILENTWRITER LC-08" ,"printer.nec.lc-08"
+,"fonttab.nec.lc-08");
+
+treiber einrichten;
+
+PROC liste (TEXT CONST firmenname, druckername ,
+ printername, fonttabname ) :
+ INT VAR firmnum ;
+ IF firmen CONTAINS firmenname
+ THEN firmnum := link (firmen,firmenname)
+ ELSE insert (firmen,firmenname,firmnum)
+ FI;
+ insert (drucker(firmnum), druckername) ;
+ insert (printer(firmnum), printername) ;
+ insert (fonttables(firmnum), fonttabname) ;
+END PROC liste ;
+
+PROC treiber einrichten :
+ INT VAR menu phase := 1 ;
+ BOOL VAR installed := FALSE ;
+ BOOL VAR was esc ;
+ INT VAR firmnum, druckernum ;
+ TEXT VAR firmenname, druckername, printername, fonttabname ;
+
+ pre menu ;
+ REP
+ SELECT menu phase OF
+ CASE 1 : menu ("Hauptmenü Tintenstrahl und Laserdrucker", firmen,
+ "CR: Eingabe ESC : Installation abrechen",
+ firmnum, was esc ) ;
+ IF was esc
+ THEN menu phase := 0
+ ELSE menu phase := 2 ;
+ firmenname := name (firmen,firmnum) ;
+ FI ;
+
+ CASE 2 : menu (firmenname + " - Menü", drucker(firmnum),
+ "CR: Eingabe ESC : Zurück zum Hauptmenü",
+ druckernum, was esc) ;
+ IF was esc
+ THEN menu phase := 1
+ ELSE menu phase := 3 ;
+ druckername := name (drucker(firmnum),druckernum);
+ printername := name (printer(firmnum),druckernum);
+ fonttabname := name (fonttables(firmnum),druckernum);
+ FI;
+
+ CASE 3 : inst (druckername, printername, fonttabname, installed) ;
+ IF NOT installed THEN menu phase := 1 FI;
+ END SELECT
+ UNTIL installed OR abbruch PER ;
+ post menu.
+
+ abbruch:
+ menu phase < 1 .
+
+ pre menu:
+ line;
+ IF is single task system
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+ FI;
+ IF NOT is system task (myself)
+ THEN errorstop ("Die Druckertask muß im Systemzweig angelegt werden")
+ FI;
+ command dialogue (TRUE);
+ IF name (myself) <> "PRINTER"
+ THEN putline ("Diese Task heißt nicht ""PRINTER"", sondern """ +
+ name (myself) + """ !");
+ IF yes ("Soll die Task in ""PRINTER"" umbenannt werden ?")
+ THEN rename myself ("PRINTER")
+ FI
+ FI.
+
+ is single task system: (pcb (9) AND 255) = 1.
+
+ post menu:
+ IF NOT installed
+ THEN page;
+ putline ("Es ist kein Druckertreiber installiert worden!");
+ line;
+ putline ("Wenn dieses Installationsprogramm insertiert wurde,");
+ putline ("kann es in der Task """ + name (myself) + """ ");
+ putline ("mit 'treiber einrichten' erneut aufgerufen werden.");
+ line;
+ FI.
+
+END PROC treiber einrichten ;
+
+PROCEDURE menu (TEXT CONST header, THESAURUS CONST items, TEXT CONST bottom,
+ INT VAR choice, BOOL VAR was esc) :
+ INT VAR anzahl ;
+ page;
+ headline (header) ;
+ show list (items,anzahl) ;
+ bottomline (bottom) ;
+ ask user (anzahl,choice,was esc);
+END PROC menu ;
+
+PROC headline (TEXT CONST header):
+ cursor (13,1);
+ putline ("E U M E L - Druckertreiber - Installations - Programm");
+ cursor (40 - LENGTH header DIV 2, 2);
+ IF header <> "" THEN put (header) FI ;
+ line (2)
+END PROC headline;
+
+PROC bottomline (TEXT CONST bottom):
+ cursor (1,24);
+ IF bottom <> "" THEN put (""5"" + bottom) FI ;
+END PROC bottomline;
+
+PROC show list (THESAURUS CONST items , INT VAR anzahl ) :
+ INT VAR i ;
+ anzahl := highest entry (items);
+ FOR i FROM 1 UPTO anzahl REP
+ putline ( text(i) + ". " + name (items,i) ) ;
+ PER;
+END PROC show list ;
+
+PROC ask user (INT CONST max choice, INT VAR choice, BOOL VAR was esc):
+ TEXT VAR exit;
+ TEXT VAR inp := "";
+ REP
+ cursor (1,23);
+ IF inp = ""
+ THEN put ("Ihre Wahl (Nummer eingeben):")
+ ELSE put ("FEHLER! Eingabe korrigieren:")
+ FI;
+ editget (inp, ""27"", "", exit);
+ was esc := exit = ""27"";
+ UNTIL was esc OR ok PER.
+
+ ok:
+ choice := int (inp) ;
+ last conversion ok CAND ( choice > 0 AND choice <= max choice) .
+END PROC ask user;
+
+BOOL PROC is system task (TASK CONST task):
+ TASK VAR tsk := task ;
+ WHILE NOT (tsk = supervisor OR tsk = niltask) REP
+ tsk := father (tsk) ;
+ PER;
+ tsk = supervisor
+END PROC is system task ;
+
+PROC inst (TEXT CONST druckername, printername, fonttabname,
+ BOOL VAR success) :
+ page ;
+ headline (druckername) ;
+ fetch from archive if necessary ((empty thesaurus
+ + printer name + fonttab name) - all ,success);
+ IF success AND ok
+ THEN page ;
+ putline ("Der Drucker wird insertiert");
+ insert (printer name) ;
+ ELSE success := FALSE ;
+ FI.
+
+ok:
+ bottomline (" ");
+ yes ("Soll der ausgewählte Drucker insertiert werden").
+
+END PROC inst ;
+
+PROC fetch from archive if necessary (THESAURUS CONST files,
+ BOOL VAR success ):
+ BOOL VAR was esc ;
+ THESAURUS VAR thes :: files;
+
+ WHILE highest entry (thes) > 0 REP
+ ask for archive;
+ IF NOT was esc
+ THEN disable stop ;
+ bottomline ("Bitte warten ! ");
+ reserve archive;
+ IF NOT is error
+ THEN IF highest entry (thes / ALL archive) > 0
+ THEN fetch (thes / ALL archive, archive);
+ ELSE fehler ("Dateien nicht gefunden")
+ FI;
+ thes := thes - all;
+ FI;
+ IF is error
+ THEN fehler (errormessage);
+ clear error
+ FI;
+ command dialogue (FALSE);
+ release (archive);
+ command dialogue (TRUE);
+ enable stop ;
+ FI;
+ UNTIL was esc PER;
+ success := highest entry (thes) = 0.
+
+ask for archive:
+ headline ("") ;
+ putline ("Bitte Archiv mit den Dateien");
+ TEXT VAR buffer;
+ INT VAR index :: 0;
+ REP
+ get (thes, buffer, index);
+ putline (" " + buffer)
+ UNTIL index = 0 PER;
+ putline ("einlegen !");
+ bottomline ("CR: Wenn Archiv eingelegt ESC : Zurück zum Hauptmenü");
+ cursor (1,24);
+ REP
+ inchar (buffer) ;
+ UNTIL buffer = ""13"" OR buffer = ""27"" PER ;
+ was esc := buffer = ""27"".
+
+reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI.
+
+END PROC fetch from archive if necessary ;
+
+PROC fehler (TEXT CONST fehlermeldung):
+ bottomline (""7"" + fehlermeldung + " Bitte eine Taste drücken") ;
+ pause ;
+ bottomline (" ") ;
+END PROC fehler;
+
+END PACKET laserdrucker inserter;
+
diff --git a/system/printer-laser/4/src/printer.apple.laserwriter b/system/printer-laser/4/src/printer.apple.laserwriter
new file mode 100644
index 0000000..d4c6adf
--- /dev/null
+++ b/system/printer-laser/4/src/printer.apple.laserwriter
@@ -0,0 +1,770 @@
+PACKET apple laser writer printer
+
+(**************************************************************************)
+(* Stand : 24.02.88 *)
+(* APPLE LaswerWriter (PostScript) Verison : 4 *)
+(* Autor : Rudolf Ruland *)
+(**************************************************************************)
+
+ DEFINES open,
+ close,
+ execute,
+
+ paper size,
+ paper x size,
+ paper y size,
+
+ load positioning procs,
+ load underline procs,
+ load italics procs,
+ load encoding,
+
+ read ps input,
+
+ box commands,
+ insert box command,
+ delete box command,
+
+ print error,
+ :
+
+LET
+(* underline = 1,
+ bold = 2,
+ italics = 4,
+ reverse = 8,
+*)
+ underline linetype = 1,
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1,
+ c write cmd = 2,
+ c carriage return = 3,
+ c move = 4,
+ c draw = 5,
+ c on = 6,
+ c off = 7,
+ c type = 8,
+
+ ps input name = "PostScript.input",
+ ps error = 999,
+
+ tag type = 1;
+
+INT VAR paper length, font no, underline no, symbol type;
+REAL VAR x size, y size;
+BOOL VAR is landscape;
+TEXT VAR record, char, command, symbol;
+FILE VAR ps input;
+THESAURUS VAR box cmds := empty thesaurus;
+
+(*********************************************************************)
+
+paper size (21.0, 29.7);
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+REAL PROC paper x size : x size END PROC paper x size;
+
+REAL PROC paper y size : y size END PROC paper y size;
+
+
+THESAURUS PROC box commands : box cmds END PROC box commands;
+
+PROC insert box command (TEXT CONST new command) :
+
+ command := new command;
+ change all (command, " ", "");
+ insert (box cmds, command)
+
+END PROC insert box command;
+
+PROC delete box command (TEXT CONST old command) :
+
+ INT VAR dummy;
+ command := old command;
+ change all (command, " ", "");
+ delete (box cmds, command, dummy)
+
+END PROC delete box command;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ IF pos (material, "landscape") > 0 OR pos (material, "quer") > 0
+ THEN is landscape := TRUE;
+ x steps := x step conversion ( y size );
+ y steps := y step conversion ( x size );
+ ELSE is landscape := FALSE;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ FI;
+ forget (ps input name, quiet);
+ ps input := sequential file (output, ps input name);
+ paper length := y steps;
+ font no := 0;
+ underline no := 0;
+ disable stop;
+ out (""4"");
+ read ps input (ps input, 18000, ""4"");
+ clear error;
+ enable stop;
+ out ("initgraphics erasepage statusdict /waittimeout 3000 put ");
+ load positioning procs;
+ load underline procs;
+ load italics procs;
+ load encoding;
+ read ps input (ps input, 0, "");
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ x start := 0;
+ y start := 0;
+ IF pos (material, "tray") > 0
+ THEN out ("statusdict /manualfeed false put ");
+ ELIF pos (material, "manual") > 0
+ THEN out ("statusdict /manualfeed true put statusdict /manualfeedtimeout 3600 put ");
+ FI;
+ IF material contains a number
+ THEN out ("/#copies "); out (number); out ("def ");
+ FI;
+ IF is landscape
+ THEN out (paper length);
+ out ("ys 0 translate 90 rotate ");
+ FI;
+ read ps input (ps input, 0, "");
+
+ . material contains a number :
+ INT VAR number := pos (material, "0", "9", 1);
+ IF number = 0
+ THEN FALSE
+ ELSE number := max (1, int (subtext (material, number, number + 1)));
+ TRUE
+ FI
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+ OTHERWISE : put (param1)
+END SELECT;
+
+.
+ close document :
+ disable stop;
+ out (""4"");
+ read ps input (ps input, 18000, ""4"");
+
+
+(*. remaining y steps : param1*)
+.
+ close page :
+ outline ("showpage");
+ read ps input (ps input, 0, "");
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ out ("(");
+ out subtext (string, from, to);
+ out (") show ");
+.
+ write cmd :
+ command := subtext (string, from, to);
+ IF is box cmd
+ THEN disable stop;
+ do (command);
+ clear error;
+ ELSE out (command);
+ out (" ");
+ FI;
+
+ . is box cmd :
+ scan (command);
+ next symbol (symbol, symbol type);
+ (symbol type = tag type) CAND (box cmds CONTAINS symbol)
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ move to (0, y pos);
+ line;
+ read ps input (ps input, 0, "");
+
+
+. x steps : param1
+. y steps : param2
+
+.
+ move :
+ move to (x pos, y pos);
+
+.
+ draw :
+ IF y steps <> 0 COR x steps < 0 COR linetype <> underline linetype
+ THEN stop
+ ELSE IF underline no <> font no THEN out ("lu ") FI;
+ out (x steps);
+ out ("ul ");
+ FI;
+
+
+. modification : param1
+.
+ on :
+ IF on string (modification) <> ""
+ THEN out (on string (modification));
+ out (" ");
+ ELSE stop
+ FI
+
+.
+ off :
+ IF off string (modification) <> ""
+ THEN out (off string (modification));
+ out (" ");
+ ELSE stop
+ FI
+
+
+. font nr : param1
+.
+ type :
+ font no := font nr;
+ out (fontstring (font nr));
+ out (" /af exch def af setfont ");
+
+END PROC execute;
+
+
+PROC move to (INT CONST x, y) :
+
+ out (x); out ("xs ");
+ out (paper length - y); out ("ys moveto ");
+
+END PROC move to;
+
+
+PROC line : out (""13""10"") END PROC line;
+
+PROC outline (TEXT CONST string) : out (string); out (""13""10"") END PROC outline;
+
+PROC out (INT CONST value) : out (text (value)); out (" ") END PROC out;
+
+PROC out (REAL CONST value) : out (text (value)); out (" ") END PROC out;
+
+
+PROC load positioning procs :
+
+ out ("/xs {"); out (72.0 / 2.54 * x step conversion (1)); out ("mul} def ");
+ out ("/ys {"); out (72.0 / 2.54 * y step conversion (1)); out ("mul} def ");
+
+END PROC load positioning procs;
+
+
+PROC load underline procs :
+
+ out ("/ul {xs ut setlinewidth 0 up rmoveto dup gsave 0 rlineto stroke grestore up neg rmoveto} def ");
+ out ("/lu {af /FontMatrix get 3 get af /FontInfo get 2 copy /up 3 1 roll /UnderlinePosition get mul 3 mul def /ut 3 1 roll /UnderlineThickness get mul def} def ");
+
+END PROC load underline procs;
+
+
+PROC load italics procs :
+
+ out ("/iton {/m matrix def m 2 12 sin 12 cos div put af m makefont setfont} def ");
+ out ("/itoff {af setfont} def ");
+
+END PROC load italics procs;
+
+
+PROC load encoding :
+
+ out ("/reencsmalldict 12 dict def ");
+ out ("/ReEncodeSmall {reencsmalldict begin ");
+ out ("/newcodesandnames exch def /newfontname exch def /basefontname exch def ");
+ out ("/basefontdict basefontname findfont def /newfont basefontdict maxlength dict def ");
+ out ("basefontdict {exch dup /FID ne {dup /Encoding eq {exch dup length array copy newfont 3 1 roll put} {exch newfont 3 1 roll put} ifelse} {pop pop} ifelse} forall ");
+ out ("newfont /FontName newfontname put newcodesandnames aload pop newcodesandnames length 2 idiv {newfont /Encoding get 3 1 roll put} repeat ");
+ out ("newfontname newfont definefont pop ");
+ out ("end} def ");
+ out ("/eumelencoding[10#128 /Ccedilla 10#129 /udieresis 10#128 /Ccedilla 10#129 /udieresis ");
+ out ("10#130 /eacute 10#131 /acircumflex 10#132 /adieresis 10#133 /agrave 10#134 /aring 10#135 /ccedilla 10#136 /ecircumflex 10#137 /edieresis 10#138 /egrave 10#139 /idieresis ");
+ out ("10#140 /icircumflex 10#141 /igrave 10#142 /Adieresis 10#143 /Aring 10#144 /Eacute 10#145 /ae 10#146 /AE 10#147 /ocircumflex 10#148 /odieresis 10#149 /ograve ");
+ out ("10#150 /ucircumflex 10#151 /ugrave 10#152 /ydieresis 10#153 /Odieresis 10#154 /Udieresis 10#155 /cent 10#156 /sterling 10#157 /yen 10#158 /currency 10#159 /florin ");
+ out ("10#160 /aacute 10#161 /iacute 10#162 /oacute 10#163 /uacute 10#164 /ntilde 10#165 /Ntilde 10#166 /ordfeminine 10#167 /ordmasculine 10#168 /questiondown 10#169 /quotedblleft ");
+ out ("10#170 /quotedblright 10#171 /guilsinglleft 10#172 /guilsinglright 10#173 /exclamdown 10#174 /guillemotleft 10#175 /guillemotright 10#176 /atilde 10#177 /otilde 10#178 /Oslash 10#179 /oslash ");
+ out ("10#180 /oe 10#181 /OE 10#182 /Agrave 10#183 /Atilde 10#184 /Otilde 10#185 /section 10#186 /daggerdbl 10#187 /dagger 10#188 /paragraph 10#189 /space ");
+ out ("10#190 /space 10#191 /space 10#192 /quotedblbase 10#193 /ellipsis 10#194 /perthousand 10#195 /bullet 10#196 /endash 10#197 /emdash 10#198 /space 10#199 /Aacute ");
+ out ("10#200 /Acircumflex 10#201 /Egrave 10#202 /Ecircumflex 10#203 /Edieresis 10#204 /Igrave 10#205 /Iacute 10#206 /Icircumflex 10#207 /Idieresis 10#208 /Ograve 10#209 /Oacute ");
+ out ("10#210 /Ocircumflex 10#211 /Scaron 10#212 /scaron 10#213 /Ugrave 10#214 /Adieresis 10#215 /Odieresis 10#216 /Udieresis 10#217 /adieresis 10#218 /odieresis 10#219 /udieresis ");
+ out ("10#220 /k 10#221 /hyphen 10#222 /numbersign 10#223 /space 10#224 /grave 10#225 /acute 10#226 /circumflex 10#227 /tilde 10#228 /dieresis 10#229 /ring ");
+ out ("10#230 /cedilla 10#231 /caron 10#232 /Lslash 10#233 /Oslash 10#234 /OE 10#235 /ordmasculine 10#236 /Uacute 10#237 /Ucircumflex 10#238 /Ydieresis 10#239 /germandbls ");
+ out ("10#240 /Zcaron 10#241 /zcaron 10#242 /fraction 10#243 /ae ");
+ out ("10#251 /germandbls 10#252 /section] def ");
+ out ("/Helvetica /EHelvetica eumelencoding ReEncodeSmall ");
+ out ("/Helvetica-Bold /EHelvetica-Bold eumelencoding ReEncodeSmall ");
+ out ("/Helvetica-Oblique /EHelvetica-Oblique eumelencoding ReEncodeSmall ");
+ out ("/Helvetica-BoldOblique /EHelvetica-BoldOblique eumelencoding ReEncodeSmall ");
+ out ("/Times-Roman /ETimes-Roman eumelencoding ReEncodeSmall ");
+ out ("/Times-Bold /ETimes-Bold eumelencoding ReEncodeSmall ");
+ out ("/Times-Italic /ETimes-Italic eumelencoding ReEncodeSmall ");
+ out ("/Times-BoldItalic /ETimes-BoldItalic eumelencoding ReEncodeSmall ");
+ out ("/Courier /ECourier eumelencoding ReEncodeSmall ");
+ out ("/Courier-Oblique /ECourier-Oblique eumelencoding ReEncodeSmall ");
+ out ("/Courier-BoldOblique /ECourier-BoldOblique eumelencoding ReEncodeSmall ");
+ out ("/Courier-Bold /ECourier-Bold eumelencoding ReEncodeSmall ");
+ line;
+
+END PROC load encoding;
+
+
+PROC read ps input (FILE VAR input file, INT CONST timeout, TEXT CONST ok) :
+
+ BOOL VAR was cr;
+ record := "";
+ was cr := FALSE;
+ char := incharety (timeout);
+ REP IF char = ""10"" CAND was cr
+ THEN put record;
+ was cr := FALSE;
+ ELIF char = ""13"" CAND NOT was cr
+ THEN was cr := TRUE;
+ ELSE IF was cr
+ THEN record CAT """13""";
+ was cr := FALSE;
+ FI;
+ IF char = ""4""
+ THEN IF record <> "" THEN put record FI;
+ putline (input file, "-- EOF --");
+ line (input file);
+ ELIF char >= " "
+ THEN record CAT char
+ ELIF char >= ""0""
+ THEN record CAT """";
+ record CAT text (code (char));
+ record CAT """";
+ ELSE IF record <> "" THEN put record FI;
+ LEAVE read ps input;
+ FI;
+ FI;
+ IF pos (ok, char) > 0
+ THEN IF record <> "" THEN put record FI;
+ LEAVE read ps input;
+ FI;
+ cat input (record, char);
+ IF char = "" THEN char := incharety (min (5, time out)) FI;
+ PER;
+
+ . put record :
+ putline (input file, record);
+ IF NOT is error CAND pos (record, "%%[ Error:") > 0
+ THEN errorstop (ps error, record) FI;
+ record := "";
+
+END PROC read ps input;
+
+
+PROC print error (TEXT CONST error message, INT CONST error line) :
+
+ REAL CONST pl := y size * 72.0 / 2.54,
+ ys := 56.69291,
+ xs := 51.02362,
+ h := 12.0;
+ REAL VAR x := xs, y := ys + h;
+ outline ("/Courier findfont 10 scalefont setfont");
+ move to x and y;
+ out ("(FEHLER : ");
+ out (error message);
+ IF error line > 0
+ THEN out (" in Zeile ");
+ out (error line);
+ FI;
+ outline (") show");
+ IF exists (ps input name)
+ THEN ps input := sequential file (input, ps input name);
+ y INCR 3.0 * h;
+ move to x and y;
+ outline ("(PostScript - Input :) show");
+ y INCR h;
+ WHILE NOT eof (ps input)
+ REP getline (ps input, record);
+ y INCR h;
+ move to x and y;
+ out ("(");
+ out (record);
+ outline (") show");
+ PER;
+ output (ps input);
+ FI;
+ outline ("showpage");
+ out (""4"");
+ read ps input (ps input, 18000, ""4"");
+
+ . move to x and y :
+ out (x); out (pl - y); out ("moveto ");
+
+END PROC print error;
+
+
+END PACKET apple laser writer printer;
+
+
+PACKET apple laserwriter box commands
+
+(**************************************************************************)
+(* *)
+(* Kommandos zum Zeichen von Boxen, Linien und Schraffuren *)
+(* für den Apple LaserWriter *)
+(* *)
+(* Autor : Rudolf Ruland *)
+(* Stand : 24.02.88 *)
+(**************************************************************************)
+
+ DEFINES line,
+ x line,
+ y line,
+
+ box,
+ box frame,
+ box shade,
+
+ cake,
+ cake frame,
+ cake shade,
+ :
+
+INT VAR x, y, h, w;
+
+WHILE highest entry (box commands) > 0
+ REP delete box command (name (box commands, highest entry (box commands))) PER;
+insert box command ("line");
+insert box command ("xline");
+insert box command ("yline");
+insert box command ("box");
+insert box command ("boxshade");
+insert box command ("boxframe");
+insert box command ("cake");
+insert box command ("cakeshade");
+insert box command ("cakeframe");
+
+
+PROC line (REAL CONST x offset, y offset, width, height, line width) :
+
+ IF line width > 0.0
+ THEN graph on (x offset, y offset, width, height);
+ out (text (line width / 300.0 * 72.0));
+ out (" setlinewidth ");
+ out (text (w));
+ out (" xs ");
+ out (text (-h));
+ out (" ys rlineto stroke ");
+ graph off;
+ FI;
+
+END PROC line;
+
+PROC x line (REAL CONST x offset, y offset, width, line width) :
+
+ line (x offset, y offset, width, 0.0, line width);
+
+END PROC x line;
+
+PROC y line (REAL CONST x offset, y offset, height, line width) :
+
+ line (x offset, y offset, 0.0, height, line width);
+
+END PROC y line;
+
+
+PROC box (REAL CONST x offset, y offset, width, height, line width, pattern):
+
+ box shade (x offset, y offset, width, height, pattern);
+ box frame (x offset, y offset, width, height, line width);
+
+END PROC box;
+
+
+PROC box shade (REAL CONST x offset, y offset, width, height, pattern) :
+
+ graph on (x offset, y offset, width, height);
+ box path;
+ out (text (pattern));
+ out (" setgray fill ");
+ graph off;
+
+END PROC box shade;
+
+
+PROC box frame (REAL CONST x offset, y offset, width, height, line width) :
+
+ IF line width <> 0.0
+ THEN graph on (x offset, y offset, width, height);
+ box path;
+ out (text (line width / 300.0 * 72.0));
+ out (" setlinewidth stroke ");
+ graph off;
+ FI;
+
+END PROC box frame;
+
+
+PROC box path :
+
+ out (text (w));
+ out (" xs 0 rlineto 0 ");
+ out (text (-h));
+ out (" ys rlineto ");
+ out (text (-w));
+ out (" xs 0 rlineto closepath ");
+
+END PROC box path;
+
+
+
+PROC cake (REAL CONST x offset, y offset, radius, start angle, sweep angle, line width, pattern) :
+
+ cake shade (x offset, y offset, radius, start angle, sweep angle, pattern);
+ cake frame (x offset, y offset, radius, start angle, sweep angle, line width);
+
+END PROC cake;
+
+
+PROC cake shade (REAL CONST x offset, y offset, radius, start angle, sweep angle, pattern) :
+
+ graph on (x offset, y offset, radius, 0.0);
+ cake path (start angle, sweep angle);
+ out (text (pattern));
+ out (" setgray fill ");
+ graph off;
+
+END PROC cake shade;
+
+
+PROC cake frame (REAL CONST x offset, y offset, radius, start angle, sweep angle, line width) :
+
+
+ IF line width <> 0.0
+ THEN graph on (x offset, y offset, radius, 0.0);
+ cake path (start angle, sweep angle);
+ out (text (line width / 300.0 * 72.0));
+ out (" setlinewidth stroke ");
+ graph off;
+ FI;
+
+END PROC cake frame;
+
+
+PROC cake path (REAL CONST start angle, sweep angle) :
+
+ out (text (start angle));
+ out (" rotate ");
+ out ("currentpoint ");
+ out (text (w));
+ out (" xs 0 ");
+ out (text (sweep angle));
+ out (" ");
+ IF sweep angle < 360.0
+ THEN out ("2 setlinejoin arc closepath ");
+ ELSE out (text (w));
+ out (" xs 0 rmoveto arc ");
+ FI;
+
+END PROC cake path;
+
+
+PROC graph on (REAL CONST x offset, y offset, width, height) :
+
+ x := x step conversion (x offset);
+ y := y step conversion (y offset);
+ w := x step conversion (width);
+ h := y step conversion (height);
+ out ("gsave ");
+ out (text (x));
+ out (" xs ");
+ out (text (-y));
+ out (" ys rmoveto ");
+
+END PROC graph on;
+
+PROC graph off :
+
+ out ("grestore ");
+
+END PROC graph off;
+
+
+END PACKET apple laserwriter box commands;
+
+
+
+#page#
+(******************************************************************)
+(*** ***)
+(*** Generierung des Printers ***)
+(*** ***)
+(******************************************************************)
+(*
+LET up = ""3""13""5"";
+*)
+LET printer name = "printer.apple.laserwriter";
+TEXT VAR fonttab name := "fonttab.apple.laserwriter";
+
+BOOL CONST multi user := (pcb (9) AND 255) <> 1;
+
+INT VAR pr channel;
+TEXT VAR buffer;
+
+command dialogue (TRUE);
+IF NOT multi user
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+FI;
+ask for print channel;
+load font table;
+forget (printer name, quiet);
+IF multi user THEN generate printer spool FI;
+command dialogue (TRUE);
+check on;
+.
+ ask for print channel :
+ line;
+ put ("gib Druckerkanal:");
+ get (pr channel);
+ do ("serverchannel(" + text (pr channel) + ")" ) ;
+ line;
+.
+ load font table :
+ IF NOT exists (fonttab name)
+ THEN REP line (2);
+ putline ("Bitte Archiv mit der Fonttabelle """ +
+ fonttab name + """ einlegen!");
+ line;
+ UNTIL yes ("Archiv eingelegt") PER;
+ reserve archive;
+ fetch (fonttab name, archive);
+ release (archive);
+ FI;
+ font table (fonttab name);
+ IF multi user
+ THEN command dialogue (FALSE);
+ do ("save(""" + font tab name + """,task(""configurator""))")
+ FI;
+ forget (fonttab name, quiet);
+
+ . reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop;
+
+. generate printer spool :
+ eumel must advertise;
+ cursor (1, 12);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (4);
+ putline ("Generierung beendet, weiter mit 'SV'");
+ generate printer server;
+ do (buffer);
+
+. generate printer server :
+ buffer := "break (quiet);";
+ buffer CAT "spool manager (PROC printer);";
+ buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;";
+ buffer CAT "PROC printer:";
+ buffer CAT " disable stop;";
+ buffer CAT " continue (server channel);";
+ buffer CAT " check error (error message);";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " REP forget (ds);";
+ buffer CAT " execute print;";
+ buffer CAT " IF is error AND online THEN clear error; print error (error message, 0); clear error FI;";
+ buffer CAT " PER;";
+ buffer CAT "END PROC printer;";
+ buffer CAT "PROC execute print:";
+ buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;";
+ buffer CAT " enable stop;";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " call (father, fetch code, ds, reply);";
+ buffer CAT " IF reply = ack CAND type (ds) = file type";
+ buffer CAT " THEN file := sequential file (input, ds);";
+ buffer CAT " print (file,";
+ buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,";
+ buffer CAT " PROC (INT CONST, INT CONST) close,";
+ buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC execute print;";
+ buffer CAT "PROC check error(TEXT CONST message):";
+ buffer CAT " IF is error";
+ buffer CAT " THEN clear error; rename myself (message);";
+ buffer CAT " IF is error THEN end(myself) FI;";
+ buffer CAT " pause (9000); end(myself);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC check error;";
+
diff --git a/system/printer-laser/4/src/printer.canon.lbp-8 b/system/printer-laser/4/src/printer.canon.lbp-8
new file mode 100644
index 0000000..4dfe9f8
--- /dev/null
+++ b/system/printer-laser/4/src/printer.canon.lbp-8
@@ -0,0 +1,327 @@
+PACKET canon lbp 8 printer
+
+(*************************************************************************)
+(* Stand : 29.07.86 *)
+(* CANON LBP-8 A1/A2 Version : 4 *)
+(* Autor : Rudolf Ruland *)
+(*************************************************************************)
+
+
+ DEFINES open,
+ close,
+ execute,
+
+ paper size :
+
+LET underline = 1,
+(* bold = 2,
+ italics = 4,
+ reverse = 8,
+
+ underline linetype = 1, *)
+
+ csi = ""155"",
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1,
+ c write cmd = 2,
+ c carriage return = 3,
+ c move = 4,
+ c draw = 5,
+ c on = 6,
+ c off = 7,
+ c type = 8;
+
+REAL VAR x size, y size;
+BOOL VAR is underline;
+
+(*********************************************************************)
+
+paper size (21.0, 29.7);
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ is underline := FALSE;
+ x steps := x step conversion ( x size - 0.8043333 );
+ y steps := y step conversion ( y size - 0.508);
+ out (""27":"27"P"13""); (* Enable - Prop.Type *)
+ out (""27";"27"<"155"11h"); (* Reset des Druckers *)
+ out (""27"(B"); (* ACSII-Zeichensatz *)
+ out (""155"1;4 D"); (* Char.Satz 1 = PICA *)
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ x start := x step conversion (0.4064 );
+ y start := y step conversion (0.508 + 0.6345);
+ out (""13"");
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+ OTHERWISE : put (param1)
+END SELECT;
+
+.
+ close document :
+ (* out(""155"0q") von Standard-Cassette Papier holen *)
+
+(*. remaining y steps : param1*)
+.
+ close page :
+ out (""13""12"");
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ INT VAR new from, new to;
+ IF is underline
+ THEN IF pos (string, " ", from, from) <> 0
+ THEN out ("_");
+ new from := from + 1;
+ ELSE new from := from;
+ FI;
+ IF from < to AND pos (string, " ", to, to) <> 0
+ THEN new to := to - 1;
+ ELSE new to := to;
+ FI;
+ out subtext (string, new from, new to);
+ IF to <> new to THEN out ("_") FI;
+ ELSE out subtext (string, from, to)
+ FI;
+
+.
+ write cmd :
+ out subtext (string, from, to)
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ out (""13"")
+
+
+. x steps : param1
+. y steps : param2
+.
+ move :
+ IF x steps > 0
+ THEN out (csi); out (text ( x steps)); out ("a")
+ ELIF x steps < 0
+ THEN out (csi); out (text (- x steps)); out ("j")
+ FI;
+ IF y steps > 0
+ THEN out (csi); out (text ( y steps)); out ("e")
+ ELIF y steps < 0
+ THEN out (csi); out (text (- y steps)); out ("k")
+ FI;
+
+.
+ draw :
+ stop
+
+
+. modification : param1
+.
+ on :
+ IF on string (modification) <> ""
+ THEN out (on string (modification));
+ IF modification = underline THEN is underline := TRUE FI;
+ ELSE stop
+ FI
+
+.
+ off :
+ IF off string (modification) <> ""
+ THEN out (off string (modification));
+ IF modification = underline THEN is underline := FALSE FI;
+ ELSE stop
+ FI
+
+
+. font nr : param1
+.
+ type :
+ out (font string (font nr));
+
+END PROC execute;
+
+
+END PACKET canon lbp 8 printer;
+
+
+
+#page#
+(******************************************************************)
+(*** ***)
+(*** Generierung des Printers ***)
+(*** ***)
+(******************************************************************)
+
+LET printer name = "printer.canon.lbp-8";
+
+TEXT VAR fonttab name := "fonttab.canon.lbp-8";
+
+BOOL CONST multi user := (pcb (9) AND 255) <> 1;
+
+INT VAR pr channel;
+TEXT VAR buffer;
+
+command dialogue (TRUE);
+IF NOT multi user
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+FI;
+ask for print channel;
+ask for font cartridge;
+load font table;
+forget (printer name, quiet);
+IF multi user THEN generate printer spool FI;
+check on;
+.
+ ask for print channel :
+ line;
+ put ("gib Druckerkanal:");
+ get (pr channel);
+ do ("serverchannel(" + text (pr channel) + ")" ) ;
+ line;
+.
+ ask for font cartridge :
+.
+ load font table :
+ IF NOT exists (fonttab name)
+ THEN command dialogue (TRUE);
+ REP line (2);
+ putline ("Bitte Archiv mit der Fonttabelle """ +
+ fonttab name + """ einlegen!");
+ line;
+ UNTIL yes ("Archiv eingelegt") PER;
+ reserve archive;
+ fetch (fonttab name, archive);
+ release (archive);
+ FI;
+ font table (fonttab name);
+ IF multi user
+ THEN command dialogue (FALSE);
+ do ("save(""" + font tab name + """,task(""configurator""))")
+ FI;
+ forget (fonttab name, quiet);
+
+ . reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop;
+
+. generate printer spool :
+ eumel must advertise;
+ cursor (1, 12);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (4);
+ putline ("Generierung beendet, weiter mit 'SV'");
+ generate printer server;
+ do (buffer);
+
+. generate printer server :
+ buffer := "break (quiet);";
+ buffer CAT "spool manager (PROC printer);";
+ buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;";
+ buffer CAT "PROC printer:";
+ buffer CAT " disable stop;";
+ buffer CAT " continue (server channel);";
+ buffer CAT " check error (error message);";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " REP forget (ds);";
+ buffer CAT " execute print;";
+ buffer CAT " IF is error AND online THEN put error; clear error; FI;";
+ buffer CAT " PER;";
+ buffer CAT "END PROC printer;";
+ buffer CAT "PROC execute print:";
+ buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;";
+ buffer CAT " enable stop;";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " call (father, fetch code, ds, reply);";
+ buffer CAT " IF reply = ack CAND type (ds) = file type";
+ buffer CAT " THEN file := sequential file (input, ds);";
+ buffer CAT " print (file,";
+ buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,";
+ buffer CAT " PROC (INT CONST, INT CONST) close,";
+ buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC execute print;";
+ buffer CAT "PROC check error(TEXT CONST message):";
+ buffer CAT " IF is error";
+ buffer CAT " THEN clear error; rename myself (message);";
+ buffer CAT " IF is error THEN end(myself) FI;";
+ buffer CAT " pause (9000); end(myself);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC check error;";
+
diff --git a/system/printer-laser/4/src/printer.epson.sq b/system/printer-laser/4/src/printer.epson.sq
new file mode 100644
index 0000000..63e474f
--- /dev/null
+++ b/system/printer-laser/4/src/printer.epson.sq
@@ -0,0 +1,585 @@
+PACKET epson sq printer
+
+(**************************************************************************)
+(* Stand : 03.12.86 *)
+(* EPSON SQ-2500 Version : 4 *)
+(* Autor : Rudolf Ruland *)
+(**************************************************************************)
+
+ DEFINES open,
+ close,
+ execute,
+
+ paper size,
+ (* paper feed, *) (* <-- nicht getestet *)
+ std typeface,
+ std quality:
+
+LET
+(* underline = 1,
+ bold = 2,
+ italics = 4,
+ reverse = 8, *)
+
+ underline linetype = 1,
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1, cmd draft = 1,
+ c write cmd = 2, cmd nlq = 2,
+ c carriage return = 3, cmd roman = 3,
+ c move = 4, cmd sansserif = 4,
+ c draw = 5, cmd courier = 5,
+ c on = 6, cmd prestige = 6,
+ c off = 7, cmd script = 7,
+ c type = 8;
+
+INT VAR font nr, x rest, high, low, font bits, modification bits, blank pitch,
+ factor 1, factor 2, steps;
+BOOL VAR is nlq, sheet feed;
+REAL VAR x size, y size;
+TEXT VAR std quality name, std typeface name, buffer, symbol, font text;
+THESAURUS VAR commands := empty thesaurus;
+
+insert (commands, "draft");
+insert (commands, "nlq");
+insert (commands, "roman");
+insert (commands, "sansserif");
+insert (commands, "courier");
+insert (commands, "prestige");
+insert (commands, "script");
+
+. is prop : bit (font bits, 1)
+. is double : bit (font bits, 5)
+.;
+
+(*********************************************************************)
+
+paper size (13.6 * 2.54, 12.0 * 2.54);
+paper size ( 8.0 * 2.54, 12.0 * 2.54);
+paper feed ("tractor");
+std typeface ("roman");
+std quality ("draft");
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+
+PROC paper feed (TEXT CONST paper) :
+
+ IF pos (paper, "sheet") <> 0
+ THEN sheet feed := TRUE;
+ ELIF pos (paper, "tractor") <> 0
+ THEN sheet feed := FALSE;
+ ELSE errorstop ("unzulaessige Papiereinfuehrung")
+ FI;
+
+END PROC paper feed;
+
+TEXT PROC paper feed :
+
+ IF sheet feed
+ THEN "sheet"
+ ELSE "tractor"
+ FI
+
+END PROC paper feed;
+
+
+PROC std typeface (TEXT CONST typeface) :
+
+ buffer := typeface;
+ changeall (buffer, " ", "");
+ IF link (commands, buffer) >= cmd roman
+ THEN std typeface name := buffer
+ ELSE errorstop ("unzulaessige Schriftart")
+ FI;
+
+END PROC std typeface;
+
+TEXT PROC std typeface : std typeface name END PROC std typeface;
+
+
+PROC std quality (TEXT CONST quality) :
+
+ IF quality = "nlq" OR quality = "draft"
+ THEN std quality name := quality;
+ ELSE errorstop ("unzulaessige Betriebsart")
+ FI;
+
+END PROC std quality;
+
+TEXT PROC std quality : std quality name END PROC std quality;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ y steps := (y steps DIV 30) * 30;
+ modification bits := 0;
+ out (""24""27""64""); (* Reset des Druckers *)
+ out (""27"C" + code (y steps DIV 30)); (* Formularlaenge *)
+ out (""27"x"0""); (* Entwurfsqualität *)
+ out (""27"R"0""); (* Amerikanischer Zeichensatz *)
+ out (""27"t"1""27"6"); (* Erweiterung des Zeichensatzes *)
+ IF sheet feed THEN out (""27""25"4") FI; (* Sheetmode ein *)
+ IF pos (material, "roman") <> 0
+ THEN out (""27"k"0"")
+ ELIF pos (material, "sansserif") <> 0
+ THEN out (""27"k"1"")
+ ELIF pos (material, "courier") <> 0
+ THEN out (""27"k"2"")
+ ELIF pos (material, "prestige") <> 0
+ THEN out (""27"k"3"")
+ ELIF pos (material, "script") <> 0
+ THEN out (""27"k"4"")
+ ELSE out (""27"k" + code (link (commands, std typeface) - cmd roman));
+ FI;
+ IF pos (material, "nlq") <> 0
+ THEN is nlq := TRUE;
+ ELIF pos (material, "draft") <> 0
+ THEN is nlq := FALSE;
+ ELSE is nlq := std quality = "nlq"
+ FI;
+
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ x start := 0;
+ IF sheet feed
+ THEN y start := y step conversion (8.466667e-1) (* 2/6 Inch *)
+ ELSE y start := 0;
+ FI;
+ x rest := 0;
+ out (""13"");
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+END SELECT;
+
+.
+ close document :
+
+
+. remaining y steps : param1
+.
+ close page :
+ IF sheet feed
+ THEN out (""27""25"R")
+ ELIF remaining y steps > 0
+ THEN out (""12"")
+ FI;
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ out subtext (string, from, to)
+
+.
+ write cmd :
+ buffer := subtext (string, from, to);
+ scan (buffer);
+ next symbol (symbol);
+ SELECT link (commands, symbol) OF
+ CASE cmd draft : IF is nlq THEN switch to draft FI; is nlq := FALSE;
+ CASE cmd nlq : IF NOT is nlq THEN switch to nlq FI; is nlq := TRUE;
+ CASE cmd roman : out (""27"k"0"")
+ CASE cmd sansserif : out (""27"k"1"")
+ CASE cmd courier : out (""27"k"2"")
+ CASE cmd prestige : out (""27"k"3"")
+ CASE cmd script : out (""27"k"4"")
+ OTHERWISE : out (buffer);
+ END SELECT;
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ x rest := 0;
+ out (""13"");
+
+
+. x steps : param1
+. y steps : param2
+.
+ move :
+ IF x steps < 0 OR y steps < 0
+ THEN stop
+ ELSE IF x steps > 0 THEN x move FI;
+ IF y steps > 0 THEN y move FI;
+ FI;
+
+ . x move :
+ x rest INCR x steps;
+ IF not is underline
+ THEN simple x move
+ ELSE underline x move
+ FI;
+
+ . not is underline :
+ NOT bit (modification bits, 7)
+
+ . simple x move :
+ high := x rest DIV factor 1;
+ x rest := x rest MOD factor 1;
+ out (""27"\");
+ out (code (high MOD 256));
+ out (code (high DIV 256));
+
+ . underline x move :
+ high := x rest DIV factor 2;
+ x rest := x rest MOD factor 2;
+ IF high < blank pitch
+ THEN stop
+ ELSE low := high MOD 127;
+ high := high DIV 127;
+ IF low >= blank pitch
+ THEN low DECR blankpitch;
+ ELSE high DECR 1;
+ low DECR (blankpitch - 127);
+ FI;
+ IF high > 0
+ THEN out (""27" ");
+ out (code (127 - blankpitch));
+ high TIMESOUT " ";
+ FI;
+ out (""27" ");
+ out (code (low));
+ out (" "27" "0"");
+ FI;
+
+ . y move :
+ low := y steps MOD 255;
+ high := y steps DIV 255;
+ IF high > 0 THEN high TIMESOUT (""27"J"255"") FI;
+ IF low > 0 THEN out (""27"J"); out (code (low)) FI;
+.
+ draw :
+ IF x steps < 0 OR y steps <> 0 OR linetype <> underline linetype
+ THEN stop
+ ELIF x steps > 0
+ THEN x draw
+ FI;
+
+ . x draw :
+ x rest INCR x steps;
+ steps := x rest DIV 6;
+ x rest := x rest MOD 6;
+ IF steps > 0
+ THEN low := steps MOD 256;
+ high := steps DIV 256;
+ out (""27"L");
+ out (code (low));
+ out (code (high));
+ steps TIMESOUT ""1"";
+ FI;
+
+
+. modification : param1
+.
+ on :
+ buffer := on string (modification);
+ IF buffer <> ""
+ THEN modification bits := modification bits OR code (buffer);
+ switch to font;
+ ELSE stop
+ FI
+
+.
+ off :
+ buffer := off string (modification);
+ IF buffer <> ""
+ THEN modification bits := modification bits XOR code (buffer);
+ switch to font;
+ ELSE stop
+ FI
+
+.
+ type :
+ font nr := param1;
+ buffer := font string (font nr);
+ font bits := code (buffer SUB 1);
+ font text := subtext (buffer, 2);
+ IF is prop
+ THEN factor 1 := 4;
+ factor 2 := 4;
+ ELSE factor 1 := 6;
+ factor 2 := 6;
+ FI;
+ IF is double THEN factor 2 INCR factor 2 FI;
+ blank pitch := char pitch (font nr, " ") DIV factor 2;
+ switch to font;
+ IF is nlq THEN switch to nlq FI;
+
+END PROC execute;
+
+
+PROC switch to font :
+
+ out (""27"!");
+ out (code (font bits OR modification bits));
+ out (font text);
+
+END PROC switch to font;
+
+
+PROC switch to nlq :
+
+ IF NOT is prop
+ THEN factor 1 := 4;
+ factor 2 := (4 * factor 2) DIV 6;
+ blankpitch := (6 * blankpitch) DIV 4;
+ out (""27"x"1"");
+ ELSE out (""27"x"0"");
+ FI;
+
+END PROC switch to nlq;
+
+
+PROC switch to draft :
+
+ IF NOT is prop
+ THEN factor 1 := 6;
+ factor 2 := (6 * factor 2) DIV 4;
+ blankpitch := (4 * blankpitch) DIV 6;
+ out (""27"x"0"");
+ FI;
+
+END PROC switch to draft;
+
+
+END PACKET epson sq printer;
+
+
+
+#page#
+(******************************************************************)
+(*** ***)
+(*** Generierung des Printers ***)
+(*** ***)
+(******************************************************************)
+
+LET printer name = "printer.epson.sq",
+ up = ""3""13""5"";
+
+TEXT VAR fonttab name := "fonttab.epson.sq";
+
+BOOL CONST multi user := (pcb (9) AND 255) <> 1;
+
+INT VAR pr channel;
+TEXT VAR buffer;
+
+command dialogue (TRUE);
+IF NOT multi user
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+FI;
+ask for print channel;
+ask for paper format;
+ask for typeface;
+ask for print quality;
+load font table;
+forget (printer name, quiet);
+IF multi user THEN generate printer spool FI;
+check on;
+.
+ ask for print channel :
+ line;
+ put ("gib Druckerkanal:");
+ get (pr channel);
+ do ("serverchannel(" + text (pr channel) + ")" ) ;
+ line;
+.
+ ask for paper format :
+ SELECT paper format OF
+ CASE 1 : papersize ( 8.0 * 2.54, 12.0 * 2.54)
+ CASE 2 : papersize (13.6 * 2.54, 12.0 * 2.54)
+ CASE 3 : papersize (21.0, 29.7)
+ END SELECT
+
+ . paper format :
+ line;
+ REP out (up);
+ IF yes ("Papierformat : endlos, 8 Zoll breit")
+ THEN LEAVE paper format WITH 1 FI;
+ out (up);
+ IF yes ("Papierformat : endlos, 13.6 Zoll breit")
+ THEN LEAVE paper format WITH 2 FI;
+ out (up);
+ IF yes ("Papierformat : DINA 4")
+ THEN LEAVE paper format WITH 3 FI;
+ PER;
+ 0
+.
+ ask for typeface :
+ line;
+ std typeface (typeface)
+
+ . typeface :
+ REP out (up);
+ IF yes ("standardmäßige Schriftart : roman")
+ THEN LEAVE typeface WITH "roman" FI;
+ out (up);
+ IF yes ("standardmäßige Schriftart : sansserif")
+ THEN LEAVE typeface WITH "sansserif" FI;
+ out (up);
+ IF yes ("standardmäßige Schriftart : courier")
+ THEN LEAVE typeface WITH "courier" FI;
+ out (up);
+ IF yes ("standardmäßige Schriftart : prestige")
+ THEN LEAVE typeface WITH "prestige" FI;
+ out (up);
+ IF yes ("standardmäßige Schriftart : script")
+ THEN LEAVE typeface WITH "script" FI;
+ PER;
+ ""
+.
+ ask for print quality :
+ line;
+ std quality (quality);
+
+ . quality :
+ REP out (up);
+ IF yes ("standardmäßige Druckqualität : draft quality")
+ THEN LEAVE quality WITH "draft" FI;
+ out (up);
+ IF yes ("standardmäßige Druckqualität : near letter quality")
+ THEN LEAVE quality WITH "nlq" FI;
+ PER;
+ ""
+.
+ load font table :
+ IF NOT exists (fonttab name)
+ THEN command dialogue (TRUE);
+ REP line (2);
+ putline ("Bitte Archiv mit der Fonttabelle """ +
+ fonttab name + """ einlegen!");
+ line;
+ UNTIL yes ("Archiv eingelegt") PER;
+ reserve archive;
+ fetch (fonttab name, archive);
+ release (archive);
+ FI;
+ font table (fonttab name);
+ IF multi user
+ THEN command dialogue (FALSE);
+ do ("save(""" + font tab name + """,task(""configurator""))")
+ FI;
+ forget (fonttab name, quiet);
+
+ . reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop;
+
+. generate printer spool :
+ eumel must advertise;
+ cursor (1, 12);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (4);
+ putline ("Generierung beendet, weiter mit 'SV'");
+ generate printer server;
+ do (buffer);
+
+. generate printer server :
+ buffer := "break (quiet);";
+ buffer CAT "spool manager (PROC printer);";
+ buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;";
+ buffer CAT "PROC printer:";
+ buffer CAT " disable stop;";
+ buffer CAT " continue (server channel);";
+ buffer CAT " check error (error message);";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " REP forget (ds);";
+ buffer CAT " execute print;";
+ buffer CAT " IF is error AND online THEN put error; clear error; FI;";
+ buffer CAT " PER;";
+ buffer CAT "END PROC printer;";
+ buffer CAT "PROC execute print:";
+ buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;";
+ buffer CAT " enable stop;";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " call (father, fetch code, ds, reply);";
+ buffer CAT " IF reply = ack CAND type (ds) = file type";
+ buffer CAT " THEN file := sequential file (input, ds);";
+ buffer CAT " print (file,";
+ buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,";
+ buffer CAT " PROC (INT CONST, INT CONST) close,";
+ buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC execute print;";
+ buffer CAT "PROC check error(TEXT CONST message):";
+ buffer CAT " IF is error";
+ buffer CAT " THEN clear error; rename myself (message);";
+ buffer CAT " IF is error THEN end(myself) FI;";
+ buffer CAT " pause (9000); end(myself);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC check error;";
+
diff --git a/system/printer-laser/4/src/printer.hp.laserjet b/system/printer-laser/4/src/printer.hp.laserjet
new file mode 100644
index 0000000..152ee8e
--- /dev/null
+++ b/system/printer-laser/4/src/printer.hp.laserjet
@@ -0,0 +1,417 @@
+PACKET hp laserjet printer
+
+(**************************************************************************)
+(* Stand : 03.02.88 *)
+(* HP 2686A LaserJet / LaserJet+ Verison : 4 *)
+(* Autor : Rudolf Ruland *)
+(**************************************************************************)
+
+ DEFINES open,
+ close,
+ execute,
+
+ paper size,
+ printer type :
+
+LET
+(* underline = 1,
+ bold = 2,
+ italics = 4,
+ reverse = 8,
+
+ underline linetype = 1, *)
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1,
+ c write cmd = 2,
+ c carriage return = 3,
+ c move = 4,
+ c draw = 5,
+ c on = 6,
+ c off = 7,
+ c type = 8;
+
+INT VAR abs x pos
+REAL VAR x size, y size;
+BOOL VAR is laser jet plus, is landscape;
+
+(*********************************************************************)
+
+paper size (21.0, 29.7);
+printer type ("LaserJet");
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+PROC printer type (TEXT CONST type) :
+
+ is laser jet plus := pos (type, "+") <> 0
+
+END PROC printer type;
+
+TEXT PROC printer type :
+
+ IF is laser jet plus
+ THEN "LaserJet+"
+ ELSE "LaserJet"
+ FI
+
+END PROC printer type;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ out (""27"E"); (* Reset des Druckers *)
+ out (""27"&s1C"); (* 'end of line wrap' aus *)
+ out (""27"&l0L"); (* 'perforation skip' aus *)
+ out (""27"&l1X"); (* eine Kopie *)
+ out (""27"&l1H"); (* upper tray *)
+ IF pos (material, "landscape") > 0 OR pos (material, "quer") > 0
+ THEN is landscape := TRUE;
+ x steps := x step conversion ( y size );
+ y steps := y step conversion ( x size );
+ out (""27"&l1O");
+ ELSE is landscape := FALSE;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ FI;
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ IF is landscape
+ THEN x start := x step conversion (0.508); (* 0.200*2.54 *)
+ y start := y step conversion (1.693333); (* 0.500*2.54 + 2.54/6.0 *)
+ ELSE x start := x step conversion (0.39878); (* 0.157*2.54 *)
+ y start := y step conversion (1.693333); (* 0.500*2.54 + 2.54/6.0 *)
+ FI;
+ IF pos (material, "lower tray") > 0 COR pos (material, "lowertray") > 0
+ THEN out (""27"&l4H");
+ ELIF pos (material, "tray") > 0 COR pos (material, "upper tray") > 0 COR pos (material, "uppertray") > 0
+ THEN out (""27"&l1H");
+ ELIF pos (material, "manual") > 0
+ THEN out (""27"&l2H");
+ ELIF pos (material, "envelope") > 0
+ THEN out (""27"&l3H");
+ FI;
+ IF material contains a number
+ THEN out (""27"&l" + text (number) + "X");
+ FI;
+ out (""13"");
+
+ . material contains a number :
+ INT VAR number := pos (material, "0", "9", 1);
+ IF number = 0
+ THEN FALSE
+ ELSE number := max (1, int (subtext (material, number, number + 1)));
+ TRUE
+ FI
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+ OTHERWISE : put (param1)
+END SELECT;
+
+.
+ close document :
+
+
+(*. remaining y steps : param1*)
+.
+ close page :
+ out (""12"")
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ out subtext (string, from, to)
+
+.
+ write cmd :
+ out subtext (string, from, to)
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ out (""13"")
+
+
+. x steps : param1
+. y steps : param2
+.
+ move :
+ IF x steps <> 0
+ THEN x move
+ ELIF y steps > 0
+ THEN out (""27"&a+" + text (y steps) + "V");
+ ELIF y steps < 0
+ THEN out (""27"&a" + text (y steps) + "V");
+ FI;
+
+ . x move :
+ IF is laser jet plus
+ THEN laser jet plus x move
+ ELSE laser jet x move
+ FI;
+
+ . laser jet plus x move :
+ IF x steps >= 0
+ THEN out (""27"*p+" + text (x steps) + "X");
+ ELSE out (""27"*p" + text (x steps) + "X");
+ FI;
+
+ . laser jet x move :
+ abs x pos := x pos;
+ IF abs x pos >= 0
+ THEN out (""27"&a");
+ out (text ((abs x pos DIV 5) * 12 + ((abs x pos MOD 5) * 12 + 4) DIV 5));
+ out ("H");
+ ELSE stop
+ FI;
+
+.
+ draw :
+ stop
+
+
+. modification : param1
+.
+ on :
+ IF on string (modification) <> ""
+ THEN out (on string (modification))
+ ELSE stop
+ FI
+
+.
+ off :
+ IF off string (modification) <> ""
+ THEN out (off string (modification))
+ ELSE stop
+ FI
+
+
+. font nr : param1
+.
+ type :
+ out (font string (font nr));
+
+END PROC execute;
+
+
+END PACKET hp laserjet printer;
+
+
+#page#
+(******************************************************************)
+(*** ***)
+(*** Generierung des Printers ***)
+(*** ***)
+(******************************************************************)
+
+LET printer name = "printer.hp.laserjet",
+ up = ""3""13""5"";
+
+TEXT VAR fonttab name := "fonttab.hp.laserjet";
+
+BOOL CONST multi user := (pcb (9) AND 255) <> 1;
+
+INT VAR pr channel;
+TEXT VAR buffer;
+
+command dialogue (TRUE);
+IF NOT multi user
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+FI;
+ask for print channel;
+ask for printer type;
+load font table;
+forget (printer name, quiet);
+IF multi user THEN generate printer spool FI;
+check on;
+.
+ ask for print channel :
+ line;
+ put ("gib Druckerkanal:");
+ get (pr channel);
+ do ("serverchannel(" + text (pr channel) + ")" ) ;
+ line;
+.
+ ask for printer type :
+ printer type (laser jet);
+
+ . laser jet :
+ line;
+ REP out (up);
+ IF yes ("Druckertyp : HP LaserJet")
+ THEN LEAVE laser jet WITH "LaserJet" FI;
+ out (up);
+ IF yes ("Druckertyp : HP LaserJet+")
+ THEN LEAVE laser jet WITH "LaserJet+" FI;
+ PER;
+ ""
+.
+ load font table :
+ line (2);
+ write (""13""4"");
+ putline ("Die Fonttabelle """ + fonttab name +
+ """ enthält die Schrifttypen der");
+ putline ("Font Cartriges:");
+ putline (" 92286A Courier 1");
+ putline (" 92286C International 1");
+ putline (" 92286D Prestige Elite");
+ putline (" 92286E Letter Gothic");
+ putline (" 92286F TMS Proportional 2");
+ putline (" 92286L Courier P&L");
+ putline (" 92286M Prestige Elite P&L");
+ putline (" 92286N Letter Gothic P&L");
+ putline (" 92286P TMS RMN P&L");
+ putline (" 92286Q Memo 1");
+ line;
+ putline ("Für ein korrektes Druckbild dürfen immer nur die Schrifttypen angesprochen");
+ putline ("werden, deren Cartrige eingeschoben ist!");
+ IF printer type = "LaserJet"
+ THEN line;
+ putline ("ELAN-Listings können nur gedruckt werden, wenn ein Cartrige mit dem");
+ putline ("Schrifttyp 'LINE PRINTER' eingeschoben ist!");
+ FI;
+ line (2);
+ putline ("Weiter nach Eingabe einer Taste");
+ pause;
+ IF NOT exists (fonttab name)
+ THEN command dialogue (TRUE);
+ REP line (2);
+ putline ("Bitte Archiv mit der Fonttabelle """ +
+ fonttab name + """ einlegen!");
+ line;
+ UNTIL yes ("Archiv eingelegt") PER;
+ reserve archive;
+ fetch (fonttab name, archive);
+ release (archive);
+ FI;
+ font table (fonttab name);
+ IF multi user
+ THEN command dialogue (FALSE);
+ do ("save(""" + font tab name + """,task(""configurator""))")
+ FI;
+ forget (fonttab name, quiet);
+
+ . reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop;
+
+. generate printer spool :
+ eumel must advertise;
+ cursor (1, 12);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (4);
+ putline ("Generierung beendet, weiter mit 'SV'");
+ generate printer server;
+ do (buffer);
+
+. generate printer server :
+ buffer := "break (quiet);";
+ buffer CAT "spool manager (PROC printer);";
+ buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;";
+ buffer CAT "PROC printer:";
+ buffer CAT " disable stop;";
+ buffer CAT " continue (server channel);";
+ buffer CAT " check error (error message);";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " REP forget (ds);";
+ buffer CAT " execute print;";
+ buffer CAT " IF is error AND online";
+ buffer CAT " THEN out (""""27""(8U""27""(s0p10h12v0s0b3T"");";
+ buffer CAT " put error; clear error; out (""""12"""");";
+ buffer CAT " FI;";
+ buffer CAT " PER;";
+ buffer CAT "END PROC printer;";
+ buffer CAT "PROC execute print:";
+ buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;";
+ buffer CAT " enable stop;";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " call (father, fetch code, ds, reply);";
+ buffer CAT " IF reply = ack CAND type (ds) = file type";
+ buffer CAT " THEN file := sequential file (input, ds);";
+ buffer CAT " print (file,";
+ buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,";
+ buffer CAT " PROC (INT CONST, INT CONST) close,";
+ buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC execute print;";
+ buffer CAT "PROC check error(TEXT CONST message):";
+ buffer CAT " IF is error";
+ buffer CAT " THEN clear error; rename myself (message);";
+ buffer CAT " IF is error THEN end(myself) FI;";
+ buffer CAT " pause (9000); end(myself);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC check error;";
+
diff --git a/system/printer-laser/4/src/printer.kyocera.f-1010 b/system/printer-laser/4/src/printer.kyocera.f-1010
new file mode 100644
index 0000000..a46f7b3
--- /dev/null
+++ b/system/printer-laser/4/src/printer.kyocera.f-1010
@@ -0,0 +1,373 @@
+PACKET kyocera f 1010 printer
+
+(**************************************************************************)
+(* Stand : 03.12.86 *)
+(* KYOCERA F - 1010 Verison : 4 *)
+(* Autor : Rudolf Ruland *)
+(**************************************************************************)
+
+(**************************************************************************)
+(* Hinweis : Die 'time-out' Zeit, nach der der Eingabepuffer ausgegeben *)
+(* wird, wenn keine Eingabe mehr erfolgt, sollte moeglichst *)
+(* gross gewaehlt werden, *)
+(* z.B. mit FRPO H9, 60; wird sie auf 5 Min. gesetzt *)
+(**************************************************************************)
+
+
+ DEFINES open,
+ close,
+ execute,
+
+ paper size :
+
+LET underline = 1,
+(* bold = 2,
+ italics = 4,
+ reverse = 8,
+
+ underline linetype = 1, *)
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1,
+ c write cmd = 2,
+ c carriage return = 3,
+ c move = 4,
+ c draw = 5,
+ c on = 6,
+ c off = 7,
+ c type = 8;
+
+INT VAR blankpitch, high, low;
+REAL VAR x size, y size;
+BOOL VAR is landscape, is underline;
+
+(*********************************************************************)
+
+paper size (21.0, 29.7);
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ out ("!"82"! RES; UNIT D; EXIT;"); (* Reset des Druckers *)
+ IF pos (material, "landscape") > 0 OR pos (material, "quer") > 0
+ THEN is landscape := TRUE;
+ x steps := x step conversion ( y size );
+ y steps := y step conversion ( x size );
+ out (""27"&l1O");
+ ELSE is landscape := FALSE;
+ x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ FI;
+ is underline := FALSE;
+ IF y size < 29.7 OR x size < 21.0
+ THEN out ("!"82"! SLM ");
+ IF is landscape
+ THEN out (text (x step conversion (29.7 - y size)));
+ out ("; STM ");
+ out (text (y step conversion ((21.0 - x size) * 0.5)));
+ ELSE out (text (x step conversion ((21.0 - x size) * 0.5)));
+ FI;
+ out ("; EXIT;");
+ FI;
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ out ("!"82"! MZP 0, 0; EXIT;"); (* Positionierung zum Nullpunkt *)
+ IF is landscape
+ THEN x start := x step conversion (0.19);
+ y start := y step conversion (0.70);
+ ELSE x start := x step conversion (0.56);
+ y start := y step conversion (0.60);
+ FI;
+ IF pos (material, "tray") > 0
+ THEN out (""27"&l1H");
+ ELIF pos (material, "manual") > 0
+ THEN out (""27"&l2H");
+ FI;
+ out (""13"");
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+ OTHERWISE : put (param1)
+END SELECT;
+
+.
+ close document :
+
+
+(*. remaining y steps : param1*)
+.
+ close page :
+ out (""12"");
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ out subtext (string, from, to)
+
+.
+ write cmd :
+ out subtext (string, from, to)
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ out (""13"")
+
+
+. x steps : param1
+. y steps : param2
+.
+ move :
+ IF x steps > 0
+ THEN IF is underline
+ THEN underline x move
+ ELSE out (""27"*p+" + text (x steps) + "X");
+ FI;
+ ELIF x steps < 0
+ THEN out (""27"*p" + text (x steps) + "X");
+ ELIF y steps > 0
+ THEN out (""27"*p+" + text (y steps) + "Y");
+ ELIF y steps < 0
+ THEN out (""27"*p" + text (y steps) + "Y");
+ FI;
+
+ . underline x move :
+ high := x steps DIV blankpitch;
+ low := x steps MOD blankpitch;
+ IF high > 0 THEN high TIMESOUT " " FI;
+ IF low > 0 THEN out (" "27"*p" + text (low - blank pitch) + "X") FI;
+
+.
+ draw :
+ stop
+
+
+. modification : param1
+.
+ on :
+ IF on string (modification) <> ""
+ THEN out (on string (modification));
+ IF modification = underline THEN is underline := TRUE FI;
+ ELSE stop
+ FI
+
+.
+ off :
+ IF off string (modification) <> ""
+ THEN out (off string (modification));
+ IF modification = underline THEN is underline := FALSE FI;
+ ELSE stop
+ FI
+
+
+. font nr : param1
+.
+ type :
+ out (font string (font nr));
+ blankpitch := char pitch (font nr, " ");
+
+END PROC execute;
+
+
+END PACKET kyocera f 1010 printer;
+
+
+
+#page#
+(******************************************************************)
+(*** ***)
+(*** Generierung des Printers ***)
+(*** ***)
+(******************************************************************)
+
+LET printer name = "printer.kyocera.f-1010";
+
+TEXT VAR fonttab name := "fonttab.kyocera.f-1010";
+
+BOOL CONST multi user := (pcb (9) AND 255) <> 1;
+
+INT VAR pr channel;
+TEXT VAR buffer;
+
+command dialogue (TRUE);
+IF NOT multi user
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+FI;
+ask for print channel;
+dynamic font hint;
+load font table;
+forget (printer name, quiet);
+IF multi user THEN generate printer spool FI;
+check on;
+command dialogue (TRUE);
+.
+ ask for print channel :
+ line;
+ put ("gib Druckerkanal:");
+ get (pr channel);
+ do ("serverchannel(" + text (pr channel) + ")" ) ;
+ line;
+.
+ dynamic font hint :
+ line (3);
+ putline (""4"Hinweis zur Benutzung der dynamischen Schrifttypen:");
+ line;
+ putline (" In der Fonttabelle """ + fonttab name + """ sind einige dynamische");
+ putline (" Schrifttypen angepaßt. Diese müssen nach jedem Einschalten des");
+ putline (" Druckers neu generiert werden.");
+ putline (" Zur Generierung dieser Schrifttypen befinden sich auf dem Standard-");
+ putline (" archive die folgenden Dateien:");
+ line;
+ putline (" ""genfont.kyocera.f-1010.dynamic1""");
+ putline (" ""genfont.kyocera.f-1010.dynamic2""");
+ line;
+ putline (" Nach Einschalten des Druckers müssen diese Dateien zuerst ausgedruckt");
+ putline (" werden.");
+ putline (" Die Generierung benötigt pro Schriftart etwa 15 Minuten.");
+ line (2);
+ putline ("Weiter nach Eingabe einer Taste");
+ pause;
+.
+ load font table :
+ IF NOT exists (fonttab name)
+ THEN REP line (2);
+ putline ("Bitte Archiv mit der Fonttabelle """ +
+ fonttab name + """ einlegen!");
+ line;
+ UNTIL yes ("Archiv eingelegt") PER;
+ reserve archive;
+ fetch (fonttab name, archive);
+ release (archive);
+ FI;
+ font table (fonttab name);
+ IF multi user
+ THEN command dialogue (FALSE);
+ do ("save(""" + font tab name + """,task(""configurator""))")
+ FI;
+ forget (fonttab name, quiet);
+
+ . reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop;
+
+. generate printer spool :
+ eumel must advertise;
+ cursor (1, 12);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (4);
+ putline ("Generierung beendet, weiter mit 'SV'");
+ generate printer server;
+ do (buffer);
+
+. generate printer server :
+ buffer := "break (quiet);";
+ buffer CAT "spool manager (PROC printer);";
+ buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;";
+ buffer CAT "PROC printer:";
+ buffer CAT " disable stop;";
+ buffer CAT " continue (server channel);";
+ buffer CAT " check error (error message);";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " REP forget (ds);";
+ buffer CAT " execute print;";
+ buffer CAT " IF is error AND online";
+ buffer CAT " THEN out (""""27""(8U""27""(s0p10h12v0s0b3T"");";
+ buffer CAT " put error; clear error; out (""""12"""");";
+ buffer CAT " FI;";
+ buffer CAT " PER;";
+ buffer CAT "END PROC printer;";
+ buffer CAT "PROC execute print:";
+ buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;";
+ buffer CAT " enable stop;";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " call (father, fetch code, ds, reply);";
+ buffer CAT " IF reply = ack CAND type (ds) = file type";
+ buffer CAT " THEN file := sequential file (input, ds);";
+ buffer CAT " print (file,";
+ buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,";
+ buffer CAT " PROC (INT CONST, INT CONST) close,";
+ buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC execute print;";
+ buffer CAT "PROC check error(TEXT CONST message):";
+ buffer CAT " IF is error";
+ buffer CAT " THEN clear error; rename myself (message);";
+ buffer CAT " IF is error THEN end(myself) FI;";
+ buffer CAT " pause (9000); end(myself);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC check error;";
+
diff --git a/system/printer-laser/4/src/printer.nec.lc-08 b/system/printer-laser/4/src/printer.nec.lc-08
new file mode 100644
index 0000000..9ee2837
--- /dev/null
+++ b/system/printer-laser/4/src/printer.nec.lc-08
@@ -0,0 +1,626 @@
+PACKET nec lc 08 printer
+
+(**************************************************************************)
+(* Stand : 29.01.88 *)
+(* NEC Silentwriter LC-08 Verison : 4 *)
+(* Autor : Rudolf Ruland *)
+(**************************************************************************)
+
+ DEFINES open,
+ close,
+ execute,
+
+ box commands,
+ insert box command,
+ delete box command,
+
+ paper size,
+ paper x size,
+ paper y size:
+
+LET
+(* underline = 1,
+ bold = 2,
+ italics = 4,
+ reverse = 8,
+
+ underline linetype = 1, *)
+
+ c document = 1,
+ c page = 2,
+
+ c write text = 1,
+ c write cmd = 2,
+ c carriage return = 3,
+ c move = 4,
+ c draw = 5,
+ c on = 6,
+ c off = 7,
+ c type = 8,
+
+ tag type = 1;
+
+INT VAR symbol type;
+REAL VAR x size, y size;
+BOOL VAR is landscape, was cr;
+TEXT VAR bold buffer, mod string, command, symbol;
+THESAURUS VAR box cmds := empty thesaurus;
+
+(*********************************************************************)
+
+paper size (21.0, 29.7);
+
+PROC paper size (REAL CONST x, y) :
+
+ x size := x;
+ y size := y;
+
+END PROC paper size;
+
+PROC paper size :
+
+ line;
+ putline ("Papierbreite = " + text (x size, 5, 2) + " cm = " + text (x size / 2.54, 5, 2) + " Zoll");
+ putline ("Papierlaenge = " + text (y size, 5, 2) + " cm = " + text (y size / 2.54, 5, 2) + " Zoll");
+
+END PROC paper size;
+
+REAL PROC paper x size : x size END PROC paper x size;
+REAL PROC paper y size : y size END PROC paper y size;
+
+
+THESAURUS PROC box commands : box cmds END PROC box commands;
+
+PROC insert box command (TEXT CONST new command) :
+
+ command := new command;
+ change all (command, " ", "");
+ insert (box cmds, command)
+
+END PROC insert box command;
+
+PROC delete box command (TEXT CONST old command) :
+
+ INT VAR dummy;
+ command := old command;
+ change all (command, " ", "");
+ delete (box cmds, command, dummy)
+
+END PROC delete box command;
+
+(*********************************************************************)
+
+PROC open (INT CONST op code, INT VAR param1, param2) :
+
+SELECT op code OF
+ CASE c document : open document
+ CASE c page : open page
+END SELECT;
+
+
+. x steps : param1
+. y steps : param2
+.
+ open document :
+ out (""28"Cz"); (* Diablo 630 Emulation *)
+ out (""27""13"P"); (* Reset *)
+ out (""28"$"); (* Formatlaenge loeschen *)
+ out (""28"Ca"27"6"28"Cz"); (* Zeichensatz 2 *)
+ out (""28"Ra"); (* USA-Zeichensatz *)
+ out (""27""25"1"); (* Sheet 1 *)
+ is landscape := pos (material, "landscape") > 0;
+ IF is landscape
+ THEN x steps := x step conversion ( y size );
+ y steps := y step conversion ( x size );
+ out (""28")"128""0""); (* Landscape-Mode *)
+ ELSE x steps := x step conversion ( x size );
+ y steps := y step conversion ( y size );
+ out (""28")"001""0""); (* Portait -Mode *)
+ FI;
+ was cr := FALSE;
+ bold buffer := "";
+
+. x start : param1
+. y start : param2
+.
+ open page :
+ IF is landscape
+ THEN x start := x step conversion (0.45);
+ y start := y step conversion (0.9);
+ ELSE x start := x step conversion (0.7);
+ y start := y step conversion (0.9);
+ FI;
+ IF pos (material, "sheet1") > 0
+ THEN out (""27""25"1")
+ ELIF pos (material, "sheet2") > 0
+ THEN out (""27""25"2")
+ ELIF pos (material, "manual") > 0
+ THEN out (""27""25"E")
+ FI;
+ out (""28"'a"0""0""28"&a"0""0""); (* Positionierung auf den Nullpunkt *)
+
+END PROC open;
+
+
+PROC close (INT CONST op code, INT CONST param1) :
+
+SELECT op code OF
+ CASE c document : close document
+ CASE c page : close page
+ OTHERWISE : put (param1)
+END SELECT;
+
+.
+ close document :
+
+
+(*. remaining y steps : param1*)
+.
+ close page :
+ out (""12"")
+
+END PROC close;
+
+
+PROC execute (INT CONST op code, TEXT CONST string, INT CONST param1, param2) :
+
+SELECT op code OF
+ CASE c write text : write text
+ CASE c write cmd : write cmd
+ CASE c carriage return : carriage return
+ CASE c move : move
+ CASE c draw : draw
+ CASE c on : on
+ CASE c off : off
+ CASE c type : type
+END SELECT
+
+
+. from : param1
+. to : param2
+.
+ write text :
+ IF was cr
+ THEN was cr := FALSE;
+ out (bold buffer);
+ FI;
+ out subtext (string, from, to)
+
+.
+ write cmd :
+ IF was cr
+ THEN was cr := FALSE;
+ out (bold buffer);
+ FI;
+ command := subtext (string, from, to);
+ IF is box cmd
+ THEN disable stop;
+ do (command);
+ clear error;
+ ELSE out (command);
+ FI;
+
+ . is box cmd :
+ scan (command);
+ next symbol (symbol, symbol type);
+ (symbol type = tag type) CAND (box cmds CONTAINS symbol)
+
+
+(*. x steps to left margin : param1*)
+.
+ carriage return :
+ out (""13"");
+ was cr := TRUE;
+
+
+. x steps : param1
+. y steps : param2
+.
+ move :
+ IF x steps <> 0 THEN x move FI;
+ IF y steps <> 0 THEN y move FI;
+
+ . x move :
+ IF x steps > 0 THEN out (""28"&c") ELSE out (""28"&d") FI;
+ out (x steps low);
+ out (x steps high);
+
+ . x steps low : code (abs (x steps) MOD 256)
+ . x steps high : code (abs (x steps) DIV 256)
+
+ . y move :
+ IF y steps > 0 THEN out (""28"'c") ELSE out (""28"'d") FI;
+ out (y steps low);
+ out (y steps high);
+
+ . y steps low : code (abs (y steps) MOD 256)
+ . y steps high : code (abs (y steps) DIV 256)
+.
+ draw :
+ stop
+
+
+. modification : param1
+.
+ on :
+ mod string := on string (modification);
+ IF mod string <> ""
+ THEN out (mod string);
+ IF pos (""27"W"27"O", mod string) > 0
+ THEN bold buffer CAT mod string;
+ FI;
+ ELSE stop
+ FI
+
+.
+ off :
+ mod string := off string (modification);
+ IF mod string <> ""
+ THEN out (mod string);
+ IF pos (""27"&", mod string) > 0
+ THEN bold buffer := subtext (bold buffer, 1, LENGTH bold buffer - 2);
+ out (bold buffer);
+ FI;
+ ELSE stop
+ FI
+
+
+. font nr : param1
+.
+ type :
+ out (""28")"); (* Font Identifikation *)
+ command := font string (font nr);
+ IF is landscape
+ THEN out subtext (command, 3, 4);
+ ELSE out subtext (command, 1, 2);
+ FI;
+ out (""28"E"); (* Zeilenvorschub (VMI) *)
+ out (code (font height (font nr) + font depth (font nr) + font lead (font nr)));
+ out (""28"F"); (* Zeichenabstand (HMI) *)
+ out (code (char pitch (font nr, " ")));
+ out (""27"P"); (* proportional ein *)
+ out subtext (command, 5);
+
+END PROC execute;
+
+END PACKET nec lc 08 printer;
+
+
+PACKET nec lc 08 box commands
+
+(**************************************************************************)
+(* *)
+(* Kommandos zum Zeichen von Boxen, Linien und Schraffuren *)
+(* für den NEC Laserdrucker LC-08 *)
+(* *)
+(* Autor : Rudolf Ruland *)
+(* Stand : 29.01.88 *)
+(**************************************************************************)
+
+ DEFINES line,
+ x line,
+ y line,
+
+ box,
+ box frame,
+ box shade,
+
+ cake,
+ cake frame,
+ cake shade,
+ :
+
+INT VAR x, y, h, w;
+
+WHILE highest entry (box commands) > 0
+ REP delete box command (name (box commands, highest entry (box commands))) PER;
+insert box command ("line");
+insert box command ("xline");
+insert box command ("yline");
+insert box command ("box");
+insert box command ("boxshade");
+insert box command ("boxframe");
+insert box command ("cake");
+insert box command ("cakeshade");
+insert box command ("cakeframe");
+
+
+PROC line (REAL CONST x offset, y offset, width, height, INT CONST line width) :
+
+ IF line width > 0
+ THEN graph on (x offset, y offset, width, height);
+ out ("LW" + text (line width) + ";");
+ out ("PR;");
+ out ("PD" + text (+w) + "," + text (-h) + ";");
+ graph off;
+ FI;
+
+END PROC line;
+
+PROC x line (REAL CONST x offset, y offset, width, INT CONST line width) :
+
+ IF line width > 0
+ THEN graph on (x offset, y offset, width, 0.0);
+ out ("LW" + text (line width) + ";");
+ out ("PR;");
+ out ("PD" + text (+w) + "," + "0;");
+ graph off;
+ FI;
+
+END PROC x line;
+
+PROC y line (REAL CONST x offset, y offset, height, INT CONST line width) :
+
+ IF line width > 0
+ THEN graph on (x offset, y offset, 0.0, height);
+ out ("LW" + text (line width) + ";");
+ out ("PR;");
+ out ("PD0," + text (-h) + ";");
+ graph off;
+ FI;
+
+END PROC y line;
+
+
+PROC box (REAL CONST x offset, y offset, width, height,
+ INT CONST pattern type, line width) :
+
+ IF pattern type = 0
+ THEN box frame (x offset, y offset, width, height, line width)
+ ELIF line width = 0
+ THEN box shade (x offset, y offset, width, height, pattern type)
+ ELSE graph on (x offset, y offset, width, height);
+ out ("LW" + text (line width) + ";");
+ set pattern (pattern type);
+ out ("ER" + text (+w) + "," + text (-h) + ";");
+ graph off;
+ FI;
+
+END PROC box;
+
+
+PROC box shade (REAL CONST x offset, y offset, width, height,
+ INT CONST pattern type) :
+
+ IF pattern type <> 0
+ THEN graph on (x offset, y offset, width, height);
+ set pattern (pattern type);
+ out ("RR" + text (+w) + "," + text (-h) + ";");
+ graph off;
+ FI;
+
+END PROC box shade;
+
+
+PROC box frame (REAL CONST x offset, y offset, width, height,
+ INT CONST line width) :
+
+ IF line width <> 0
+ THEN graph on (x offset, y offset, width, height);
+ out ("LW" + text (line width) + ";");
+ out ("PR;");
+ out ("PD");
+ out (text (+w) + "," + "0,");
+ out ( "0," + text (-h) + ",");
+ out (text (-w) + "," + "0,");
+ out ( "0," + text (+h) + ";");
+ graph off;
+ FI;
+
+END PROC box frame;
+
+
+PROC cake (REAL CONST x offset, y offset, radius, start angle, sweep angle,
+ INT CONST pattern type, line width) :
+
+ IF pattern type = 0
+ THEN cake frame (x offset, y offset, radius, start angle, sweep angle, line width)
+ ELIF line width = 0
+ THEN cake shade (x offset, y offset, radius, start angle, sweep angle, pattern type)
+ ELSE graph on (x offset, y offset, radius, 0.0);
+ out ("LW" + text (line width) + ";");
+ set pattern (pattern type);
+ out ("EW" + text (+w) + "," + text (start angle) + "," + text (sweep angle) + ";");
+ graph off;
+ FI;
+
+END PROC cake;
+
+
+PROC cake shade (REAL CONST x offset, y offset, radius, start angle, sweep angle,
+ INT CONST pattern type) :
+
+ IF pattern type > 0 CAND w > 0
+ THEN graph on (x offset, y offset, radius, 0.0);
+ set pattern (pattern type);
+ out ("WG" + text (+w) + "," + text (start angle) + "," + text (sweep angle) + ";");
+ graph off;
+ FI;
+
+END PROC cake shade;
+
+
+PROC cake frame (REAL CONST x offset, y offset, radius, start angle, sweep angle,
+ INT CONST line width) :
+
+
+ IF line width <> 0
+ THEN REAL CONST xs := real (x) + cos (start angle*pi/180.0) * real (w),
+ ys := real (y) + sin (start angle*pi/180.0) * real (w);
+ graph on (x offset, y offset, radius, 0.0);
+ out ("LW" + text (line width) + ";");
+ out ("MA"+ text (xs) + "," + text (ys) + ";");
+ out ("FA"+ text ( x) + "," + text ( y) + "," + text (sweep angle) + ";");
+ out ("MA"+ text ( x) + "," + text ( y) + ";");
+ graph off;
+ FI;
+
+END PROC cake frame;
+
+
+PROC graph on (REAL CONST x offset, y offset, width, height) :
+
+ x := x pos + x step conversion (x offset);
+ y := plot y size - (y pos + y step conversion (y offset));
+ w := x step conversion (width);
+ h := y step conversion (height);
+ out (""28"Aa");
+ out ("DF;");
+ out ("MA"+ text (x) + "," + text (y) + ";");
+
+ . plot y size : 3389 - y step conversion (1.0)
+
+END PROC graph on;
+
+PROC graph off :
+
+ out (""28"Az");
+
+END PROC graph off;
+
+
+PROC set pattern (INT CONST pattern type) :
+
+ out ("XX1;");
+ out (pattern);
+
+ . pattern :
+ SELECT pattern type OF
+ CASE 1 : "FT2,1,0;"
+ CASE 2 : "FT2,1,90;"
+ CASE 3 : "FT2,1,45;"
+ CASE 4 : "FT3,1,0;"
+ CASE 5 : "FT3,1,45;"
+ CASE 6 : "FT2,100,0;"
+ CASE 7 : "FT2,100,90;"
+ CASE 8 : "FT2,100,45;"
+ CASE 9 : "FT3,100,0;"
+ CASE 10 : "FT3,100,45;"
+ OTHERWISE : "FT1;"
+ END SELECT
+
+END PROC set pattern;
+
+
+END PACKET nec lc 08 box commands;
+
+
+
+#page#
+(******************************************************************)
+(*** ***)
+(*** Generierung des Printers ***)
+(*** ***)
+(******************************************************************)
+
+LET printer name = "printer.nec.lc-08";
+
+TEXT VAR fonttab name := "fonttab.nec.lc-08";
+
+BOOL CONST multi user := (pcb (9) AND 255) <> 1;
+
+INT VAR pr channel;
+TEXT VAR buffer;
+
+command dialogue (TRUE);
+IF NOT multi user
+ THEN errorstop ("Dieser Treiber arbeitet nur mit Multi-Tasking-EUMEL")
+FI;
+ask for print channel;
+load font table;
+forget (printer name, quiet);
+IF multi user THEN generate printer spool FI;
+command dialogue (TRUE);
+check on;
+.
+ ask for print channel :
+ line;
+ put ("gib Druckerkanal:");
+ get (pr channel);
+ do ("serverchannel(" + text (pr channel) + ")" ) ;
+ line;
+.
+ load font table :
+ IF NOT exists (fonttab name)
+ THEN REP line (2);
+ putline ("Bitte Archiv mit der Fonttabelle """ +
+ fonttab name + """ einlegen!");
+ line;
+ UNTIL yes ("Archiv eingelegt") PER;
+ reserve archive;
+ fetch (fonttab name, archive);
+ release (archive);
+ FI;
+ font table (fonttab name);
+ IF multi user
+ THEN command dialogue (FALSE);
+ do ("save(""" + font tab name + """,task(""configurator""))")
+ FI;
+ forget (fonttab name, quiet);
+
+ . reserve archive :
+ INT VAR p1, p2;
+ archive (" "31" ");
+ disable stop;
+ list (archive);
+ IF is error
+ THEN buffer := errormessage;
+ p1 := pos (buffer, """", 1 ) + 1;
+ p2 := pos (buffer, """", p1) - 1;
+ IF p1 > 0 AND p2 > 0
+ THEN clear error;
+ buffer := subtext (buffer, p1, p2);
+ archive (buffer);
+ FI;
+ FI;
+ enable stop;
+
+. generate printer spool :
+ eumel must advertise;
+ cursor (1, 12);
+ putline ("In allen bestehenden Tasks - insbesondere in der Task ""PUBLIC"" - muß");
+ putline ("die Fonttabelle mit dem Kommando");
+ line;
+ putline (" font table (""" + font tab name + """)");
+ line;
+ putline ("eingestellt werden!!!");
+ line (4);
+ putline ("Generierung beendet, weiter mit 'SV'");
+ generate printer server;
+ do (buffer);
+
+. generate printer server :
+ buffer := "break (quiet);";
+ buffer CAT "spool manager (PROC printer);";
+ buffer CAT "INT VAR reply; DATASPACE VAR ds; FILE VAR file;";
+ buffer CAT "PROC printer:";
+ buffer CAT " disable stop;";
+ buffer CAT " continue (server channel);";
+ buffer CAT " check error (error message);";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " REP forget (ds);";
+ buffer CAT " execute print;";
+ buffer CAT " IF is error AND online THEN put error; clear error; FI;";
+ buffer CAT " PER;";
+ buffer CAT "END PROC printer;";
+ buffer CAT "PROC execute print:";
+ buffer CAT " LET ack = 0, fetch code = 11, file type = 1003;";
+ buffer CAT " enable stop;";
+ buffer CAT " ds := nilspace;";
+ buffer CAT " call (father, fetch code, ds, reply);";
+ buffer CAT " IF reply = ack CAND type (ds) = file type";
+ buffer CAT " THEN file := sequential file (input, ds);";
+ buffer CAT " print (file,";
+ buffer CAT " PROC (INT CONST, INT VAR, INT VAR) open,";
+ buffer CAT " PROC (INT CONST, INT CONST) close,";
+ buffer CAT " PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC execute print;";
+ buffer CAT "PROC check error(TEXT CONST message):";
+ buffer CAT " IF is error";
+ buffer CAT " THEN clear error; rename myself (message);";
+ buffer CAT " IF is error THEN end(myself) FI;";
+ buffer CAT " pause (9000); end(myself);";
+ buffer CAT " FI;";
+ buffer CAT "END PROC check error;";
+
diff --git a/system/setup/3.1/source-disk b/system/setup/3.1/source-disk
new file mode 100644
index 0000000..1421205
--- /dev/null
+++ b/system/setup/3.1/source-disk
@@ -0,0 +1 @@
+setup/setup-src-3.1_shard-4.9_1989-04-18.img
diff --git a/system/setup/3.1/src/AT-4.x b/system/setup/3.1/src/AT-4.x
new file mode 100644
index 0000000..86962e3
--- /dev/null
+++ b/system/setup/3.1/src/AT-4.x
Binary files differ
diff --git a/system/setup/3.1/src/SHARD b/system/setup/3.1/src/SHARD
new file mode 100644
index 0000000..c1619b3
--- /dev/null
+++ b/system/setup/3.1/src/SHARD
Binary files differ
diff --git a/system/setup/3.1/src/SHard Basis b/system/setup/3.1/src/SHard Basis
new file mode 100644
index 0000000..60800a1
--- /dev/null
+++ b/system/setup/3.1/src/SHard Basis
Binary files differ
diff --git a/system/setup/3.1/src/bootblock b/system/setup/3.1/src/bootblock
new file mode 100644
index 0000000..00b56a2
--- /dev/null
+++ b/system/setup/3.1/src/bootblock
Binary files differ
diff --git a/system/setup/3.1/src/configuration b/system/setup/3.1/src/configuration
new file mode 100644
index 0000000..139597f
--- /dev/null
+++ b/system/setup/3.1/src/configuration
@@ -0,0 +1,2 @@
+
+
diff --git a/system/setup/3.1/src/neu b/system/setup/3.1/src/neu
new file mode 100644
index 0000000..a89779c
--- /dev/null
+++ b/system/setup/3.1/src/neu
@@ -0,0 +1,34 @@
+TEXT VAR t1 :: "SHardmodul Floppy", t2 :: "FLOPPY.EXE";
+reserve ("ds", /"DOS");
+IF yes("init",FALSE)
+ THEN init modules list;
+FI;
+THESAURUS VAR th1 :: all modules, th2 :: empty thesaurus;
+WHILE yes ("noch Module holen", TRUE) REP
+t2 := ONE /"DOS";
+t1 := ONE (th1);
+editget (t1); line;
+forget (t1);
+fetch (t2, /"DOS");
+copy (t2, t1); last param (t1);
+th2 := th2 + t1
+PER;
+WHILE yes ("jetzt noch andere holen", FALSE) REP
+ t2 := ONE /"DOS";
+ t1 := ONE all;
+editget (t1); line;
+forget (t1);
+fetch (t2, /"DOS");
+copy (t2, t1); last param (t1);
+PER;
+release (/"DOS");
+
+linkshard module (th2);
+
+
+
+
+
+
+
+
diff --git a/system/setup/3.1/src/setup eumel -1: mini eumel dummies b/system/setup/3.1/src/setup eumel -1: mini eumel dummies
new file mode 100644
index 0000000..a1fa2b5
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel -1: mini eumel dummies
@@ -0,0 +1,28 @@
+
+PACKET setup eumel mini eumel dummies (* Stand : 08.04.88 *)
+DEFINES FILE,
+ sequentialfile,
+ output,
+ putline,
+ :=,
+ run :
+
+TYPE FILE = INT;
+
+INT CONST output :: 0;
+
+OP := (FILE VAR a, FILE CONST b):
+
+END OP :=;
+FILE PROC sequentialfile (INT CONST a, TEXT CONST b) :
+ FILE : (0).
+END PROC sequentialfile;
+
+PROC putline (FILE CONST a, TEXT CONST b):
+END PROC putline;
+
+PROC run (TEXT CONST a):
+END PROC run;
+
+END PACKET setup eumel mini eumel dummies;
+
diff --git a/system/setup/3.1/src/setup eumel 0: -M b/system/setup/3.1/src/setup eumel 0: -M
new file mode 100644
index 0000000..bad5028
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 0: -M
@@ -0,0 +1,32 @@
+PACKET setup eumel multiuserspecials (* Copyright (C) 1985, 1988 *)
+DEFINES terminal setup, (* Martin Schönbeck, Spenge *)
+ indirect list, (* Lutz Prechelt, Karlsruhe *)
+ setup testing : (* Stand: 07.05.88 2.1 *)
+
+LET sysout file = "sysout";
+
+BOOL VAR setup test version :: FALSE;
+
+PROC terminal setup:
+ (* It took about 2 manmonths to debug this procedure ! *)
+END PROC terminal setup;
+
+PROC indirect list (BOOL CONST make indirection) :
+ IF make indirection
+ THEN sysout (sysout file);
+ ELSE sysout ("");
+ print (sysout file);
+ forget (sysout file, quiet)
+ FI.
+END PROC indirect list;
+
+PROC setup testing (BOOL CONST new ):
+ setup test version := new;
+END PROC setup testing;
+
+BOOL PROC setup testing :
+ setup test version.
+END PROC setup testing;
+
+END PACKET setup eumel multiuserspecials;
+
diff --git a/system/setup/3.1/src/setup eumel 0: -S b/system/setup/3.1/src/setup eumel 0: -S
new file mode 100644
index 0000000..50a8330
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 0: -S
@@ -0,0 +1,35 @@
+PACKET setup eumel singleuserspecials (* Copyright (C) 1985, 1988 *)
+DEFINES terminal setup, (* Martin Schönbeck, Spenge *)
+ break, (* Lutz Prechelt, Karlsruhe *)
+ indirect list, (* Stand: 07.05.88 2.1 *)
+ setup testing :
+
+LET printer channel = 15,
+ screen channel = 1;
+
+
+PROC break (QUIET CONST quiet):
+END PROC break;
+
+PROC terminal setup:
+ setup
+END PROC terminal setup;
+
+PROC indirect list (BOOL CONST make indirection) :
+ (* Man beachte, daß es nicht besonders sinnvoll ist, auf einem Drucker
+ cout zu machen...
+ *)
+ IF make indirection
+ THEN continue (printer channel)
+ ELSE continue (screen channel) FI.
+END PROC indirect list;
+
+PROC setup testing (BOOL CONST new):
+END PROC setup testing;
+
+BOOL PROC setup testing :
+ FALSE.
+END PROC setup testing;
+
+END PACKET setup eumel singleuserspecials;
+
diff --git a/system/setup/3.1/src/setup eumel 1: basisoperationen b/system/setup/3.1/src/setup eumel 1: basisoperationen
new file mode 100644
index 0000000..a705ff4
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 1: basisoperationen
@@ -0,0 +1,1071 @@
+
+(**************************************************************************)
+(***** Grundoperationen für den Setup-Eumel (Modul-SHard) *****************)
+(***** Copyright (c) 1985 - 1988 by *****************)
+(***** Martin Schönbeck, Spenge / Lutz Prechelt, Karlsruhe ****************)
+(**************************************************************************)
+
+(* Fünf Pakete :
+ 1. setup eumel basisoperationen
+ Handhabung von 16-Bit unsigned Werten in INTs und Editierfunktionen
+ 2. splitting
+ Worttrennung von REALs und Bytetrennung von INTs
+ 3. basic block io
+ blockin und blockout auf Datenräume mit retrys und Fehlermeldungen
+ 4. write file
+ Direktes Schreiben/Lesen eines Datenraums in/aus eine(r) Partition
+ 5. thesaurus utilities
+ ONE,CERTAIN,certain zum Aussuchen aus Thesauri ohne Editor
+*)
+
+
+PACKET setup eumel basisoperationen (* (C) 1987 Lutz Prechelt, Karlsruhe *)
+DEFINES editget, editgetchar, (* Stand: 08.04.88 Version 1.1 *)
+ yes, no, (* Eumel 1.8.0 *)
+ direction, reset direction,
+ data error, write head,
+ LIST, list, CAT, emptylist,
+ (*UNSIGNED,*) unsigned, int, text,
+ RANGE, range, everywhere,
+ ANDXOR, andxor,
+ dec, hex, bin,
+ IN,
+ := ,
+ put :
+
+(* Dieses Paket stellt die Basisfunktionen für den Elanteil des Setup-SHard
+ zur Verfügung.
+ Es ist dies im Wesentlichen die Handhabung von INT-Werten auch in Binär-
+ und Hexdarstellung, sowie die Plausibilitätsprüfung mit Fehleranzeigen.
+*)
+
+TYPE LIST = TEXT, (* TEXT aus mehreren UNSIGNEDen (replace/ISUB) *)
+ RANGE = STRUCT (UNSIGNED low, high),
+ ANDXOR = STRUCT (UNSIGNED and mask, xor mask);
+
+LET UNSIGNED = INT; (* 16 bit *)
+
+TYPE REPRESENTATION = INT;
+
+REPRESENTATION CONST dec :: REPRESENTATION : (10),
+ hex :: REPRESENTATION : (16),
+ bin :: REPRESENTATION : (2);
+
+(* Diese Typen dienen zur Wertprüfung bei der Eingabe. *)
+
+LET up = ""3"",
+ down = ""10"",
+ right = ""2"",
+ error = ""0""; (* fuer current direction *)
+
+TEXT VAR current direction :: ""; (* enthaelt up oder down oder "" *)
+BOOL VAR direction valid :: FALSE;
+
+TEXT CONST hex digits :: "0123456789abcdef";
+
+(********************* Zuweisungen *************************************)
+
+OP := (LIST VAR a, LIST CONST b) :
+ CONCR (a) := CONCR (b)
+END OP := ;
+
+OP := (RANGE VAR a, RANGE CONST b) :
+ a.low := b.low;
+ a.high := b.high
+END OP := ;
+
+OP := (ANDXOR VAR a, ANDXOR CONST b) :
+ a.and mask := b.and mask;
+ a.xor mask := b.xor mask
+END OP := ;
+
+OP := (REPRESENTATION VAR a, REPRESENTATION CONST b) :
+ CONCR (a) := CONCR (b)
+END OP := ;
+
+(************************** IN ******************************************)
+
+BOOL OP IN (UNSIGNED CONST a, LIST CONST l) :
+ INT CONST p :: pos (CONCR (l), textform (a));
+ p > 0 AND p MOD 2 = 1 (* enthalten und word-aligned *)
+END OP IN;
+
+BOOL OP IN (UNSIGNED CONST a, RANGE CONST b) :
+ (* RANGES sind inklusiv ihrer Grenzen *)
+ reverse (textform (a)) <= reverse (textform (b.high)) AND
+ reverse (textform (a)) >= reverse (textform (b.low))
+END OP IN;
+
+BOOL OP IN (UNSIGNED CONST a, ANDXOR CONST mask) :
+ (* Es muss (Bitweise) (a AND andmask) XOR xormask = 0 sein *)
+ ((a AND mask.and mask) XOR mask.xor mask) = 0
+END OP IN;
+
+(************************* Konstruktoren ********************************)
+
+LIST CONST emptylist :: LIST : ("");
+
+LIST PROC list (TEXT CONST list text) :
+ (* Konstruiert aus einer in Textform gegebenen Liste von Unsigneds eine
+ LIST. Die einzelnen Werte sind durch Komma getrennt und dürfen in
+ dezimaler, sedezimaler oder binärer Darstellung notiert sein.
+ *)
+ TEXT VAR t :: compress (list text);
+ IF t = "" THEN emptylist
+ ELSE TEXT VAR result :: "";
+ REPEAT
+ INT VAR first comma pos :: pos (t, ",");
+ IF first comma pos = 0 THEN first comma pos := LENGTH t + 1 FI;
+ result CAT textform (unsigned (subtext (t, 1, first comma pos - 1)));
+ t := subtext (t, first comma pos + 1)
+ UNTIL t = "" PER;
+ LIST : (result)
+ FI
+END PROC list;
+
+(*UNSIGNED PROC unsigned (INT CONST sixteen bits) :
+ sixteen bits
+END PROC unsigned;*)
+
+UNSIGNED PROC unsigned (TEXT CONST number) :
+ INT VAR result :: 0, i;
+ TEXT VAR t :: compress (to lower (number)), type :: t SUB LENGTH t;
+ IF pos ("hb" + hex digits, type) = 0
+ THEN set conversion (FALSE);
+ LEAVE unsigned WITH 0
+ FI;
+ IF type = "h"
+ THEN convert hex
+ ELIF type = "b"
+ THEN convert binary
+ ELSE convert decimal FI;
+ result.
+
+convert hex :
+ FOR i FROM 1 UPTO LENGTH t - 1 REP
+ TEXT CONST c :: t SUB i;
+ IF pos (hex digits, c) = 0
+ THEN set conversion (FALSE);
+ LEAVE unsigned WITH 0
+ FI;
+ rotate (result, 4);
+ result INCR pos (hex digits, c) - 1
+ PER.
+
+convert binary :
+ FOR i FROM 1 UPTO LENGTH t - 1 REP
+ TEXT CONST bit :: t SUB i;
+ IF bit <> "0" AND bit <> "1"
+ THEN set conversion (FALSE);
+ LEAVE unsigned WITH 0
+ FI;
+ rotate (result, 1);
+ result INCR int (bit)
+ PER.
+
+convert decimal :
+ REAL VAR x :: real (t);
+ IF NOT last conversion ok THEN LEAVE unsigned WITH 0 FI;
+ IF x < 32768.0
+ THEN result := int (x)
+ ELSE result := int (x - 65536.0) FI.
+END PROC unsigned;
+
+RANGE CONST everywhere :: RANGE : (0, -1);
+
+RANGE PROC range (UNSIGNED CONST low, high) :
+ RANGE : (low, high)
+END PROC range;
+
+ANDXOR PROC andxor (UNSIGNED CONST and mask, xor mask) :
+ ANDXOR : (and mask, xor mask)
+ENDPROC andxor;
+
+
+(******* weitere Operationen für UNSIGNED, LIST, RANGE, ANDXOR **************)
+
+INT PROC int (UNSIGNED CONST a) :
+ (* falls jemand noch exotische Dinge damit tun will *)
+ a
+END PROC int;
+
+OP CAT (LIST VAR l, UNSIGNED CONST a) :
+ (* Liste nachtraeglich erweitern *)
+ CONCR (l) CAT textform (a)
+END OP CAT;
+
+(********************* editget(char), yes, no *****************************)
+
+PROC editget (INT CONST spalte, zeile, TEXT CONST prompt, INT VAR i) :
+ cursor (spalte, zeile);
+ editget (prompt, i)
+END PROC editget;
+
+PROC editget (INT CONST spalte, zeile, TEXT CONST prompt, UNSIGNED VAR a,
+ REPRESENTATION CONST r) :
+ cursor (spalte, zeile);
+ editget (prompt, a, r)
+END PROC editget;
+
+PROC editget (TEXT CONST prompt, INT VAR i) :
+ TEXT VAR t :: text (i);
+ test up or down (prompt, t);
+ IF current direction <> "" THEN LEAVE editget FI;
+ editget (t,7,7);
+ i := int (t);
+ IF NOT last conversion ok
+ THEN data error ("Eingabe unerlaubt als Zahl") FI
+END PROC editget;
+
+PROC editget (TEXT CONST prompt, UNSIGNED VAR a, REPRESENTATION CONST r) :
+ TEXT VAR t :: text (a, r);
+ test up or down (prompt, t);
+ IF current direction <> "" THEN LEAVE editget FI;
+ editget (t,18,18);
+ a := unsigned (t);
+ IF NOT last conversion ok
+ THEN data error ("Eingabe unerlaubt") FI
+END PROC editget;
+
+BOOL PROC yes (TEXT CONST frage, BOOL CONST std antwort) :
+ (* Achtung: hierdrin kann nicht die alte "yes" Prozedur benutzt werden, da
+ diese kein getchar benutzt.
+ Die alten yes/no werden unten durch Resultatlose ueberdeckt.
+ *)
+ LET allowed = "NnJj";
+ INT VAR x,y; get cursor (x,y);
+ IF NOT command dialogue THEN LEAVE yes WITH std antwort FI;
+ REP UNTIL getcharety = "" PER;
+ REP
+ cursor (x,y);
+ test up or down (frage + " ? (j/n)", standard antwort text);
+ IF current direction <> "" THEN LEAVE yes WITH std antwort FI;
+ TEXT VAR t;
+ getchar (t);
+ IF t = ""13""
+ THEN t := standard antwort text FI;
+ IF pos (allowed, t) = 0
+ THEN out (""7"") ELSE out (t); out (""13""10"") FI
+ UNTIL pos (allowed, t) <> 0 PER;
+ t = "j" OR t = "J".
+
+standard antwort text:
+ IF std antwort
+ THEN "j"
+ ELSE "n"
+ FI.
+END PROC yes;
+
+BOOL PROC yes (INT CONST spalte, zeile, TEXT CONST frage,
+ BOOL CONST std antwort) :
+ cursor (spalte, zeile);
+ yes (frage, std antwort).
+END PROC yes;
+
+PROC yes (TEXT CONST dummy): END PROC yes;
+
+PROC no (TEXT CONST dummy): END PROC no;
+
+PROC editgetchar (INT CONST spalte, zeile, TEXT CONST prompt, allowed,
+ UNSIGNED VAR a) :
+ cursor (spalte, zeile);
+ editgetchar (prompt, allowed, a)
+END PROC editgetchar;
+
+PROC editgetchar (TEXT CONST prompt, allowed, UNSIGNED VAR a) :
+ (* Bietet Zeichen an (nehmen mit RETURN), nimmt nur die in allowed.
+ obere 8 Bit der Vorbesetzung werden abgeschnitten.
+ *)
+ TEXT VAR t;
+ test up or down (prompt, perhaps a);
+ a := a MOD 256;
+ IF current direction <> "" THEN LEAVE editgetchar FI;
+ getchar (t);
+ IF t = ""13""
+ THEN (* Vorbesetzung behalten *)
+ out (right)
+ ELIF pos (allowed, t) <> 0
+ THEN a := code (t);
+ out (t)
+ ELSE out (t);
+ data error ("unzulässiges Zeichen")
+ FI.
+
+perhaps a:
+ IF a > 31 THEN code (a) ELSE "" FI.
+END PROC editgetchar;
+
+(********* data error, write head, (reset) direction *********************)
+
+PROC data error (TEXT CONST fehlermeldung) :
+ cursor (1, 24);
+ out (""7"Fehler : " + fehlermeldung + " (Bitte Taste) ");
+ REP UNTIL incharety (2) = "" PER; pause;
+ cursor (1, 24); out (""4"");
+ current direction := error
+END PROC data error;
+
+PROC write head (TEXT CONST headtext) :
+ TEXT CONST text :: subtext (headtext, 1, 77);
+ INT CONST luecke :: (79 - LENGTH text) DIV 2 - 1;
+ out (""1""4""15"");
+ luecke TIMESOUT " ";
+ out (text);
+ luecke TIMESOUT " ";
+ out (""14""13""10""10"").
+END PROC write head;
+
+TEXT PROC direction :
+ current direction
+END PROC direction;
+
+PROC reset direction (BOOL CONST manouvres possible) :
+ (* Hiermit kann die letzte Manövrierbewegung nach der Auswertung gelöscht
+ werden. Mit NOT manouvres possible wird der ganze Manövriermechanismus
+ außer Betrieb gesetzt.
+ *)
+ direction valid := manouvres possible;
+ current direction := ""
+END PROC reset direction;
+
+(*********************** put *******************************************)
+
+PROC put (INT CONST spalte, zeile, UNSIGNED CONST a, REPRESENTATION CONST r):
+ cursor (spalte, zeile);
+ put (a, r)
+END PROC put;
+
+PROC put (INT CONST spalte, zeile, LIST CONST l, REPRESENTATION CONST r):
+ cursor (spalte, zeile);
+ put (l, r)
+END PROC put;
+
+PROC put (INT CONST spalte, zeile, RANGE CONST a, REPRESENTATION CONST r):
+ cursor (spalte, zeile);
+ put (a, r)
+END PROC put;
+
+PROC put (UNSIGNED CONST a, REPRESENTATION CONST r) :
+ put (text (a, r))
+END PROC put;
+
+PROC put (LIST CONST a, REPRESENTATION CONST r) :
+ INT VAR i, l :: LENGTH CONCR (a) DIV 2;
+ write ("(");
+ FOR i FROM 1 UPTO l REP
+ put (text (CONCR (a) ISUB i, r));
+ IF i < l THEN put (",") FI
+ PER;
+ IF l > 0 THEN out (""8"") FI;
+ put (")")
+END PROC put;
+
+PROC put (RANGE CONST a, REPRESENTATION CONST r) :
+ write (text (a.low, r));
+ write ("...");
+ write (text (a.high, r))
+END PROC put;
+(*** ist put auf RANGE in dieser Weise sinnvoll ?
+ vielleicht lieber die Maske bitweise mit x, 1, 0 darstellen ?
+***)
+
+PROC put (BOOL CONST b):
+ IF b
+ THEN put ("Ja ");
+ ELSE put ("Nein");
+ FI
+END PROC put;
+
+
+(********************* interne Hilfsprozeduren ****************************)
+
+TEXT PROC text (UNSIGNED CONST a, REPRESENTATION CONST r) :
+ TEXT VAR result :: "";
+ INT VAR i;
+ set conversion (TRUE);
+ IF CONCR (r) = 10 THEN decimal form
+ ELIF CONCR (r) = 2 THEN binary form
+ ELSE hex form FI.
+
+decimal form :
+ IF bit (a, 15) (* dann kriegt man im Eumel negatives Vorzeichen *)
+ THEN result := text (real (text (a)) + 65536.0); (* Der Umweg ueber
+ Text ist noetig, wegen (1.8.0) real (-32767-1) --> stack overflow *)
+ subtext (result, 1, pos (result, ".") - 1) (* Dezimalpunkt weghauen *)
+ ELSE text (a) FI.
+
+binary form :
+ FOR i FROM 15 DOWNTO 0 REP
+ IF bit (a, i) THEN result CAT "1" ELSE result CAT "0" FI
+ PER;
+ result + "b".
+
+hex form :
+ INT VAR help :: a;
+ FOR i FROM 1 UPTO 4 REP
+ rotate (help, 4); (* oberste 4 bit zu untersten 4 machen *)
+ result CAT (hex digits SUB nibble + 1); (* oberste 4 bit darstellen *)
+ PER;
+ result + "h".
+
+nibble :
+ help MOD 16. (* unterste 4 bit *)
+END PROC text;
+
+TEXT PROC textform (UNSIGNED CONST a) :
+ (* speichert das INT in einen TEXT (mit ISUB lesbar) *)
+ TEXT VAR ta :: " ";
+ replace (ta, 1, a);
+ ta
+END PROC textform;
+
+TEXT PROC reverse (TEXT CONST a) :
+ (* Text umdrehen. Das braucht man, um die ISUBS direkt vergleichen zu
+ koennen.
+ *)
+ IF LENGTH a <= 1 THEN a
+ ELSE reverse (subtext (a, 2)) + (a SUB 1) FI
+END PROC reverse;
+
+PROC test up or down (TEXT CONST prompt, data) :
+ IF current direction <> "" AND NOT direction valid
+ THEN current direction := "";
+ LEAVE test up or down
+ FI;
+ out (prompt);
+ out (" "8""8""8""8""8""8""); (* nächste 6 Zeichen Löschen *)
+ out (data); LENGTH data TIMESOUT ""8"";
+ IF NOT direction valid THEN LEAVE test up or down FI;
+ getchar (current direction);
+ IF current direction = up OR current direction = down
+ THEN (* verschlucken, spaeter auswerten *)
+ ELSE push (current direction);
+ current direction := ""
+ FI
+END PROC test up or down;
+
+TEXT PROC to lower (TEXT CONST text) :
+ TEXT VAR t :: text;
+ INT VAR i;
+ FOR i FROM 1 UPTO LENGTH t REP
+ IF (t SUB i) >= ""65"" AND (t SUB i) <= ""90""
+ THEN replace (t, i, code (code (t SUB i) + 32)) FI
+ PER;
+ t
+END PROC to lower;
+
+END PACKET setup eumel basisoperationen;
+
+
+
+PACKET splitting DEFINES low byte, (* Copyright (C) 1985 *)
+ high byte, (* Martin Schönbeck, Spenge *)
+ low word, (* Stand: 13.09.85 *)
+ high word:
+
+INT PROC high byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 2)
+
+END PROC high byte;
+
+INT PROC low byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 1)
+
+END PROC low byte;
+
+INT PROC high word (REAL CONST double precission int):
+
+ int (double precission int / 65536.0)
+
+END PROC high word;
+
+INT PROC low word (REAL CONST double precission int):
+
+ string of low bytes ISUB 1.
+
+string of low bytes:
+ code (int (double precission int MOD 256.0)) +
+ code (int ((double precission int MOD 65536.0) / 256.0)).
+
+END PROC low word;
+
+END PACKET splitting;
+
+
+
+PACKET basic block io DEFINES
+ verify track,
+ read block,
+ write block:
+
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, 0, block no, return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, 0, block no, return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, high word (block no) OR -512,
+ low word (block no), return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, high word (block no) OR -512,
+ low word (block no), return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+PROC verify track (DATASPACE VAR ds, INT CONST ds page no,
+ REAL CONST startblock no, INT VAR return code):
+ block in (ds, ds page no, high word (startblock no) OR -256,
+ low word (startblock no), return code);
+END PROC verify track;
+
+END PACKET basic block io;
+
+
+
+PACKET write file DEFINES write file, (* Copyright (C) 1985, 1987 *)
+ read file : (* Martin Schönbeck, Spenge *)
+ (* Lutz Prechelt, Karlsruhe *)
+ (* Stand: 07.06.87 *)
+
+PROC write file (TEXT CONST file name, REAL CONST start block,
+ INT CONST number of blocks):
+
+ INT VAR count;
+ disable stop;
+ DATASPACE VAR ds := old (file name);
+ FOR count FROM 0 UPTO (number of blocks - 1) REP
+ write block (ds, count + 3, start block + real (count))
+ UNTIL is error PER;
+ forget (ds).
+
+END PROC write file;
+
+PROC write file (TEXT CONST file name, REAL CONST start block,
+ INT CONST number of blocks, write channel):
+
+ enable stop;
+ INT VAR old channel := channel;
+ IF old channel <> write channel THEN continue (write channel) FI;
+ disable stop;
+ write file (file name, start block, number of blocks);
+ IF old channel <> write channel
+ THEN break (quiet);
+ continue (old channel)
+ FI.
+END PROC write file;
+
+PROC read file (DATASPACE VAR file, REAL CONST start block,
+ INT CONST number of blocks):
+ INT VAR count;
+ disable stop;
+ forget (file); file := nilspace;
+ FOR count FROM 0 UPTO (number of blocks - 1) REP
+ read block (file, count + 3, start block + real (count))
+ UNTIL is error PER.
+END PROC read file;
+
+PROC read file (DATASPACE VAR file, REAL CONST start block,
+ INT CONST number of blocks, read channel):
+ enable stop;
+ INT VAR old channel := channel;
+ IF old channel <> read channel THEN continue (read channel) FI;
+ disable stop;
+ read file (file, start block, number of blocks);
+ IF old channel <> channel
+ THEN break (quiet);
+ continue (old channel)
+ FI.
+END PROC read file;
+
+END PACKET write file;
+
+PACKET thesaurus utilities
+DEFINES ONE, certain : (* Stand: 21.03.88 *)
+ (* Korr : Lutz Prechelt *)
+LET max entries = 200;
+
+LET oben unten rubout return = ""3""10""12""13"";
+
+INT VAR anzahl,
+ firstline, size, (* erste Bildschirmz./Anz. Zeilen für Vorgang *)
+ realc, virtc; (* akt. Zeile in Fenster/Eintragsnummer *)
+
+TEXT VAR string;
+
+THESAURUS PROC certain (THESAURUS CONST in, pre) :
+ einzelne (in, pre, TRUE).
+END PROC certain;
+
+TEXT OP ONE (THESAURUS CONST t):
+ name (einzelne (t, empty thesaurus, FALSE),1)
+END OP ONE;
+
+THESAURUS PROC einzelne (THESAURUS CONST thes, preselections,
+ BOOL CONST viele):
+ (* Benutzt nur den Rest des Bildschirms ab der aktuellen Zeile nach unten.
+ Die in preselections enthaltenen Namen aus t sind bereits zu Beginn
+ angekreuzt.
+ Ein Aufruf mit NOT viele und preselections/t <> empty thesaurus ist
+ nicht sinnvoll.
+ Die Cursorposition nach Verlassen ist wieder in der "aktuellen" Zeile
+ auf Position 1, so daß mit out (""4"") der Kram selektiv gelöscht
+ werden kann.
+ *)
+ ROW maxentries TEXT VAR eintrag;
+ THESAURUS VAR ausgabe :: empty thesaurus,
+ t :: empty thesaurus + thes; (* Leereinträge entfernen! *)
+ INT VAR i;
+ initialisiere ankreuzen;
+ IF anzahl = 0 THEN LEAVE einzelne WITH empty thesaurus FI;
+ bildschirm vorbereiten;
+ bild (1, eintrag);
+ virtc := 1;
+ realc := 1;
+ realcursor setzen;
+ kreuze an (viele, eintrag);
+ ausgabe erzeugen;
+ cursor (1, firstline - 2); out (""4"");
+ ausgabe.
+
+initialisiere ankreuzen:
+ anzahl := highest entry (t);
+ string := "";
+ (* t enthält keine Leereinträge mehr ! *)
+ FOR i FROM 1 UPTO anzahl REP
+ eintrag [i] := name (t,i)
+ PER;
+ FOR i FROM 1 UPTO highest entry (preselections) REP
+ INT CONST preselection link :: link (t, name (preselections, i));
+ IF preselection link > 0
+ THEN string CAT textstr (preselection link) FI
+ PER.
+
+bildschirm vorbereiten:
+ get cursor (i, firstline);
+ out (""13""4""); (* Restbildschirm löschen *)
+ IF viele
+ THEN putline ("Wählen <CR> Löschen <RUBOUT> " +
+ "alle Löschen <HOP><RUBOUT> Beenden <ESC>q")
+ ELSE putline ("Auswählen <CR>") FI;
+ putline ("Marke bewegen <RUNTER> <RAUF> <HOP><RUNTER> <HOP><RAUF>");
+ firstline INCR 2;
+ size := 24 - firstline + 1.
+
+ausgabe erzeugen:
+ WHILE string <> "" REP
+ insert (ausgabe, eintrag [string ISUB 1]);
+ string := subtext (string, 3);
+ PER
+END PROC einzelne;
+
+PROC realcursor setzen:
+ TEXT CONST mark :: marke (virtc, TRUE);
+ cursor (1, firstline + realc - 1);
+ out (mark + LENGTH mark * ""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 " "
+ FI
+END PROC marke;
+
+PROC bild (INT CONST anfang, ROW maxentries TEXT CONST eintrag):
+ cursor (1, firstline);
+ out (""4""3""); (* Restschirm löschen, 1 Zeile rauf *)
+ INT VAR i;
+ FOR i FROM anfang UPTO grenze REP
+ out (""13""10"");
+ out (marke (i, FALSE));
+ out (eintrag [i])
+ PER.
+
+grenze:
+ min (anzahl, anfang + size - 1)
+END PROC bild;
+
+PROC kreuze an (BOOL CONST viele, ROW maxentries TEXT CONST eintrag) :
+ REP zeichen lesen;
+ zeichen interpretieren
+ PER.
+
+zeichen lesen:
+ TEXT VAR zeichen;
+ inchar (zeichen, ""1""27""3""10""13"1Xx+"11""12"Oo0-").
+
+zeichen interpretieren:
+ SELECT code (zeichen) OF
+ CASE 1 (* hop *) : hoppen (eintrag)
+ CASE 27 (* ESC *) : IF incharety (600) = "q" THEN LEAVE kreuze an FI
+ CASE 3 (* rauf *) : nach oben (eintrag)
+ CASE 10 (* runter *) : nach unten (eintrag)
+ CASE 13 (* Return *) : ankreuzen (eintrag, TRUE); evtl aufhoeren
+ CASE 49,(* 1 *)
+ 88,(* X *)
+ 120,(* x *)
+ 43,(* + *)
+ 11 (* Rubin *) : ankreuzen (eintrag, FALSE); evtl aufhoeren
+ CASE 12,(* Rubout *)
+ 79,(* O *)
+ 111,(* o *)
+ 48,(* 0 *)
+ 45 (* - *) : auskreuzen (eintrag)
+ END SELECT.
+
+evtl aufhoeren:
+ IF NOT viele THEN LEAVE kreuze an FI.
+
+END PROC kreuze an;
+
+PROC hoppen (ROW maxentries TEXT CONST eintrag) :
+ zweites zeichen lesen;
+ zeichen interpretieren.
+
+zweites zeichen lesen:
+ TEXT VAR zz;
+ inchar (zz).
+
+zeichen interpretieren:
+ SELECT pos (oben unten rubout return, zz) OF
+ CASE 1 : hop nach oben
+ CASE 2 : hop nach unten
+ CASE 3 : alles loeschen
+ CASE 4 : rest ankreuzen
+ OTHERWISE out (""7"")
+ END SELECT.
+
+rest ankreuzen:
+ INT VAR i;
+ FOR i FROM 1 UPTO anzahl REP (* alles *)
+ IF nr (i) = 0 (* was noch nicht angekreuzt ist *)
+ THEN string CAT textstr (i) (* ankreuzen *)
+ FI
+ PER;
+ bild aktualisieren.
+
+alles loeschen:
+ string := "";
+ bild aktualisieren.
+
+hop nach oben:
+ IF ganz oben
+ THEN out (""7"")
+ ELIF oben im fenster
+ THEN raufblaettern
+ ELSE top of page
+ FI.
+
+ganz oben:
+ virtc = 1.
+
+oben im fenster:
+ realc = 1.
+
+raufblaettern:
+ virtc DECR size;
+ virtc := max (virtc, 1);
+ bild (virtc, eintrag);
+ 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 im fenster
+ THEN runterblaettern
+ ELSE bottom of page
+ FI.
+
+ganz unten:
+ virtc = anzahl.
+
+unten im fenster:
+ firstline + realc > 24.
+
+runterblaettern:
+ INT VAR alter virtc :: virtc;
+ virtc INCR size;
+ virtc := min (virtc, anzahl);
+ realc := virtc - alter virtc;
+ bild (alter virtc + 1, eintrag);
+ realcursor setzen.
+
+bottom of page:
+ loesche marke;
+ alter virtc := virtc;
+ virtc INCR (size - realc);
+ virtc := min (anzahl, virtc);
+ realc INCR (virtc - alter virtc);
+ realcursor setzen
+END PROC hoppen;
+
+PROC ankreuzen (ROW maxentries TEXT CONST eintrag, BOOL CONST ggf auskreuzen):
+ (* bei ggf auskreuzen wird der Eintrag, falls er schon angekreuzt ist,
+ ausgekreuzt, andernfalls normal angekreuzt.
+ *)
+ INT VAR pl :: nr (virtc);
+ IF pl <> 0
+ THEN schon angekreuzt
+ FI;
+ string CAT textstr (virtc);
+ IF virtc < anzahl THEN nach unten (eintrag) ELSE realcursor setzen FI.
+
+schon angekreuzt :
+ IF ggf auskreuzen THEN auskreuzen (eintrag) ELSE out (""7"") FI;
+ LEAVE ankreuzen.
+END PROC ankreuzen;
+
+PROC auskreuzen (ROW maxentries TEXT CONST eintrag) :
+ INT VAR posi :: nr (virtc);
+ IF posi = 0
+ THEN out (""7""); LEAVE auskreuzen
+ FI;
+ rausschmeissen;
+ loesche marke;
+ bild aktualisieren;
+ IF virtc < anzahl THEN nach unten (eintrag) FI.
+
+rausschmeissen:
+ string := subtext (string,1, 2*posi-2) + subtext (string,2*posi+1)
+END PROC auskreuzen;
+
+PROC bild aktualisieren:
+ INT VAR ob, un, i;
+ ob := virtc - realc + 1;
+ un := min (ob + size - 1, anzahl);
+ cursor (1, firstline - 1);
+ FOR i FROM ob UPTO un REP
+ out (""13""10""); out (marke (i, FALSE))
+ PER;
+ realcursor setzen.
+END PROC bild aktualisieren;
+
+PROC nach oben (ROW maxentries TEXT CONST eintrag) :
+ IF noch nicht oben (* virtuell *)
+ THEN gehe nach oben
+ ELSE out (""7"")
+ FI;
+ realcursor setzen.
+
+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, eintrag).
+
+cursor up:
+ loesche marke;
+ virtc DECR 1;
+ realc DECR 1.
+END PROC nach oben;
+
+PROC nach unten (ROW maxentries TEXT CONST eintrag) :
+ IF noch nicht unten (* virtuell *)
+ THEN gehe nach unten
+ ELSE out (""7"")
+ FI.
+
+noch nicht unten:
+ virtc < anzahl.
+
+gehe nach unten:
+ IF realc > size - 1
+ THEN scroll up
+ ELSE cursor down
+ FI.
+
+scroll up:
+ virtc INCR 1;
+ bild (virtc - size + 1, eintrag);
+ realcursor setzen.
+
+cursor down:
+ loesche marke;
+ virtc INCR 1;
+ realc INCR 1;
+ realcursor setzen
+END PROC nach unten;
+
+PROC loesche marke:
+ out (marke (virtc, FALSE))
+END PROC loesche marke;
+
+TEXT PROC textstr (INT CONST nr):
+ TEXT VAR help :: " ";
+ replace (help, 1, nr);
+ help.
+END PROC textstr;
+
+INT PROC nr (INT CONST zeiger):
+ IF pos (string, textstr (zeiger)) = 0 (* haut hin, da zeiger < 255 *)
+ THEN 0
+ ELSE (pos (string,textstr (zeiger)) DIV 2) + 1
+ FI
+END PROC nr;
+
+PROC inchar (TEXT VAR t, TEXT CONST allowed) :
+ REP
+ getchar (t);
+ IF pos (allowed, t) = 0 THEN out (""7"") FI
+ UNTIL pos (allowed, t) > 0 PER.
+END PROC inchar;
+
+END PACKET thesaurus utilities;
+
diff --git a/system/setup/3.1/src/setup eumel 2: modulzugriffe b/system/setup/3.1/src/setup eumel 2: modulzugriffe
new file mode 100644
index 0000000..42163f4
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 2: modulzugriffe
@@ -0,0 +1,441 @@
+
+(* Pakete:
+ 1. setup eumel modulzugriffe
+ Abstrakter Datentyp MODUL : Typ, Datenraumtyp, Zugriffsoperationen
+ 2. setup eumel modul und shard zugriffe
+ Zugriffe in Module und SHards (Datentyp MODUL) mit Strukturwissen
+*)
+
+(**************************************************************************)
+(***** Datentyp MODUL und Zugriffsoperationen dafür ****************)
+(***** Copyright (c) 1987, 1988 by ****************)
+(***** Lutz Prechelt, Karlsruhe ****************)
+(**************************************************************************)
+
+PACKET setup eumel modulzugriffe (* Copyright (c) 1987 by *)
+DEFINES int, byte, text, unsigned, (* Lutz Prechelt, Karlsruhe *)
+ dtcb abfragen, ccb abfragen, (* Stand : 12.03.88 1.1 *)
+ dtcb refinements, ccb refinements, (* Eumel 1.8.1 *)
+ info,
+ page,
+ copy,
+ datenraumtyp modul,
+ MODUL :
+
+
+(* Dies Paket realisiert gezielte Zugriffe in einen Struct vom Typ MODUL.
+ Dies ist das Format eines SHard Moduls. Der Typ wird auch verwendet, um
+ das SHard-Hauptmodul oder einzelne ccbs zu handhaben!
+ Für die Adressierung der Bytes werden REAL-Werte verwendet, damit die
+ Größe nicht auf maxint beschränkt ist. Dies ist normalerweise sicher
+ (wegen der BCD-Arithmetik des Eumel), jedoch sind sinnlose nichtganzzahlige
+ Adressen dadurch möglich. Das wird aus Effizienzgründen nicht abgefangen,
+ die korrekte Benutzung liegt in der Verantwortung des Aufrufers.
+ Es sollen alle Zugriffe auf Module nur mit den Prozeduren dieses Pakets
+ abgewickelt werden.
+*)
+
+
+INT CONST high only ::-256,
+ low only :: 255;
+
+LET max page = 128;
+
+TYPE MODUL = STRUCT (ALIGN dummy, ROW 256 INT header,
+ ROW max page ROW 256 INT b,
+ INT dtcb abfragen, ccb abfragen,
+ TEXT dtcb ref, ccb ref, info);
+
+(* Der Typ kann wegen des ALIGN direkt auf einen Datenraum (für ein Modul)
+ gelegt werden. Der Teil b fasst 64kB Daten und kann direkt für blockout
+ verwendet werden. Die restlichen Teile sind nur für Module relevant.
+*)
+
+INT CONST datenraumtyp modul :: 5687; (* Typ eines MODUL als Datenraum *)
+
+(*********************** INT ********************************************)
+
+INT PROC int (MODUL CONST m, REAL CONST byte nr) :
+ (* liefert das INT aus dem Modul m, das bei Byte "byte nr" beginnt *)
+ INT VAR page :: int (byte nr DIV 512.0) + 1,
+ nr :: int (byte nr MOD 512.0) DIV 2 + 1;
+ INT VAR whole int :: m.b[page][nr];
+ IF byte nr MOD 2.0 <> 0.0
+ THEN rotate (whole int, 8); (* high und low byte vertauschen *)
+ (whole int AND low only) + next byte in high
+ ELSE whole int FI.
+
+next byte in high :
+ IF nr = 256 THEN nr := 1; page INCR 1 ELSE nr INCR 1 FI;
+ INT VAR help :: m.b[page][nr] AND low only;
+ rotate (help, 8);
+ help.
+END PROC int;
+
+INT PROC int (MODUL CONST m, INT CONST byte nr) :
+ int (m, real (byte nr))
+END PROC int;
+
+PROC int (MODUL VAR m, REAL CONST byte nr, INT CONST new) :
+ (* schreibt den neuen 16-Bit Wert new ab dem Byte "byte nr" in den Teil b
+ des Moduls m. Hier kommt es nicht sehr aufs Tempo an, deshalb benutzen
+ wir hier einfach "byte".
+ *)
+ INT VAR value :: new;
+ rotate (value, 8); (* high byte zu low byte machen *)
+ byte (m, byte nr, new AND low only);
+ byte (m, byte nr + 1.0, value AND low only);
+END PROC int;
+
+PROC int (MODUL VAR m, INT CONST byte nr, INT CONST new) :
+ int (m, real (byte nr), new)
+END PROC int;
+
+(************************** BYTE *******************************************)
+
+INT PROC byte (MODUL CONST m, REAL CONST byte nr) :
+ (* liefert das Byte mit der Nummer "byte nr" aus dem Teil b des Moduls m.
+ Das erste Byte hat die Nummer 0
+ *)
+ INT CONST page :: int (byte nr DIV 512.0) + 1,
+ nr :: int (byte nr MOD 512.0) DIV 2 + 1;
+ INT VAR whole int :: m.b[page][nr];
+ IF byte nr MOD 2.0 <> 0.0
+ THEN rotate (whole int, 8); (* high und low byte vertauschen *) FI;
+ whole int AND low only.
+END PROC byte;
+
+INT PROC byte (MODUL CONST m, INT CONST byte nr) :
+ byte (m, real (byte nr))
+END PROC byte;
+
+PROC byte (MODUL VAR m, REAL CONST byte nr, INT CONST new) :
+ (* Schreibt die unteren 8 bit von new an das Byte der Stelle byte nr im
+ Modul m
+ *)
+ INT CONST page :: int (byte nr DIV 512.0) + 1,
+ nr :: int (byte nr MOD 512.0) DIV 2 + 1;
+ INT VAR new byte :: new AND low only,
+ whole int :: m.b[page][nr];
+ m.b[page][nr] := new int.
+
+new int :
+ IF byte nr MOD 2.0 = 0.0 (* low byte ändern ? *)
+ THEN (whole int AND high only) + new byte
+ ELSE rotate (new byte, 8); (* new nach high rotieren *)
+ new byte + (whole int AND low only)
+ FI.
+END PROC byte;
+
+PROC byte (MODUL VAR m, INT CONST byte nr, INT CONST new) :
+ byte (m, real (byte nr), new)
+END PROC byte;
+
+(*********************** TEXT ********************************************)
+
+TEXT PROC text (MODUL CONST m, REAL CONST first byte nr, INT CONST length) :
+ (* Extrahiert die naechsten length bytes aus m ab byte nr als TEXT *)
+ REAL VAR i :: first byte nr;
+ TEXT VAR result :: "";
+ WHILE i < first byte nr + real (length) REP
+ result CAT code (byte (m, i));
+ i INCR 1.0
+ PER;
+ result.
+END PROC text;
+
+TEXT PROC text (MODUL CONST m, INT CONST first byte nr, INT CONST length) :
+ text (m, real (first byte nr), length)
+END PROC text;
+
+(* Ein schreibendes Analogon zu "text" gibt es nicht. *)
+
+(*********************** unsigned *****************************************)
+
+REAL PROC unsigned (INT CONST sixteen bits) :
+ (* hiermit kann man die Vorzeichenprobleme umschiffen, die der Eumel bei
+ INTs über maxint macht.
+ Liefert das INT als 16-Bit unsigned Wert interpretiert im REAL-Format.
+ *)
+ real (text (sixteen bits, dec))
+END PROC unsigned;
+
+INT PROC unsigned (REAL CONST sixteen bit value) :
+ (* Umkehrung des obigen : REAL 0..65536 rein, passenden 16 bit unsigned
+ Wert raus
+ *)
+ TEXT CONST t :: text (sixteen bit value);
+ int (unsigned (value text)).
+
+value text :
+ IF pos (t, ".") <> 0
+ THEN subtext (t, 1, pos (t, ".") - 1)
+ ELSE t
+ FI.
+END PROC unsigned;
+
+(******************** dtcb, ccb, info **************************************)
+
+INT PROC dtcb abfragen (MODUL CONST m) :
+ m.dtcb abfragen
+END PROC dtcb abfragen;
+
+PROC dtcb abfragen (MODUL VAR m, INT CONST neu) :
+ m.dtcb abfragen := neu
+END PROC dtcb abfragen;
+
+TEXT PROC dtcb refinements (MODUL CONST m) :
+ m.dtcb ref
+END PROC dtcb refinements;
+
+PROC dtcb refinements (MODUL VAR m, TEXT CONST neu) :
+ m.dtcb ref := neu
+END PROC dtcb refinements;
+
+INT PROC ccb abfragen (MODUL CONST m) :
+ m.ccb abfragen
+END PROC ccb abfragen;
+
+PROC ccb abfragen (MODUL VAR m, INT CONST neu) :
+ m.ccb abfragen := neu
+END PROC ccb abfragen;
+
+TEXT PROC ccb refinements (MODUL CONST m) :
+ m.ccb ref
+END PROC ccb refinements;
+
+PROC ccb refinements (MODUL VAR m, TEXT CONST neu) :
+ m.ccb ref := neu
+END PROC ccb refinements;
+
+TEXT PROC info (MODUL CONST m) :
+ m.info
+END PROC info;
+
+PROC info (MODUL VAR m, TEXT CONST neu) :
+ m.info := neu
+END PROC info;
+
+(********************* page **********************************************)
+
+(* Die Prozedur page dient dazu, aus dem Datenbereich b eines MODULs
+ einzelne Seiten (512 Byte Blöcke) in Form eines ROW 256 INT anzusprechen
+ um damit blockin/blockout zu machen.
+ Die Seitennummern gehen von 1 bis max page
+*)
+
+ROW 256 INT PROC page (MODUL CONST m, INT CONST page nr) :
+ m.b[page nr]
+END PROC page;
+
+PROC page (MODUL VAR m, INT CONST page nr, ROW 256 INT CONST new page) :
+ m.b[page nr] := new page
+END PROC page;
+
+(*********************** copy ********************************************)
+
+PROC copy (MODUL CONST from, REAL CONST origin,
+ MODUL VAR to, REAL CONST destination, INT CONST length) :
+ (* Kopiert schnell eine Anzahl von Bytes aus einem Modul in ein anderes
+ die Optimierung klappt nur, wenn von einer geraden Adresse an eine
+ gerade Adresse kopiert wird oder von ungerade nach ungerade.
+ Macht cout.
+ *)
+ INT VAR i, interval :: cout interval;
+ REAL VAR offset :: 0.0;
+ IF length < 0 THEN errorstop ("copy : length = " + text (length)) FI;
+ IF origin MOD 2.0 <> destination MOD 2.0
+ THEN copy slow
+ ELSE copy fast FI;
+ cout (length).
+
+cout interval :
+ IF length > 1024 THEN 32
+ ELIF length > 64 THEN 8
+ ELSE 1 FI.
+
+copy slow :
+ FOR i FROM 1 UPTO length REP
+ IF i MOD 2*interval = 0 THEN cout (i) FI;
+ byte (to, destination + offset, byte (from, origin + offset));
+ offset INCR 1.0
+ PER.
+
+copy fast :
+ IF origin MOD 2.0 <> 0.0 AND length > 0
+ THEN byte (to, destination, byte (from, origin));
+ offset := 1.0
+ FI;
+ FOR i FROM 1 UPTO (length - int (origin MOD 2.0)) DIV 2 REP
+ INT CONST page1 :: int ((origin+offset) DIV 512.0) + 1,
+ nr1 :: int ((origin+offset) MOD 512.0) DIV 2 + 1,
+ page2 :: int ((destination+offset) DIV 512.0) + 1,
+ nr2 :: int ((destination+offset) MOD 512.0) DIV 2 + 1;
+ to.b[page2][nr2] := from.b[page1][nr1];
+ IF i MOD interval = 0 THEN cout (2*i) FI;
+ offset INCR 2.0
+ PER;
+ IF length - int (offset) = 1
+ THEN byte (to, destination + offset, byte (from, origin + offset)) FI.
+END PROC copy;
+
+(************************ Hilfsprozeduren ********************************)
+
+REAL OP DIV (REAL CONST a, b) :
+ floor (a/b)
+END OP DIV;
+
+END PACKET setup eumel modulzugriffe;
+
+
+(**************************************************************************)
+(***** Zugriffe in Module mit Strukturwissen ****************)
+(***** Copyright (c) 1988 by ****************)
+(***** Lutz Prechelt, Karlsruhe ****************)
+(**************************************************************************)
+
+PACKET setup eumel modul und shard zugriffe (* Copyright (c) 1988 by *)
+DEFINES sh dtcb offset, (* Lutz Prechelt, Karlsruhe *)
+ sh ccb offset, (* Stand : 23.04.88 1.2 *)
+ get new channel table, (* Eumel 1.8.1 *)
+ init modules list,
+ all modules,
+ module type,
+ module name:
+
+(* Dieses Paket definiert Operationen zum Zugriff auf bestimmte Daten in
+ SHardmodulen und SHards. Es ist hierin Wissen über die Struktur dieser
+ Teile enthalten.
+ Beschreibung des SHardformats siehe setup eumel 4: modulkonfiguration
+*)
+
+LET nr of channels total = 40,
+ offset channel table pointer = 10;
+
+THESAURUS VAR all the beautiful modules we know :: emptythesaurus;
+
+(******************* Kanaltabelle lesen/schreiben **************************)
+
+(* Hier geht schöne Struktur (und damit zugleich einfache Programmierung)
+ über gute Performance. (Wir lesen einiges mehrfach)
+*)
+
+REAL PROC sh dtcb offset (MODUL CONST shard, INT CONST kanal) :
+ unsigned (int (shard, ct + 4 * kanal)).
+
+ct :
+ int (shard, offset channel table pointer).
+END PROC sh dtcb offset;
+
+REAL PROC sh ccb offset (MODUL CONST shard, INT CONST kanal) :
+ unsigned (int (shard, ct + 4 * kanal + 2)).
+
+ct :
+ int (shard, offset channel table pointer).
+END PROC sh ccb offset;
+
+PROC sh dtcb offset (MODUL VAR shard, INT CONST kanal, REAL CONST value) :
+ int (shard, ct + 4 * kanal, unsigned (value)).
+
+ct :
+ int (shard, offset channel table pointer).
+END PROC sh dtcb offset;
+
+PROC sh ccb offset (MODUL VAR shard, INT CONST kanal, REAL CONST value) :
+ int (shard, ct + 4 * kanal + 2, unsigned (value)).
+
+ct :
+ int (shard, offset channel table pointer).
+END PROC sh ccb offset;
+
+PROC get new channel table (MODUL CONST new shard,
+ ROW 256 INT VAR channel table of new shard) :
+ (* Kopiert die Kanaltabelle aus new shard nach
+ channel table of new shard
+ *)
+ INT VAR offset :: int (new shard, offset channel table pointer);
+ INT VAR i;
+ FOR i FROM 1 UPTO 2 * nr of channels total REP
+ channel table of new shard [i] := int (new shard, offset);
+ offset INCR 2
+ PER.
+END PROC get new channel table;
+
+(********************* modules list handling *****************************)
+
+TEXT VAR m list;
+
+PROC init modules list :
+ (* Baut in der Variablen m list einen "Assoziativspeicher" für
+ Modulnamen <--> Modultyp auf und erstellt eine Liste aller
+ Shardmoduldateinamen für "all modules"
+ Der Text m list enthält für jede Datei, die ein SHardmodul enthält,
+ einen Eintrag folgender Form :
+ ""0"", modultyp, ""0"", Dateiname, ""0""
+ Dabei ist modultyp genau 4 Byte lang.
+ Diese Eintragsform ermöglicht ein (auf dem Eumel) sehr effizientes
+ Suchen, sowohl von Modultypen zu Modulnamen als auch umgekehrt.
+ Die Prozedur macht cout (dateinummer)
+ *)
+ INT VAR i;
+ TEXT VAR t;
+ m list := ""; all the beautiful modules we know := empty thesaurus;
+ FOR i FROM 1 UPTO highest entry (all) REP
+ cout (i);
+ t := name (all, i);
+ IF t <> "" CAND type (old (t)) = datenraumtyp modul
+ THEN add t FI
+ PER.
+
+add t :
+ insert (all the beautiful modules we know, t);
+ TEXT CONST typ :: read module type (t);
+ m list cat typmarker;
+ m list CAT t;
+ m list CAT ""0"".
+
+m list cat typmarker :
+ m list CAT ""0"";
+ m list CAT typ;
+ m list CAT ""0"".
+END PROC init modules list;
+
+THESAURUS PROC all modules :
+ all the beautiful modules we know.
+END PROC all modules;
+
+TEXT PROC read module type (TEXT CONST datei) :
+ (* Liefert den 4-Byte Modultyp des in der Datei datei enthaltenen
+ SHardmoduls, falls möglich, andernfalls ""
+ *)
+ IF NOT exists (datei) COR type (old (datei)) <> datenraumtyp modul
+ THEN ""
+ ELSE BOUND MODUL CONST m :: old (datei);
+ text (m, int (m, 8), 4)
+ FI.
+END PROC read module type;
+
+TEXT PROC module type (TEXT CONST module name) :
+ (* Liefert den 4-Byte Modultyp zu module name aus m list, sofern vorhanden
+ andernfalls ""
+ *)
+ INT CONST p :: pos (m list, ""0"" + module name + ""0"");
+ IF p = 0
+ THEN ""
+ ELSE subtext (m list, p - 4, p - 1) FI.
+END PROC module type;
+
+TEXT PROC module name (TEXT CONST module type) :
+ (* Liefert den Moduldateinamen zum 4-Byte Modultyp module type, oder
+ "" falls kein solches Modul vorhanden.
+ *)
+ INT VAR p :: pos (m list, ""0"" + module type + ""0"");
+ IF p = 0
+ THEN ""
+ ELSE p INCR 6;
+ subtext (m list, p, pos (m list, ""0"", p) - 1)
+ FI.
+END PROC module name;
+
+END PACKET setup eumel modul und shard zugriffe;
+
diff --git a/system/setup/3.1/src/setup eumel 3: modulkonfiguration b/system/setup/3.1/src/setup eumel 3: modulkonfiguration
new file mode 100644
index 0000000..529d0de
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 3: modulkonfiguration
@@ -0,0 +1,854 @@
+
+(**************************************************************************)
+(***** Ergänzung des SHards um ein Modul (mit Dialog) *****************)
+(***** Copyright (c) 1987, 1988 by *****************)
+(***** Lutz Prechelt, Karlsruhe *****************)
+(**************************************************************************)
+
+PACKET setup eumel modulkonfiguration (* Copyright (c) by *)
+DEFINES configurate module, (* Lutz Prechelt, Karlsruhe *)
+ print configuration, (* Eumel 1.8.1 *)
+ give me, take you, (* Stand : 12.07.88 3.2 *)
+ new index,
+ perform dtcb dialogue,
+ perform ccb dialogue,
+ (* für Modulprogrammierer : *)
+ write info,
+ channel free,
+ reserve channel,
+ channels of this module,
+ buffer address :
+
+(* Dieses Modul führt den kompletten Dialog mit dem Benutzer durch, der
+ nötig ist, um alle Kanäle, die mit demselben Modul laufen sollen, zu
+ konfigurieren.
+ Verfahren :
+ im alten SHard den dtcb suchen
+ dtcb und Modul im neuen SHard eintragen
+ dtcb mit oder ohne Vorbild konfigurieren
+ alle ccbs zu dem Modul im alten SHard suchen und Kanalnummern merken
+ Auswahl einer Kanalmenge durch Benutzer mit alten als Vorschlag
+ ccbs in neuen SHard kopieren
+ ccbs mit oder ohne Vorbild konfigurieren
+ Kanaltabelle auf den neuen Stand bringen
+ neuen Shard und seine geänderte Länge zurückgeben
+
+ Dabei kann der "Dialog" bei geeigneten Rahmenbedingungen durch bloßes
+ Übertragen der Werte aus einem Vorlage-SHard ersetzt werden, wenn der
+ Benutzer dies wünscht (want automatic mode). Dann geht alles von selbst.
+ (....kaufen Sie Setup-Eumel und es geht alles wie von selbst !)
+
+Format des SHard-Hauptmoduls :
+ 1. (Byte 0-2) jmp boot (3 Byte)
+ 2. (Byte 3) reserviert
+ 3. (Byte 4) SHard-Version
+ 4. (Byte 5) SHard-Release
+ 5. (Byte 6/7) SHardlänge (2 Byte)
+ 6. (Byte 8/9) Verweis auf Bad-Block Tabelle (2 Byte)
+ 7. (Byte 10/11) Verweis auf Kanaltabelle
+ 8. (Byte 16-175) Eumelleiste
+ 9. (Byte 176-299) SHardleiste
+ 10. (ab Byte 300) Shardhauptmodulroutinen und -daten
+ 11. (danach) Rumpf des Hauptmoduls mit Bad-Block-Tabelle,
+ Kanaltabelle, Routinen und Daten
+ 12. (danach) Folge der Module (bis Byte SHardlänge - 1)
+
+Kanaltabelle:
+ feste Länge 40 Einträge "nr of channels total" (Kanal 0 bis Kanal 39)
+ jeder Eintrag besteht aus : (alles 2 Byte)
+ offset dtcb, offset ccb
+
+Achtung : Dieses Programm schmiert bei SHards über 32767 Byte Länge
+ eventuell ab (es hat noch niemand probiert) !
+
+Abkürzungen: cb steht für control block und meint entweder ccb oder dtcb
+
+Implementationsanmerkung :
+Bei der Verwendung von THESAURUS wird von dem Wissen über die Art der
+Implementation derselben Gebrauch gemacht, indem folgende Annahmen in den
+Code eingehen:
+1. Bei einem THESAURUS, in dem nicht gelöscht wurde, ist highest entry gleich
+ der Kardinalität
+2. außerdem entspricht dann die Nummer (link) eines Eintrags seinem
+ Eintragszeitpunkt, d.h. der Position in der Eintragsfolge
+3. + und - liefert THESAURi, in denen nicht gelöscht wurde und die Eintrags-
+ reihenfolge ist wie von den Parametern vorgegeben (bei + links zuerst)
+4. certain und ONE liefern THESAURi, in denen nicht gelöscht wurde.
+*)
+
+(************************* Daten ********************************)
+
+LET nr of channels total = 40, (* SHard Tabellenlänge *)
+ mdts = 40, (* max dialogtable size in INTs *)
+ mchm = 20, (* max channels for module *)
+ offset sh version = 4,
+ offset sh structureversion = 5,
+ offset shardlength = 6,
+
+ do name = "PrOgRaM tO Do";
+
+LET UNSIGNED = INT,
+ VARIABLES = ROW mdts ROW mchm INT;
+TEXT CONST variables var xxv :: "ROW " + text (mdts) + " ROW "+
+ text (mchm) + " INT VARxxv;";
+
+VARIABLES VAR v; (* siehe give me / take you *)
+
+INT VAR max index; (* Information für new index *)
+
+INT VAR channels of module; (* Information für channels of this module *)
+
+TEXT VAR actual info; (* fuer write info *)
+
+ROW 256 INT VAR channel table of new shard; (* für channel free *)
+
+DATASPACE VAR dummy ds; (* für print configuration *)
+
+REAL VAR new shard length;
+
+(***************************************************************************)
+(************* Hier geht's los...... ***************************************)
+(***************************************************************************)
+
+(******************** configurate module **********************************)
+
+PROC configurate module (MODUL VAR new shard, MODUL CONST old shard,
+ BOOL CONST old shard valid, want automatic mode,
+ TEXT CONST modulname) :
+ do configurate module (new shard, old shard, old shard valid,
+ want automatic mode, modulname, FALSE)
+END PROC configurate module;
+
+(********************** print configuration *******************************)
+
+PROC print configuration (MODUL CONST old shard, TEXT CONST modulname) :
+ (* Es ist hier schon sichergestellt, daß old shard valid ist und das Modul
+ auch im SHard enthalten
+ *)
+ forget (dummy ds); dummy ds := nilspace;
+ BOUND MODUL VAR dummy :: dummy ds;
+ do configurate module (dummy, old shard, TRUE, FALSE, modulname, TRUE);
+ forget (dummy ds).
+END PROC print configuration;
+
+
+(******************* do configurate module *********************************)
+
+PROC do configurate module (MODUL VAR new shard, MODUL CONST old shard,
+ BOOL CONST old shard valid, want automatic mode,
+ TEXT CONST modulname,
+ BOOL CONST print configuration only):
+ (* In dieser Prozedur ist die Beschränkung auf Module mit unter 32kB
+ Länge ausgenutzt.
+ Ist kein alter SHard vorhanden, so muss ein leerer SHard übergeben
+ werden (d.h. alle Einträge in der Kanaltabelle sind 0).
+ Ein alter SHard darf keinesfalls unterschiedliche releases desselben
+ Modultyps enthalten.
+ Resultierende SHardgesamtlängen von über 32k sind noch nicht getestet.
+ *)
+ BOUND MODUL VAR m;
+ INT VAR (***** Daten über das neue Modul *****)
+ sh version, sh structure version, release,
+ max ccb, nr of ccbs,
+ dtcb table entries, offset dtcb table, (* Variablentabellen *)
+ ccb table entries, offset ccb table,
+ muster ccb length, offset muster ccb, (* Muster-ccb im Modul *)
+ module body length, (* Länge des zu kopierenden Modulrumpfs *)
+ offset module body, offset dtcb;
+ TEXT VAR modultyp; (* 4 Byte *)
+ INT VAR (***** Daten über den alten SHard *****)
+ old release :: -2; (* garantiert inkompatibel *)
+ REAL VAR offset old dtcb :: 0.0;
+ ROW nr of channels total REAL VAR offset old ccb;
+ BOOL VAR old cbs valid :: FALSE;
+ THESAURUS VAR old channels :: empty thesaurus;
+ (***** Daten über den neuen SHard *****)
+ REAL VAR dtcb location;
+ ROW nr of channels total REAL VAR ccb location;
+ (***** Sonstige Daten *****)
+ INT VAR i, k, kanal, ccb count;
+ BOOL VAR automatic mode, configurate :: NOT print configuration only;
+ reset direction (FALSE); (* zur Sicherheit *)
+ IF configurate
+ THEN new shard length := unsigned (int (new shard, offset shard length)) FI;
+ connect module;
+ get module data;
+ test sh version compatibility; (* ggf. LEAVE *)
+ (* Bisher wurde nur gelesen, ab jetzt darf nicht mehr abgebrochen werden *)
+ search old shard for module and find all old ccbs;
+ test release compatibility; (* ggf. LEAVE *)
+ IF configurate
+ THEN write module with dtcb to shard;
+ perhaps set automatic mode;
+ FI;
+ configurate dtcb;
+ IF configurate
+ THEN kopf;
+ select channels;
+ write ccbs to shard;
+ ELSE nr of ccbs := highest entry (old channels)
+ FI;
+ configurate ccbs;
+ IF configurate
+ THEN make entries in channeltable of new shard;
+ int (new shard, offset shardlength, unsigned (new shard length))
+ FI.
+
+connect module :
+ m := old (modulname);
+ actual info := info (m);
+ IF configurate
+ THEN kopf
+ ELSE put ("-----"); put (modulname); putline ("-----")
+ FI.
+
+get module data :
+ (* Format des Moduls in den ersten Bytes:
+ Byte Entry
+ 0/1 offset dtcb variablen tabelle
+ 2/3 offset ccb variablen tabelle
+ 4/5 offset muster-ccb
+ 6/7 offset modulrumpf
+ 8/9 offset dtcb
+ 10/11 max anzahl ccbs
+ die tabellen enthalten im ersten Wort die Anzahl ihrer Einträge
+ der modulrumpf und der ccb ihre Länge in Byte
+ die Länge der Tabellen ergibt sich aus den offset-Differenzen.
+ dtcb-Format : Modultyp (4 Byte)
+ SHardversion (1 Byte)
+ SHardstrukturversion (1 Byte)
+ Modulrelease (2 Byte) ....
+ *)
+ max ccb := int (m, 10);
+ offset dtcb table := int (m, 0);
+ dtcb table entries := int (m, offset dtcb table);
+ offset ccb table := int (m, 2);
+ ccb table entries := int (m, offset ccb table);
+ offset muster ccb := int (m, 4);
+ muster ccb length := int (m, offset muster ccb);
+ offset module body := int (m, 6);
+ module body length := int (m, offset module body);
+ offset dtcb := int (m, 8);
+(*****
+put (" offset dtcb table:"); put( offset dtcb table); line;
+put (" dtcb table entrie:"); put( dtcb table entries); line;
+put (" offset ccb table :"); put( offset ccb table); line;
+put (" ccb table entrie:"); put( ccb table entries); line;
+put (" offset muster ccb:"); put( offset muster ccb); line;
+put (" muster ccb length:"); put( muster ccb length); line;
+put (" offset module bod:"); put( offset module body); line;
+put (" module body lengt:"); put( module body length); line;
+put (" offset dtcb :"); put( offset dtcb); line;*****)
+ modultyp := text (m, offset dtcb, 4);
+ sh version := byte (m, offset dtcb + 4);
+ sh structureversion := byte (m, offset dtcb + 5);
+ release := int (m, offset dtcb + 6).
+
+test sh version compatibility :
+ IF configurate AND NOT version is compatible
+ THEN putline ("Das Modul ist mit dieser SHard-Version nicht mehr verträglich.");
+ putline (""10""10""15" Installation des Moduls wird abgebrochen. "14""7""13""10"");
+ go on;
+ LEAVE do configurate module
+ FI.
+
+version is compatible:
+ (* Kompatibel, wenn das Modul eine ältere oder gleiche sh version verlangt
+ und die gleiche sh structureversion
+ *)
+ sh version <= byte (new shard, offset sh version) CAND
+ sh structure version = byte (new shard, offset sh structureversion).
+
+search old shard for module and find all old ccbs :
+ (* Es werden alle Kanäle des alten SHard untersucht, ob der dortige Treiber
+ den gleichen Modultyp hat und in diesem Fall die Kanalnummer in
+ "old channels" gesammelt, sowie offset old ccb gemerkt, im Nichterfolgs-
+ falle wird offset old ccb auf diesem Kanal 0 gesetzt.
+ Es werden auch alle verketteten Treiber untersucht.
+ Auch old cbs valid und offset old dtcb werden ggf. gesetzt.
+ *)
+ IF NOT old shard valid
+ THEN LEAVE search old shard for module and find all old ccbs FI;
+ IF configurate THEN put ("Ich untersuche den alten SHard :") FI;
+ FOR kanal FROM 0 UPTO nr of channels total - 1 REP
+ IF configurate THEN cout (kanal) FI;
+ collect ccbs on this channel
+ PER;
+ IF configurate THEN put (""13""5"") FI. (* Zeile löschen *)
+
+collect ccbs on this channel :
+ REAL VAR p dtcb :: sh dtcb offset (old shard, kanal),
+ p ccb :: sh ccb offset (old shard, kanal);
+ WHILE p dtcb <> 0.0 AND p ccb <> 0.0 REP
+ BOOL CONST success :: text (old shard, p dtcb, 4) = modultyp;
+ IF success
+ THEN offset old dtcb := p dtcb;
+ old release := int (old shard, p dtcb + 6.0);
+ insert (old channels, text (kanal));
+ offset old ccb [kanal+1] := p ccb
+ ELSE p dtcb := unsigned (int (old shard, p ccb + 2.0)); (* verkettet *)
+ p ccb := unsigned (int (old shard, p ccb + 4.0))
+ FI
+ UNTIL success PER;
+ old cbs valid := old shard valid AND offset old dtcb <> 0.0 AND
+ (release = old release + 1 OR release = old release).
+
+test release compatibility:
+ IF print configuration only AND NOT old cbs valid
+ THEN putline ("Kein Zugriff auf die Konfigurationsdaten möglich");
+ LEAVE do configurate module
+ FI.
+
+write module with dtcb to shard :
+ put ("Modul """ + modulname + """ wird in den SHard eingetragen :");
+ IF int (new shard length MOD 2.0) <> offset module body MOD 2
+ THEN new shard length INCR 1.0 FI; (* kopiert so schneller *)
+ dtcb location := new shard length +
+ real (offset dtcb - offset module body);
+ copy (m, real (offset module body), new shard, new shard length,
+ module body length);
+ new shard length INCR real (module body length).
+
+perhaps set automatic mode :
+ IF old cbs valid AND old release = release
+ THEN automatic mode := want automatic mode
+ ELSE automatic mode := FALSE FI.
+
+configurate dtcb :
+ IF configurate
+ THEN kopf;
+ putline ("Konfiguration des Treibers :");
+ get new channel table (new shard, channel table of new shard);
+ FI;
+ perform dtcb dialogue (m, real (offset dtcb table+2), dtcb table entries,
+ new shard, dtcb location,
+ old shard, offset old dtcb,
+ old cbs valid, release = old release,
+ dtcb refinements (m), dtcb abfragen (m),
+ automatic mode, print configuration only).
+
+select channels :
+ ccb count := highest entry (old channels);
+ k := min (ccb count, max ccb); (* .... Mutter der Porzellankiste *)
+ nr of ccbs := max (k, 1);
+ IF automatic mode THEN LEAVE select channels FI;
+ IF max ccb > 1
+ THEN REP
+ editget ("Wieviele Kanäle mit diesem Treiber (1 bis " +
+ text (max ccb) + ") : ", nr of ccbs);
+ out (""13"")
+ UNTIL nr of ccbs IN range (1, max ccb) PER;
+ out (""10""10"")
+ ELSE nr of ccbs := 1 FI;
+ IF nr of ccbs < ccb count (* weniger als früher *)
+ THEN put ("Wählen Sie mindestens"); putline (x kanäle aus deren);
+ putline ("Werte nicht als Vorbesetzung angeboten werden sollen"10"");
+ REP
+ THESAURUS CONST help :: certain (old channels, empty thesaurus);
+ IF NOT enough refused THEN out (""7"") FI
+ UNTIL enough refused PER;
+ old channels := old channels - help;
+ out (""3""3""3""4"") (* clear screen from incl. "Wählen..." on *)
+ FI.
+
+x kanäle aus deren :
+ IF ccb count - nr of ccbs > 1
+ THEN text (ccb count - nr of ccbs) + " Kanäle aus, deren"
+ ELSE "einen Kanal aus, dessen" FI.
+
+enough refused :
+ highest entry (help) >= ccb count - nr of ccbs.
+
+write ccbs to shard :
+ (* Ausserdem wird hier ccb location vorbereitet *)
+ out ("Die Kanäle werden in den neuen SHard eingetragen : ");
+ FOR i FROM 1 UPTO nr of ccbs REP
+ ccb location [i] := new shard length;
+ copy (m, real (offset muster ccb + 2), new shard, new shard length,
+ muster ccb length);
+ new shard length INCR real (muster ccb length)
+ PER.
+
+configurate ccbs :
+ (*put (old shard valid); put ("Release:"); put (release); put (" old release:"); put (old release);
+ put (old cbs valid); pause;*)
+ IF configurate
+ THEN out (""13""10"Konfiguration der Kanäle:"13""10"");
+ get new channel table (new shard, channel table of new shard)
+ FI;
+ ccb count := 0;
+ FOR kanal FROM 0 UPTO nr of channels total REP
+ IF old channels CONTAINS text (kanal)
+ THEN ccb count INCR 1;
+ offset old ccb [ccb count] := offset old ccb [kanal+1]
+ FI
+ PER;
+ FOR i FROM ccb count + 1 UPTO nr of ccbs REP
+ offset old ccb [i] := 0.0
+ PER;
+ perform ccb dialogue (m, real (offset ccb table+2), ccb table entries,
+ new shard, ccb location,
+ old shard, offset old ccb,
+ nr of ccbs,
+ offset old dtcb <> 0.0, release = old release,
+ ccb refinements (m), ccb abfragen (m),
+ automatic mode, print configuration only).
+
+make entries in channeltable of new shard :
+ kopf;
+ out ("Konfigurationsdaten werden in den neuen SHard eingetragen : ");
+ FOR i FROM 1 UPTO nr of ccbs REP
+ cout (i);
+ kanal := (*v[1][i]falsch???!!!*) byte (new shard, ccb location [i]);
+ make entry in channeltable of new shard
+ PER.
+
+make entry in channeltable of new shard :
+ IF NOT channel free (kanal)
+ THEN (* dtcb/ccb Adresse aus channel table nach neuem ccb umtragen. *)
+ int (new shard, ccb location [i] + 2.0,
+ unsigned (sh dtcb offset (new shard, kanal)));
+ int (new shard, ccb location [i] + 4.0,
+ unsigned (sh ccb offset (new shard, kanal)));
+ ELSE (* Folge-dtcb/ccb Adresse auf 0 setzen *)
+ int (new shard, ccb location [i] + 2.0, 0);
+ int (new shard, ccb location [i] + 4.0, 0);
+ FI;
+ (* Jetzt neue Adresse in channel table eintragen *)
+ sh dtcb offset (new shard, kanal, dtcb location);
+ sh ccb offset (new shard, kanal, ccb location [i]);
+ k := byte (new shard, ccb location [i] + 1.0); (* Zusatzkanalnummer *)
+ IF k <> 255 (* 255 = kein Zusatzkanal vorhanden *)
+ THEN (* IF NOT channel free (k) THEN alter eintrag futsch !!! *)
+ sh dtcb offset (new shard, k, dtcb location);
+ sh ccb offset (new shard, k, ccb location [i])
+ FI.
+
+kopf :
+ write head ("""" + modulname + """ in den SHard aufnehmen");
+ out (actual info);
+ out (""13""10"").
+END PROC do configurate module;
+
+
+(********************* perform dialogue ************************************)
+
+PROC perform dtcb dialogue
+ (MODUL VAR m, REAL CONST offset dialogue table,
+ INT CONST dialogue table entries,
+ MODUL VAR dtcb, REAL CONST offset dtcb,
+ MODUL CONST old dtcb, REAL CONST offset old dtcb,
+ BOOL CONST old dtcb valid, same release,
+ TEXT CONST refinements, INT CONST count,
+ BOOL CONST automatic mode, print configuration only):
+ ROW nr of channels total REAL VAR offset cb, offset old cb;
+ offset cb [1] := offset dtcb;
+ offset old cb [1] := offset old dtcb;
+ perform dialogue (TRUE, m, offset dialogue table, dialogue table entries,
+ dtcb, offset cb, old dtcb, offset old cb, 1,
+ old dtcb valid, same release, refinements, count,
+ automatic mode, print configuration only).
+END PROC perform dtcb dialogue;
+
+PROC perform ccb dialogue
+ (MODUL VAR m, REAL CONST offset dialogue table,
+ INT CONST dialogue table entries,
+ MODUL VAR ccb, ROW nr of channels total REAL CONST offset ccb,
+ MODUL CONST old ccb, ROW nr of channels total REAL CONST offset old ccb,
+ INT CONST nr of ccbs, BOOL CONST old ccbs valid, same release,
+ TEXT CONST refinements, INT CONST count,
+ BOOL CONST automatic mode, print configuration only) :
+ perform dialogue (FALSE, m, offset dialogue table, dialogue table entries,
+ ccb, offset ccb, old ccb, offset old ccb, nr of ccbs,
+ old ccbs valid, same release, refinements, count,
+ automatic mode, print configuration only).
+END PROC perform ccb dialogue;
+
+
+PROC perform dialogue
+ (BOOL CONST is dtcb,
+ MODUL VAR m, REAL CONST offset dialogue table,
+ INT CONST dialogue table entries,
+ MODUL VAR cb, ROW nr of channels total REAL CONST offset cb,
+ MODUL CONST old cb, ROW nr of channels total REAL CONST offset old cb,
+ INT CONST nr of cbs, BOOL CONST old cb valid, same release,
+ TEXT CONST refinements, INT CONST refinement count,
+ BOOL CONST automatic mode, print configuration only) :
+ (* Konfigurationsdialog für einen (Satz von) Kontrollblock(s) oder bloßes
+ Anzeigen der Konfigurationsdaten derselben.
+
+ 1. bei NOT print configuration only:
+ Führt den Dialog für eine Tabelle (also ccb oder dtcb Variablentabelle)
+ durch und bestückt den controlblock entsprechend.
+ Es wird gleich eine ganze Tabelle von controlblocks (max. mchm Stück)
+ abgearbeitet und zwar nr of cbs Stück; im Falle is dtcb wird natürlich
+ nur der Eintrag 1 der Tabellen benutzt (vom Aufrufer).
+ Das Eingabemodul ist m mit der zu bearbeitenden Tabelle an der Stelle
+ offset dialogue table. Die Tabelle enthält dialogue table entries
+ Einträge (max. mdts Stück !)
+ Die Ausgabe des Prozesses landet im Modul cb ab den Stellen offset cb.
+ cb ist dabei jeweils der neue SHard, damit man nicht das Modul ändert.
+ Die Vorlagen zum Abgucken liefert, falls old cb valid ist, das
+ Modul old cb (der alte SHard) ab offset old cb, dabei ist die Struktur
+ gleich der neuen, wenn same release gilt, andernfalls sind die
+ Vorversionsoffsets zu benutzen (Versionsnummer um genau 1 erhöht).
+ Bei automatic mode werden nur still diese Vorgabewerte übernommen.
+ Die Elan-Teile für den Dialog liefert schliesslich der Text refinements,
+ er enthält refinement count Abfragen der Namen r1, r2, .....
+ Wenn refinent count = 0 ist, passiert hier eigentlich nichts,
+ deshalb sollte dann
+ für eine korrekte Initialisierung auch die Variablentabelle leer sein;
+ ist sie es allerdings doch nicht, werden hier noch die Standardwerte in
+ die ccbs eingetragen und nur der leere Dialog unterdrückt.
+ Vor Beginn/Nach Ende des gesamten Dialogs wird das refinement
+ dialoguestart/dialogueend aufgerufen; bei NOT is dtcb vor/nach dem Dialog
+ jedes Kanals auch noch channelstart/channelend.
+
+ 2. bei print configuration only:
+ Die Daten zum new shard werden überhaupt nicht benutzt, von den
+ refinements wird nur für jeden Kanal einmal "print configuration"
+ aufgerufen.
+ *)
+ REAL VAR table byte :: offset dialogue table;
+ ROW mdts INT VAR offset, old offset, length;
+ INT VAR i, k;
+ BOOL VAR configurate :: NOT print configuration only;
+ TEXT VAR program, t;
+ IF print configuration only (* Hier wird evtl. schon verlassen *)
+ THEN startup for print
+ ELSE startup for dialogue FI;
+ IF refinement count > 0 THEN build program FI;
+ build data in v;
+ IF refinement count > 0 THEN do program FI;
+ IF configurate THEN put values in cb FI.
+
+startup for print :
+ IF refinement count = 0 OR dialogue table entries = 0
+ THEN LEAVE perform dialogue FI.
+
+startup for dialogue:
+ IF refinement count = 0
+ THEN putline ("Keine Konfiguration notwendig.");
+ IF dialogue table entries = 0
+ THEN pause (20); LEAVE perform dialogue FI
+ ELSE putline ("Die Konfiguration wird vorbereitet.") FI.
+
+build program:
+ max index := refinement count; (* damit new index bescheid weiss *)
+ program := variables var xxv;
+ program cat main part;
+ perhaps program cat data refinements;
+ program CAT refinements.
+
+program cat main part :
+ program CAT "LET UNSIGNED=INT;giveme(xxv);INT VARxxi::1,actchannel;";
+ IF print configuration only OR automatic mode
+ THEN program cat main part for print or automatic mode
+ ELSE program cat main part for dialogue FI.
+
+program cat main part for print or automatic mode:
+ (* Leider muss man, wenn man den Modulprogrammierer bei den .ccb und .dtcb
+ Teilen nicht zu stark reglementieren will, einiges mitübersetzen, was
+ dann gar nicht benutzt wird (z.B. alle Refinements).
+ Und der Gedanke macht ihn blaß,
+ wenn er fragt: was kostet das ?
+ Wilhelm Busch
+ *)
+ program CAT "FORactchannelFROM 1 UPTOchannelsofthismoduleREP";
+ IF print configuration only
+ THEN program CAT "printconfigurationPER."
+ ELSE (* automatic mode: *) program CAT "automaticPER;takeyou(xxv)."
+ FI;
+ program CAT " xxa:actchannel. thischannel:";
+ IF NOT is dtcb THEN program CAT "channelstart;" FI;
+ FOR i FROM 1 UPTO refinement count REP
+ program CAT "r"; (* Alle in this channel aufrufen, damit *)
+ program CAT text (i); (* "LEAVE this channel" kein Fehler ist. *)
+ program CAT ";"
+ PER;
+ IF NOT is dtcb
+ THEN program CAT "channelend" FI;
+ program CAT ". ".
+
+program cat main part for dialogue:
+ program CAT "dialoguestart;FORactchannelFROM 1 UPTOchannelsofthismoduleREP";
+ program CAT "thischannelPER;dialogueend;takeyou(xxv). ";
+ program CAT "xxa:actchannel. thischannel:";
+ IF NOT is dtcb THEN program CAT "channelstart;" FI;
+ program CAT "REP SELECTxxiOF ";
+ FOR i FROM 1 UPTO refinement count REP
+ program CAT "CASE ";
+ program CAT text (i);
+ program CAT ":r";
+ program CAT text (i);
+ program CAT " "
+ PER;
+ program CAT "ENDSELECT UNTIL NOTnewindex(xxi)PER";
+ IF NOT is dtcb
+ THEN program CAT ";channelend;reservechannel(xxv[1][xxa])" FI;
+ program CAT ". ".
+
+perhaps program cat data refinements :
+ FOR i FROM 1 UPTO dialogue table entries REP
+ IF configurate THEN cout (i) FI;
+ read start of next table entry; (* must be done in autom. mode, too, *)
+ t := next variable name; (* to get offset/oldoffset/length [i] *)
+ program CAT t;
+ program CAT ":xxv[";
+ program CAT text (i);
+ program CAT "][xxa]. "; (* Das war der normale Eintrag "varname" *)
+ program CAT t; (* Jetzt der für alle Kanäle "varname k" *)
+ program CAT "k:xxv[";
+ program CAT text (i);
+ program CAT "]. "
+ PER.
+
+read start of next table entry :
+ (* Format der Einträge in den Variablentabellen:
+ dw offset in cb
+ dw offset in old cb (oder ffffh falls neu)
+ db Typ (d.h. Länge und ist 1 oder 2)
+ db Namenslänge
+ db ...(Name)...
+ *)
+ INT CONST length of variable :: byte (m, table byte + 4.0),
+ length of name :: byte (m, table byte + 5.0);
+ old offset [i] := int (m, table byte + 2.0); (* Diese Sammlung *)
+ offset [i] := int (m, table byte); (* bereitet das Datenholen vor *)
+ length [i] := length of variable;
+ IF length of variable < 1 OR length of variable > 2
+ THEN errorstop ("invalid variablelength : " + text (length of variable))
+ FI;
+ table byte INCR 6.0.
+
+next variable name:
+ table byte INCR real (length of name);
+ text (m, table byte - real (length of name), length of name).
+
+build data in v :
+ FOR k FROM 1 UPTO nr of cbs REP (* Kanäle *)
+ IF configurate THEN cout (k) FI;
+ FOR i FROM 1 UPTO dialogue table entries REP (* Variablen *)
+ v[i][k] := next init value
+ PER
+ PER.
+
+next init value :
+ IF old cb valid CAND old cb present CAND value accessible
+ THEN value from old cb
+ ELSE value from new cb FI.
+
+old cb present :
+ offset old cb [k] > 0.0.
+
+value accessible :
+ same release OR
+ (* Ein release zuvor und Variable gibts schon: *) old offset [i] <> -1.
+
+value from old cb :
+ IF length [i] = 1
+ THEN byte (old cb, offset old cb [k] + real (offset of old value))
+ ELSE int (old cb, offset old cb [k] + real (offset of old value))
+ FI.
+
+value from new cb :
+ IF length [i] = 1
+ THEN byte (cb, offset cb [k] + real (offset [i]))
+ ELSE int (cb, offset cb [k] + real (offset [i])) FI.
+
+offset of old value :
+ IF same release
+ THEN offset [i]
+ ELSE old offset [i] FI.
+
+do program :
+ reset direction (TRUE);
+ channels of module := nr of cbs;
+ IF setup testing
+ THEN (* für diesen THEN-Teil beim abgespeckten Eumel
+ setup eummel mini eumel dummies insertieren *)
+ forget (do name, quiet);
+ FILE VAR f := sequentialfile (output, do name);
+ putline (f, program);
+ (*edit (do name);*)
+ run (do name);
+ forget(do name, quiet);
+ ELSE do (program);
+ FI;
+ program := ""; (* Platz sparen *)
+ reset direction (FALSE).
+
+put values in cb :
+ FOR k FROM 1 UPTO nr of cbs REP
+ cout (k);
+ FOR i FROM 1 UPTO dialogue table entries REP
+ IF length [i] = 1 THEN put byte ELSE put int FI
+ PER;
+ PER.
+
+put byte :
+ byte (cb, offset cb [k] + real (offset [i]), v[i][k]).
+
+put int :
+ int (cb, offset cb [k] + real (offset [i]), v[i][k]).
+END PROC perform dialogue;
+
+(****************** give me, take you, new index ***************************)
+
+(* Diese Prozeduren werden aus dem do beim perform dialogue heraus aufgerufen
+ Sie dienen zur Kommunikation mit den Paketdaten dieses Pakets (give me,
+ take you) oder zur Verkleinerung des do-Programms (new index)
+*)
+
+PROC give me (VARIABLES VAR variables) :
+ (* Der Sinn dieser Prozedur besteht in Folgendem :
+ bei perform dialogue wird in dem do, das die refinements des
+ SHard-Moduls ausführt, eine Datenstruktur vom Typ VARIABLES aufgebaut,
+ die alle in den Variablentabellen des Moduls aufgeführten Variablen
+ enthält und einzeln über passend benannte refinements zugänglich macht.
+ Diese Datenstruktur wird zuvor in diesem Paket hier initialisiert mit
+ Initwerten aus der Variablentabelle oder wenn möglich mit den
+ entsprechenden Werten aus dem alten SHard. Mit give me fordert das
+ do-Programm die initialisierte Datenstruktur aus diesem Paket hier an.
+ Im do wird am Schluss mit take you diese Datenstruktur an dieses Paket
+ (und damit an perform dialogue) zurückgegeben, damit die durch den
+ Dialog gesetzten Werte in den neuen SHard eingetragen werden können.
+ Eine alternative Methode, diese Kommunikation zu realisieren, wäre die
+ Benutzung von BOUND VARIABLES VARs mit demselben Datenraum.
+ *)
+ variables := v
+END PROC give me;
+
+PROC take you (VARIABLES CONST variables) :
+ (* Gegenstück zu give me, siehe dort *)
+ v := variables
+END PROC take you;
+
+BOOL PROC new index (INT VAR index) :
+ (* Verändert den Index je nach der direction und fragt bei down am Ende,
+ ob fertig. Liefert, ob es noch weitergehen soll (falls nein: index = 1)
+ *)
+ LET up = ""3"",
+ down = ""10"",
+ error = ""0"";
+ TEXT CONST old direction :: direction;
+ reset direction (TRUE);
+ IF old direction = error (* Bei Fehlern immer stehenbleiben *)
+ THEN TRUE
+ ELIF index = max index (* am Schluss aufhören oder nach 1 springen *)
+ THEN perhaps end
+ ELIF index = 1 AND old direction = up (* bei 1 und up an den Schluss *)
+ THEN index := max index; TRUE
+ ELSE normal new index (* sonst je nach direction up oder down *)
+ FI.
+
+perhaps end : (* index = max index *)
+ IF old direction = up AND max index > 1 (* hoch vom Ende *)
+ THEN index DECR 1;
+ TRUE
+ ELIF old direction = up
+ THEN TRUE
+ ELIF old direction = down (* runter am Ende *)
+ THEN index := 1;
+ TRUE
+ ELSE reset direction (FALSE); (* normal oder runter ans Ende *)
+ index := 1;
+ BOOL CONST ready :: yes (1, 23, "Fertig", FALSE);
+ reset direction (TRUE);
+ NOT ready
+ FI.
+
+normal new index :
+ IF old direction = up
+ THEN index DECR 1; TRUE
+ ELSE index INCR 1; TRUE FI.
+END PROC new index;
+
+(******************** channel (table) handling *****************************)
+
+BOOL PROC channel free (INT CONST nr,
+ ROW 256 INT CONST channel table of shard) :
+ IF nr < 0 OR nr > nr of channels total
+ THEN FALSE
+ ELSE channel table of shard [index ccb offset] = 0 FI.
+
+index ccb offset :
+ 2 * nr + 1 + 1.
+END PROC channel free;
+
+BOOL PROC channel free (INT CONST nr) :
+ channel free (nr, channel table of new shard).
+END PROC channel free;
+
+PROC reserve channel (INT CONST nr,
+ ROW 256 INT VAR channel table of shard) :
+ IF nr >= 0 AND nr < nr of channels total
+ THEN channel table of shard [index ccb offset] := 1 (* nichtnull *) FI.
+
+index ccb offset :
+ 2 * nr + 1 + 1. (* Start nicht bei 0 und ccb hinter dtcb *)
+END PROC reserve channel;
+
+PROC reserve channel (INT CONST nr) :
+ reserve channel (nr, channel table of new shard).
+END PROC reserve channel;
+
+(*THESAURUS PROC free channels (ROW 256 INT VAR channel table of shard):
+ (* Liefert einen THESAURUS, der die Klartextform genau aller in
+ channel table of shard als frei angegebenen Kanäle enthält.
+ *)
+ INT VAR i;
+ THESAURUS VAR result :: empty thesaurus;
+ FOR i FROM 1 UPTO nr of channels total REP
+ IF channel free (i, channel table of shard)
+ THEN insert (result, text (i)) FI
+ PER;
+ result.
+END PROC free channels;*)
+
+INT PROC channels of this module :
+ channels of module.
+END PROC channels of this module;
+
+(********************* write info, buffer adress **************************)
+
+PROC write info :
+ putline (actual info)
+END PROC write info;
+
+INT PROC buffer address (INT CONST buffer size):
+ IF new shard length MOD 2.0 <> 0.0 THEN new shard length INCR 1.0 FI;
+ INT CONST buf adr := unsigned (new shard length);
+ new shard length INCR real (buffer size);
+ IF new shard length >= 65536.0 OR buffer size > 1024
+ THEN errorstop ("zu großer Puffer verlangt")
+ FI;
+ buf adr
+END PROC buffer address;
+
+(************************* Hilfsprozeduren *******************************)
+
+PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line,
+ INT VAR start module nr, BOOL CONST new init, ins, dump, lst,
+ sys, coder, rt check, sermon) :
+ EXTERNAL 256
+END PROC elan;
+
+PROC do (TEXT CONST long line) :
+ DATASPACE VAR ds;
+ INT VAR module nr :: 0;
+ elan (2, ds, long line, module nr, FALSE, FALSE, FALSE, FALSE,
+ FALSE, FALSE, FALSE, FALSE);
+ forget (ds);
+ no do again
+END PROC do;
+
+PROC go on :
+ put (" >>>>> Taste drücken zum Weitermachen ");
+ REPEAT UNTIL incharety (2) = "" PER;
+ pause;
+ line.
+END PROC go on;
+
+END PACKET setup eumel modulkonfiguration;
+
diff --git a/system/setup/3.1/src/setup eumel 4: dienstprogramme b/system/setup/3.1/src/setup eumel 4: dienstprogramme
new file mode 100644
index 0000000..9ce9ca3
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 4: dienstprogramme
@@ -0,0 +1,218 @@
+
+(**************************************************************************)
+(***** Dienstprogramme für Modulprogrammierer *****************)
+(***** Copyright (c) 1987, 1988 *****************)
+(***** Lutz Prechelt, Karlsruhe *****************)
+(**************************************************************************)
+
+PACKET setup eumel dienstprogramme (* Copyright (c) 1987 by *)
+DEFINES (* Lutz Prechelt, Karlsruhe *)
+ file as one text, (* Stand : 07.05.88 1.4 *)
+ ich schreibe jetzt ein neues shard modul, (* Eumel 1.8.1 *)
+ link shard module,
+ all modules:
+
+(* Dies sind Dienstprogramme, die der Modul-Programmierer braucht *)
+
+(* Das Format der Refinementdateien für den dtcb- und ccb-Setupdialog ist wie
+ folgt:
+ 1. Zeile: INT-Denoter für die Anzahl von Abfragerefinements, die drin sind
+ Rest der Zeile muß leer sein.
+ Danach : lauter ELAN-Refinements mit den Namen r1, r2 usw.
+ evtl. weitere Refinements zur Hilfe mit beliebigen Namen (es
+ gibt ein paar Ausnahmen, über die man beim ersten Test dann aber
+ stolpert.)
+ In den Refinements dürfen Variablen vereinbart werden. Vor dem ersten
+ refinement der Datei darf KEIN Punkt sein (es ist sowieso schlechter
+ Stil, die Punkte nicht hinter die vorherige Zeile zu setzen, sondern
+ vor den refinementnamen.), hingegen MUSS nach dem letzten Refinement der
+ Datei ein Punkt stehen.
+ Wer das für nötig hält, kann auch Prozeduren definieren und verwenden,
+ was allerdings nicht geht, sind Pakete.
+ Wenn man mit Kommentaren und sonstigen Bytefressern sparsam
+ umgeht, läuft der Dialog beim Setup später etwas schneller an.
+*)
+
+LET modul namentyp = "SHardmodul *";
+
+DATASPACE VAR ds;
+
+(***************************************************************************)
+
+THESAURUS PROC all modules (THESAURUS CONST th):
+ (* Hier wird schlabberig nach Namen ausgewählt, während der Setup Eumel
+ im Betrieb die Datenraumtypen als Auswahlkriterium verwendet.
+ Die Schwierigkeiten, die bei Nichteinhalten der Namenskonventionen
+ entstehen, veranlassen hoffentlich jeden zur nötigen Disziplin...
+ *)
+ (th LIKE "SHardmodul *") - (th LIKE "SHardmodul *.ccb")
+ - (th LIKE "SHardmodul *.dtcb") - (th LIKE "SHardmodul *.info")
+END PROC all modules;
+
+(*****THESAURUS PROC all modules: wird sauber in Teil 2 realisiert
+ all modules (all)
+END PROC all modules;
+*****)
+
+(********************* link shard module *********************************)
+
+PROC link shard module:
+ TEXT VAR module :: std;
+ REPEAT
+ page;
+ putline (" L I N K S H A R D - M O D U L E"); line (2);
+ put ("Modulname:"); editget (module); line (2);
+ link shard module (module); line;
+ UNTIL NOT yes ("noch ein Modul linken", FALSE) PER
+END PROC link shard module;
+
+PROC link shard module (THESAURUS CONST th):
+ do (PROC (TEXT CONST) link shard module, th);
+END PROC link shard module;
+
+PROC link shard module (TEXT CONST module):
+ (* Ruft link shard module (modul, dtcb, ccb, info) unter Anwendung von
+ Namenskonventionen (nämlich entsprechende Suffixe ".dtcb" etc.) auf.
+ *)
+ TEXT VAR dtcb, ccb, info;
+ BOOL VAR elan neu;
+ dtcb := module + ".dtcb";
+ ccb := module + ".ccb";
+ info := module + ".info";
+ perhaps change filenames;
+ elan neu := yes (module + ": neue Elan Teile machen", FALSE);
+ IF elan neu THEN neue elan teile machen FI;
+ link shard module (module, dtcb, ccb, info);
+ IF elan neu THEN check syntax FI.
+
+neue elan teile machen:
+ edit (dtcb); line (2);
+ edit (ccb); line (2);
+ edit (info); page.
+
+perhaps change filenames:
+(*put ("Datei mit dtcb-refinements :"); editget (dtcb); line;
+ put ("Datei mit ccb-refinements :"); editget (ccb); line;
+ put ("Datei mit Infotext :"); editget (info); line (2)*) .
+
+check syntax :
+ line (2); put (module); putline (": Syntax-Check");
+ forget (ds);
+ ds := nilspace;
+ BOUND MODUL VAR m :: old (module), old shard :: ds, new shard :: ds;
+ INT VAR offset dtcb table :: int (m, 0),
+ dtcb table entries :: int (m, offset dtcb table),
+ offset ccb table :: int (m, 2),
+ ccb table entries :: int (m, offset ccb table);
+ (* Jetzt einen total verkrüppelten automatischen "perform dialogue" für
+ die Probeübersetzung der .dtcb und .ccb refinements aufrufen.
+ *)
+ perform dtcb dialogue (m, real (offset dtcb table+2), dtcb table entries,
+ new shard, 0.0,
+ old shard, 0.0,
+ FALSE, FALSE,
+ dtcb refinements (m), dtcb abfragen (m),
+ TRUE, FALSE);
+ putline ("dtcb refinements O.K.");
+ ROW 40 REAL VAR x :: ROW 40 REAL : (0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
+ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
+ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
+ 0.0, 0.0);
+ perform ccb dialogue (m, real (offset ccb table+2), ccb table entries,
+ new shard, x,
+ old shard, x,
+ 1,
+ FALSE, FALSE,
+ ccb refinements (m), ccb abfragen (m),
+ TRUE, FALSE);
+ putline ("ccb refinements O.K.");
+ forget (ds).
+END PROC link shard module;
+
+PROC link shard module (TEXT CONST module, dtcb, ccb, infofile) :
+ IF type (old (module)) <> datenraumtyp modul CAND NOT typ aendern
+ THEN LEAVE link shard module
+ ELSE type (old (module), datenraumtyp modul) FI;
+ IF NOT (module LIKE modul namentyp)
+ THEN errorstop ("Module MÜSSEN Namen der Art """ + modul namentyp +
+ """ haben")
+ FI;
+ line;
+ BOUND MODUL VAR m :: old (module);
+ TEXT VAR dtcb ref :: file as one text (dtcb, FALSE),
+ ccb ref :: file as one text (ccb, FALSE),
+ info text:: file as one text (infofile, TRUE);
+ INT CONST pos dtcb :: pos (dtcb ref, " "), (* Ende der ersten Zeile, die *)
+ pos ccb :: pos (ccb ref, " "); (* die Abfragezahl enthält *)
+ INT VAR dtcb count, ccb count;
+ dtcb count := int (subtext (dtcb ref, 1, pos dtcb));
+ IF NOT last conversion ok OR dtcb count < 0 OR dtcb count > 1000
+ THEN errorstop ("keine vernünftige Zahl von dtcb Abfragen gefunden") FI;
+ ccb count := int (subtext (ccb ref, 1, pos ccb));
+ IF NOT last conversion ok OR ccb count < 0 OR ccb count > 1000
+ THEN errorstop ("keine vernünftige Zahl von ccb Abfragen gefunden") FI;
+ (* JETZT PASSIERTS : *)
+ dtcb abfragen (m, dtcb count);
+ dtcb refinements (m, subtext (dtcb ref, pos dtcb + 1));
+ ccb abfragen (m, ccb count);
+ ccb refinements (m, subtext (ccb ref, pos ccb + 1));
+ info (m, infotext);
+ line;
+ putline (""""+module+""" gelinkt. " + text (storage (old (module))) +
+ " K Datenraumgröße.").
+
+typ aendern :
+ IF type (old (module)) = 1003 (* file type *)
+ THEN putline ("(""" + module + """ hat den Typ FILE)") FI;
+ putline ("Achtung: """ + module + """ ist nicht vom Typ eines SHard-Moduls");
+ yes ("Soll es dazu gemacht werden (Typ aufprägen)", FALSE).
+END PROC link shard module;
+
+(******************** file as one text ************************************)
+
+TEXT PROC file as one text (TEXT CONST filename, BOOL CONST verbatim) :
+ FILE VAR f :: sequential file (input, filename);
+ TEXT VAR result :: "", t;
+ put ("Lese """ + filename + """ :");
+ WHILE NOT eof (f) REP
+ cout (line no (f));
+ getline (f, t);
+ work on t;
+ result CAT t
+ PER;
+ line;
+ result.
+
+work on t :
+ IF verbatim
+ THEN t CAT ""13""10""
+ ELSE t := compress (t); t CAT " " FI.
+END PROC file as one text;
+
+(****** ich schreibe jetzt ein neues shard modul ***************************)
+
+PROC ich schreibe jetzt ein neues shard modul :
+ line (2);
+ putline ("So so, Sie wollen also ein neues SHard-Modul schreiben."); line;
+ pause (20);
+ putline ("Mir kommt es so vor, als sei heute der " + date +
+ " und im Moment gerade " + time of day + " Uhr"); line;
+ IF NOT yes ("Stimmt das ungefähr (auf 5 Minuten kommt's nicht an)", TRUE)
+ THEN do ("set date"); line (2) FI;
+ putline ("Also gut. Schreiben Sie Ihr verdammtes Modul.");
+ putline ("Aber merken Sie sich die folgenden 4 Bytes als ihren Modultyp");
+ put (""15" ");
+ REAL VAR x :: floor (clock (1) - date ("05.05.79") - time ("10:00:00"));
+ INT VAR i;
+ FOR i FROM 1 UPTO 4 REP
+ put (int (x MOD 256.0));
+ x := floor (x / 256.0)
+ PER;
+ put (" "14""); line (2);
+ putline ("Also : die Dinger merken (schreiben Sie sie auf, sonst vergessen Sie");
+ putline (" sie ja doch) und NICHT MEHR ÄNDERN !");
+ line (3)
+END PROC ich schreibe jetzt ein neues shard modul;
+
+END PACKET setup eumel dienstprogramme;
+
diff --git a/system/setup/3.1/src/setup eumel 5: partitionierung b/system/setup/3.1/src/setup eumel 5: partitionierung
new file mode 100644
index 0000000..705f26d
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 5: partitionierung
@@ -0,0 +1,435 @@
+PACKET setup eumel partitionierung (* Copyright (C) 1985 *)
+ (* Martin Schönbeck, Spenge *)
+DEFINES tracks, (* Lutz Prechelt, Karlsruhe *)
+ sectors, (* Änderungen: Ley ms *)
+ heads, (* Stand: 07.04.89 *)
+ first track,
+ last track,
+ partition start,
+ partition type,
+ partition active,
+ partition size,
+ partition word 0,
+
+ get boot block,
+ put boot block,
+ clear partition,
+
+ (*get bad track table,*)
+ get bad sector table,
+ clear partition table,
+ setup channel,
+ start of partition:
+
+ LET bst size = 1024; (* nr of bad sector table entrys *)
+
+ROW 256 INT VAR boot block;
+INT VAR boot block session := session - 1;
+INT VAR fd channel := 28; (* Festplatten-Setupkanal *)
+
+INT PROC setup channel:
+ fd channel
+END PROC setup channel;
+
+PROC setup channel (INT CONST new channel):
+ enable stop;
+ teste kanal typ;
+ boot block session DECR 1;
+ wirf altes pac raus;
+ fd channel := new channel;
+ sorge dafuer dass kanal uptodate ist.
+
+teste kanal typ:
+ IF (get value (1, new channel) AND 12) <> 12
+ THEN errorstop ("Hier gibt es leider keine Platte")
+ FI.
+
+wirf altes pac raus:
+ IF new channel <> fd channel
+ THEN INT VAR raus := get value (-13, fd channel);
+ FI.
+
+sorge dafuer dass kanal uptodate ist:
+ INT VAR old channel := channel;
+ ROW 256 INT VAR dummy; INT VAR i;
+ continue (new channel);
+ disable stop;
+ blockin (dummy, -1, -1, i);
+ break (quiet);
+ continue (old channel).
+
+END PROC setup channel;
+
+PROC get bad sector table (ROW bst size REAL VAR bb tab,
+ INT VAR bad sect, INT CONST eumel type):
+ initialisiere tabelle;
+ suche schlechte sectoren.
+
+initialisiere tabelle:
+ INT VAR i;
+ FOR i FROM 1 UPTO bst size REP
+ bb tab [i] := -1.0;
+ PER.
+
+suche schlechte sectoren:
+ INT VAR my channel := channel;
+ REAL VAR sector := start of partition (eumel type),
+ end := sector + partition size (partition number (eumel type)),
+ track mode restart :: 0.0;
+ INT VAR akt track := 0,
+ fehler code;
+ bad sect := 1; (* Eintragsnr. des NÄCHSTEN schlechten Sektors *)
+ continue (fd channel);
+ disable stop;
+ DATASPACE VAR ds := nilspace;
+ REAL CONST cylinder size :: real (sectors * heads),
+ track size :: real (sectors);
+ track mode restart := sector + track size -
+ (sector MOD track size);
+ (* wenn sector nicht erster der spur, dann die erste einzeln *)
+ WHILE sector < end REP
+ IF sector MOD cylinder size = 0.0
+ THEN melde naechste spur FI;
+ IF sector >= track mode restart
+ THEN check track
+ ELSE check sector FI
+ UNTIL bad sect > bst size OR is error PER;
+ continue (my channel);
+ forget (ds);
+ enable stop;
+ IF bad sect > bst size
+ THEN errorstop ("Zu viele schlechte Sektoren");
+ FI;
+ lass nicht zu dass ein ersatzsektor ein schlechter ist;
+ bad sect DECR 1. (* ANZAHL schlechter Sektoren *)
+
+melde naechste spur:
+ break (quiet);
+ continue (my channel);
+ akt track INCR 1;
+ cout (akt track);
+ continue (fd channel).
+
+check track :
+ verify track (ds, 2, sector, fehler code);
+ IF schlechten sektor gefunden
+ THEN track mode restart := sector + tracksize
+ ELSE sector INCR track size FI.
+
+check sector :
+ read block (ds, 2, sector, fehler code);
+ IF schlechten sektor gefunden
+ THEN eintragen FI;
+ sector INCR 1.0.
+
+schlechten sektor gefunden:
+ SELECT fehler code OF
+ CASE 0: FALSE
+ CASE 1: error stop ("Platte kann nicht gelesen werden"); FALSE
+ CASE 2: TRUE
+ CASE 3: error stop ("Versorgungsfehler beim Plattentest"); FALSE
+ OTHERWISE error stop ("unbekannter Fehler auf Platte"); FALSE
+ END SELECT.
+
+eintragen:
+ bb tab [bad sect] := sector;
+ bad sect INCR 1.
+
+lass nicht zu dass ein ersatzsektor ein schlechter ist:
+ REAL VAR aktueller ersatz := end - real (bad sect - 1);
+ INT VAR akt b sect;
+ FOR akt b sect FROM 1 UPTO bad sect - 1 REP
+ IF aktueller ersatz ist in tabelle
+ THEN vertausche aktuell zu ersetzenden mit ihm
+ FI;
+ PER.
+
+aktueller ersatz ist in tabelle:
+ INT VAR such index;
+ FOR such index FROM 1 UPTO bad sect REP
+ IF aktueller ersatz = bb tab (such index)
+ THEN LEAVE aktueller ersatz ist in tabelle WITH TRUE
+ FI;
+ PER;
+ FALSE.
+
+vertausche aktuell zu ersetzenden mit ihm:
+ bb tab ( such index ) := bb tab ( akt b sect );
+ bb tab (akt b sect) := aktueller ersatz.
+END PROC get bad sector table;
+
+INT PROC cyl and head (REAL CONST sector):
+ cylinder code (int (sector / real (sectors)) DIV heads) OR head.
+
+head :
+ (int (sector / real (sectors)) MOD heads).
+END PROC cyl and head;
+
+PROC get boot block:
+ IF boot block session <> session
+ THEN hole aktuellen boot block
+ FI.
+
+hole aktuellen bootblock :
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ get external block (dummy ds, 2, 0, fd channel);
+ IF NOT is error
+ THEN transfer data to boot block
+ FI;
+ forget (dummy ds).
+
+transfer data to boot block:
+ IF not valid boot block
+ THEN try to get valid boot block from file
+ FI;
+ boot block := partition table. block;
+ boot block session := session.
+
+not valid boot block:
+ partition table. block [256] <> boot indicator OR
+ it is an old boot block of eumel.
+
+boot indicator: -21931.
+
+it is an old boot block of eumel:
+ partition table. block [1] = 1514.
+
+try to get valid boot block from file:
+ forget (dummy ds);
+ partition table := old ("bootblock");
+ IF is error THEN LEAVE transfer data to boot block FI.
+END PROC get boot block;
+
+PROC clear partition table (INT CONST sicherung):
+ IF sicherung = -3475
+ THEN neuen boot block;
+ put boot block
+ FI.
+
+neuen boot block:
+ enable stop;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table;
+ partition table := old ("bootblock");
+ boot block := partition table. block;
+ boot block session := session.
+END PROC clear partition table;
+
+PROC put boot block:
+ IF boot block ist uptodate
+ THEN schreibe block auf platte
+ ELSE errorstop ("boot block nicht uptodate")
+ FI.
+
+boot block ist uptodate:
+ boot block session = session.
+
+schreibe block auf platte:
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ transfer data to dataspace;
+ put external block (dummy ds, 2, 0, fd channel);
+ forget (dummy ds).
+
+transfer data to dataspace:
+ partition table. block := boot block.
+END PROC put boot block;
+
+INT PROC partition number (INT CONST part type):
+ INT VAR partition;
+ FOR partition FROM 1 UPTO 4 REP
+ IF partition type (partition) = part type
+ THEN LEAVE partition number WITH partition
+ FI
+ PER;
+ errorstop ("Partitiontyp gibt es nicht");
+ 7.
+END PROC partition number;
+
+INT PROC partition word 0 (INT CONST partition):
+ boot block (entry (partition))
+END PROC partition word 0;
+
+PROC partition word 0 (INT CONST partition, word):
+ boot block (entry (partition)) := word
+END PROC partition word 0;
+
+REAL PROC start of partition (INT CONST partition type):
+ partition start (partition number (partition type))
+END PROC start of partition;
+
+
+INT PROC first track (INT CONST partition):
+ high byte (boot block [entry (partition) + 1])
+ + 4 * (low byte (boot block [entry (partition) + 1]) AND (128 + 64))
+END PROC first track;
+
+INT PROC last track (INT CONST partition):
+ high byte (boot block [entry (partition) + 3])
+ + 4 * (low byte (boot block [entry (partition) + 3]) AND (128 + 64))
+END PROC last track;
+
+INT PROC partition type (INT CONST partition):
+ low byte (boot block [entry (partition) + 2])
+END PROC partition type;
+
+BOOL PROC partition active (INT CONST partition):
+ low byte (boot block [entry (partition)]) = 128
+END PROC partition active;
+
+(****************** neu eingefügt ******************************)
+PROC partition active (INT CONST partition, BOOL CONST active):
+ IF active THEN activate this partition
+ ELSE deactivate this partition
+ FI.
+
+deactivate this partition:
+ set bit (boot block [entry (partition)], 7);
+ (* first setting needed, because reset bit does xor *)
+ reset bit (boot block [entry (partition)], 7).
+
+activate this partition:
+ set bit (boot block [entry (partition)], 7).
+END PROC partition active;
+
+(****************** neu eingefügt ******************************)
+
+PROC first track (INT CONST partition, cylinder):
+ boot block [entry (partition) + 1]
+ := cylinder code (cylinder) OR start sector.
+
+start sector:
+ IF cylinder = 0
+ THEN 2
+ ELSE 1
+ FI.
+END PROC first track;
+
+PROC last track (INT CONST partition, cylinder):
+ boot block [entry (partition) + 3] := cylinder code (cylinder).
+END PROC last track;
+
+PROC partition type (INT CONST partition, type):
+ boot block [entry (partition) + 2] := type.
+END PROC partition type;
+
+REAL PROC partition start (INT CONST partition):
+ unsigned low word + high word.
+
+unsigned low word:
+ real (low byte (boot block [entry (partition) + 4])) +
+ real (high byte (boot block [entry (partition) + 4])) * 256.0.
+
+high word:
+ real (boot block [entry (partition) + 5]) * 65536.0.
+END PROC partition start;
+
+PROC partition start (INT CONST partition, REAL CONST sector offset):
+ boot block [entry (partition) + 4] := low word (sector offset);
+ boot block [entry (partition) + 5] := high word (sector offset)
+END PROC partition start;
+
+REAL PROC partition size (INT CONST partition):
+ unsigned low word + high word.
+
+unsigned low word:
+ real (low byte (boot block [entry (partition) + 6])) +
+ real (high byte (boot block [entry (partition) + 6])) * 256.0.
+
+high word:
+ real (boot block [entry (partition) + 7]) * 65536.0.
+END PROC partition size;
+
+PROC partition size (INT CONST partition, REAL CONST number of blocks):
+ boot block [entry (partition) + 6] := low word (number of blocks);
+ boot block [entry (partition) + 7] := high word (number of blocks)
+END PROC partition size;
+
+PROC clear partition (INT CONST partition):
+ INT VAR i;
+ FOR i FROM 0 UPTO 7 REP
+ boot block [entry (partition) + i] := 0
+ PER
+END PROC clear partition;
+
+INT PROC entry (INT CONST partition):
+ get boot block;
+ 256 - 5 * 8 + (partition * 8)
+END PROC entry;
+
+INT PROC cylinder code (INT CONST cylinder):
+ cylinder text ISUB 1.
+
+cylinder text:
+ high cylinder bits + low cylinder bits.
+
+high cylinder bits:
+ code ((cylinder AND (256 + 512)) DIV 4).
+
+low cylinder bits:
+ code (cylinder AND (128 + 64 + 32 + 16 + 8 + 4 + 2 + 1)).
+END PROC cylinder code;
+
+INT PROC tracks:
+ get value (-10, fd channel)
+END PROC tracks;
+
+INT PROC sectors:
+ get value (-11, fd channel)
+END PROC sectors;
+
+INT PROC heads:
+ get value (-12, fd channel)
+END PROC heads;
+
+INT PROC get value (INT CONST control code, channel for value):
+ enable stop;
+ INT VAR old channel := channel;
+ IF channel for value <> old channel THEN continue (channel for value) FI;
+ INT VAR value;
+ control (control code, 0, 0, value);
+ IF channel for value <> old channel THEN continue (old channel) FI;
+ value
+END PROC get value;
+
+PROC get external block (DATASPACE VAR ds, INT CONST ds page,
+ archive block, get channel):
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+END PROC get external block;
+
+PROC put external block (DATASPACE CONST ds, INT CONST ds page,
+ archive block, get channel):
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+END PROC put external block;
+
+END PACKET setup eumel partitionierung;
+
diff --git a/system/setup/3.1/src/setup eumel 6: shardmontage b/system/setup/3.1/src/setup eumel 6: shardmontage
new file mode 100644
index 0000000..cc0d475
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 6: shardmontage
@@ -0,0 +1,389 @@
+
+(**************************************************************************)
+(***** Zusammenbau eines SHards aus Modulen mit Dialog *****************)
+(***** Copyright (c) 1987, 1988 by *****************)
+(***** Lutz Prechelt, Karlsruhe *****************)
+(**************************************************************************)
+
+PACKET setup eumel shardmontage (* Copyright (c) 1987 by *)
+DEFINES build shard, (* Lutz Prechelt, Karlsruhe *)
+ add bad sector table to shard, (* Stand : 08.04.88 3.2 *)
+ installation nr, (* Eumel 1.8.1 *)
+ print configuration :
+
+(* Beschreibung des SHard-Hauptmodulformats siehe "modulkonfiguration" *)
+
+(* In diesem Paket sind viele Namenskonventionen verankert.
+ Das leere SHard-Hauptmodul hat den Namen "SHard leer", teilaufgebaute
+ SHards heissen normalerweise in der Form "SHard 07.07.87 14:34" (andere
+ Namen sind möglich, wenn sie mit "SHard " beginnen.)
+ Die Prozedur build shard bastelt in Dialogsteuerung durch den Benutzer
+ aus Modulen und einem leeren oder teilaufgebauten SHard-Hauptmodul einen
+ neuen SHard zusammen und schreibt ihn in die Datei SHARD
+ Die Prozedur add bad block table to shard fügt einem so zusammengebauten
+ SHard eine bad block tabelle gemäß dem Zustand der Partition hinzu oder
+ ändert die vorhandene.
+ Dann ist der SHard komplett fertig zum auf-die-Partition-schleudern.
+ (einschliesslich Installationsnummer)
+*)
+
+LET hauptmodul namentyp = "SHard *",
+ (*modul namentyp = "SHardmodul *",*)
+ shard name = "SHARD";
+
+LET bad sector table size = 1024, (* Entries *)
+ max sh length = 60, (* Blocks, vorläufig !!! *)
+ nr of channels total = 40,
+ offset shard length = 6,
+ offset bad sector table pointer = 8,
+ offset verbal identification = 176, (* Start Shardleiste *)
+ offset id 4 = 196; (* 176 + 14h *)
+
+INT VAR actual installation nr :: id (5);
+DATASPACE VAR ds :: nilspace;
+
+PROC build shard (DATASPACE CONST old shard ds) :
+ (* Der Aufrufer muß hinterher nachsehen, ob es die Datei SHARD auch
+ wirklich gibt. Falls nicht, ist "Aufbau des SHards war nicht möglich"
+ zu melden.
+ *)
+ BOUND MODUL VAR old shard :: old shard ds, new shard;
+ TEXT VAR t;
+ INT VAR i;
+ THESAURUS VAR th, modules, automatic mode modules,
+ modules in old shard, modules in new shard;
+ BOOL CONST old shard valid :: int (old shard, offset id 4) = id (4) AND
+ verbal identification ok;
+ perhaps take old shard; (* ggf. LEAVE *)
+ get main module name in t;
+ copy (t, shard name);
+ new shard := old (shard name);
+ enable stop;
+ eliminate bad sector table from shard (new shard);
+ get module names;
+ configurate modules and build shard;
+ add ids.
+
+verbal identification ok :
+ text (old shard, offset verbal identification, 16) =
+ "SHard Schoenbeck".
+
+perhaps take old shard :
+ kopf;
+ forget (shard name, quiet);
+ IF old shard valid CAND
+ yes ("Wollen Sie den SHard genauso wie beim letzten Setup", FALSE)
+ THEN copy (old shard ds, shard name); LEAVE build shard
+ ELSE out (""10"") FI.
+
+get main module name in t :
+ putline (" A u s w a h l d e s S H a r d - H a u p t m o d u l s "10"");
+ th := all LIKE hauptmodul namentyp;
+ IF highestentry (th) > 1
+ THEN let the user select one
+ ELSE take the only one FI.
+
+let the user select one :
+ putline ("Wählen Sie jetzt bitte, welches SHard-Hauptmodul Sie als");
+ putline ("Ausgangspunkt der Konfiguration benutzen möchten.");
+ putline ("(Namen durch Zeiger auswählen dann RETURN-Taste drücken)");
+ t := ONE th;
+ out (""4""13""10""10""10"").
+
+take the only one :
+ t := name (th, 1);
+ putline ("Das einzige verfügbare SHard Hauptmodul ist");
+ putline (t);
+ pause (30).
+
+get module names :
+ (* Besorgt die Listen 1. vorhandene Module 2. Module im alten SHard
+ und 3. Module im SHard Hauptmodul
+ Liefert in modules eine Auswahl von 1. ohne 3. mit 2. als Vorschläge
+ und in automatic mode modules eine Auswahl von 2. (alles vorgeschlagen)
+ Die Liste 2. ist dabei so sortiert, daß stets eingekettete Module in der
+ richtigen Reihenfolge auftauchen.
+ *)
+ kopf;
+ put ("Ich untersuche den SHard: ");
+ get modules in shard (new shard, modules in new shard);
+ IF old shard valid
+ THEN get modules in shard (old shard, modules in old shard)
+ ELSE modules in old shard := empty thesaurus FI;
+ kopf;
+ putline ("Wählen Sie jetzt bitte mit RETURN/rauf/runter, welche Module Sie");
+ putline ("mit in den SHard aufnehmen möchten.");
+ putline ("(Zum Verlassen ESC q)");
+ modules := certain (all modules - modules in new shard,
+ modules in old shard);
+ IF old shard valid
+ THEN kopf;
+ putline ("Wählen Sie jetzt, welche der Module vollautomatisch wie im");
+ putline ("Vorlage-SHard konfiguriert werden sollen (Reihenfolge egal)");
+ automatic mode modules := certain (modules / modules in old shard,
+ modules in old shard)
+ ELSE automatic mode modules := empty thesaurus FI.
+
+configurate modules and build shard :
+ FOR i FROM 1 UPTO highest entry (modules) REP
+ page; cout (i); collect heap garbage;
+ t := name (modules, i);
+ configurate module (new shard, old shard,
+ modules in old shard CONTAINS t,
+ automatic mode modules CONTAINS t, t)
+ PER;
+ IF highest entry (automatic mode modules) < highest entry (modules)
+ THEN perhaps keep copy of partly build shard FI;
+ collect heap garbage.
+
+perhaps keep copy of partly build shard :
+ kopf;
+ storage info;
+ out (""10"Möchten Sie eine zusätzliche Kopie des SHard in dieser Version"13""10"");
+ IF yes ("aufheben", FALSE)
+ THEN TEXT CONST start :: subtext (hauptmodul namentyp, 1,
+ LENGTH hauptmodul namentyp - 1);
+ t := date;
+ put ("Gewünschter Name :"); out (start); editget (t); out (""13""10"");
+ t := start + t;
+ IF NOT exists (t) COR overwrite THEN copy (shard name, t) FI
+ FI.
+
+add ids :
+ int (new shard, offset id 4 + 2 (* ID5 *), actual installation nr);
+ int (new shard, offset id 4 + 4 (* ID6 *), id (6));
+ int (new shard, offset id 4 + 6 (* ID7 *), id (7)).
+
+overwrite :
+ IF yes ("Existierende Datei """ + t + """ überschreiben", FALSE)
+ THEN forget (t, quiet);
+ TRUE
+ ELSE FALSE FI.
+END PROC build shard;
+
+(******************** print configuration **********************************)
+
+PROC print configuration (DATASPACE CONST old shard ds, BOOL CONST on screen):
+ (* Ruft für alle Module, die in old shard ds und als Datei vorhanden sind
+ print configuration aus dem Paket modulkonfiguration auf.
+ Macht bei on screen nach jedem Modul eine Pause, andernfalls wird die
+ Ausgabe in einem Rutsch gemacht und mit indirect list auf den Drucker
+ umgeleitet.
+ *)
+ BOUND MODUL VAR old shard :: old shard ds;
+ THESAURUS VAR modules in old shard;
+ BOOL CONST old shard valid :: int (old shard, offset id 4) = id (4) AND
+ verbal identification ok;
+ enable stop;
+ IF NOT old shard valid
+ THEN errorstop ("Der SHard ist ungültig");
+ LEAVE print configuration
+ FI;
+ write head ("Anzeigen der Konfiguration des SHard");
+ put ("Bitte fassen Sie sich in Geduld");
+ get modules in shard (old shard, modules in old shard);
+ out (""4""13""10""); (* clear cout, line *)
+ IF on screen
+ THEN putline ("Nach jedem Modul eine Taste drücken.")
+ ELSE putline ("Die Ausgabe geht zum Drucker");
+ indirect list (TRUE);
+ putline ("***** SHardkonfiguration *****"); line;
+ FI;
+ disable stop;
+ do print configuration (old shard, modules in old shard, on screen);
+ IF is error THEN put error; pause; clear error FI;
+ enable stop;
+ IF NOT on screen THEN indirect list (FALSE) FI.
+
+verbal identification ok :
+ text (old shard, offset verbal identification, 16) =
+ "SHard Schoenbeck".
+END PROC print configuration;
+
+PROC do print configuration (MODUL CONST old shard,
+ THESAURUS CONST modules in old shard,
+ BOOL CONST on screen) :
+ INT VAR i;
+ TEXT VAR t;
+ enable stop;
+ FOR i FROM 1 UPTO highest entry (modules in old shard) REP
+ t := name (modules in old shard, i);
+ print configuration (old shard, t);
+ collect heap garbage;
+ IF on screen THEN pause FI
+ PER.
+END PROC do print configuration;
+
+(********************** modules in shard **********************************)
+
+PROC get modules in shard (MODUL CONST old shard,
+ THESAURUS VAR modules in old shard) :
+ (* Stellt einem THESAURUS zusammen, der aus den Namen aller in old shard
+ enthaltenen Module besteht (ohne Duplikate).
+ Dabei sind diejenigen Modulnamen, deren Treiber in old SHard nicht als
+ eingekettete Treiber vorkommen, im Resultat VOR den eingeketteten
+ (d.h. mit kleineren link-Nummern) zu finden, um die richtige
+ Konfigurationsreihenfolge vorschlagen zu können.
+ Es muß zuvor bereits einmal init modules list aufgerufen worden sein !
+ *)
+ INT VAR kanal;
+ REAL VAR p dtcb, p ccb;
+ TEXT VAR type, m name;
+ THESAURUS VAR simple :: empty thesaurus, chained :: empty thesaurus;
+ FOR kanal FROM 0 UPTO nr of channels total - 1 REP
+ cout (kanal);
+ p dtcb := sh dtcb offset (old shard, kanal);
+ p ccb := sh ccb offset (old shard, kanal);
+ look at this chain
+ PER;
+ invert chained thesaurus;
+ modules in old shard := what comes out when i let nameset do all the hard
+ work for me with a little trick and knowledge of implementation.
+
+look at this chain :
+ (* Das Verfahren ist auf den ersten Blick etwas kompliziert, spart aber
+ einiges an Kodeduplikation
+ *)
+ m name := "";
+ WHILE p dtcb <> 0.0 AND p ccb <> 0.0 REP
+ IF m name <> "" AND NOT (chained CONTAINS m name)
+ THEN insert (chained, m name) FI;
+ type := text (old shard, p dtcb, 4);
+ m name := module name (type);
+ p dtcb := unsigned (int (old shard, p ccb + 2.0)); (* verkettet *)
+ p ccb := unsigned (int (old shard, p ccb + 4.0));
+ PER;
+ IF m name <> "" THEN insert (simple, m name) FI.
+
+invert chained thesaurus :
+ (* bis jetzt sind bei mehrfachen Verkettungen die zuletzt eingeketteten
+ Treiber als erstes eingetragen, das darf jedoch nicht so bleiben
+ *)
+ INT VAR i;
+ THESAURUS VAR help :: empty thesaurus;
+ FOR i FROM highest entry (chained) DOWNTO 1 REP
+ insert (help, name (chained, i))
+ PER;
+ chained := help.
+
+what comes out when i let nameset do all the hard
+work for me with a little trick and knowledge of implementation :
+ (* Beware of false algebraic identities ! These are neither numbers nor
+ sets but lists (ordered and not duplicate-free)
+ *)
+ empty thesaurus + (simple - chained) + chained.
+END PROC get modules in shard;
+
+(*************** add bad sector table to shard ****************************)
+
+PROC add bad sector table to shard (INT CONST eumel type,
+ DATASPACE CONST shard ds,
+ BOOL CONST take from partition,
+ INT VAR bad sector count) :
+ (* Fügt einem SHard eine bad sector table hinzu oder ändert sie.
+ Ist noch keine vorhanden, so sollte der Zeiger 0 sein.
+ *)
+ ROW bad sector table size REAL VAR bst;
+ BOUND MODUL VAR new shard :: shard ds;
+ REAL VAR new shard length, offset bst;
+ INT VAR i;
+ enable stop;
+ IF take from partition
+ THEN put ("kopiere Tabelle :");
+ find bst in shard on partition
+ ELSE put ("Spur :");
+ get bad sector table (bst, bad sector count, eumel type);
+ FI;
+ eliminate bad sector table from shard (new shard);
+ new shard length := unsigned (int (new shard, offset shard length));
+ int (new shard, new shard length, bad sector count);
+ int (new shard, offset bad sector table pointer, unsigned (new shard length));
+ new shard length INCR 2.0;
+ IF take from partition
+ THEN copy bst from old to new shard
+ ELSE write bst to new shard FI;
+ int (new shard, offset shard length, unsigned (new shard length)).
+
+copy bst from old to new shard :
+ copy (old shard, offset bst + 2.0, new shard, new shard length,
+ bad sector count * 4);
+ cout (bad sector count * 4);
+ new shard length INCR real (bad sector count * 4).
+
+write bst to new shard :
+ FOR i FROM 1 UPTO bad sector count REP
+ cout (i);
+ enter bad sector low word
+ PER;
+ FOR i FROM 1 UPTO bad sector count REP
+ cout (i);
+ enter bad sector high word;
+ PER.
+
+find bst in shard on partition :
+ cout (0);
+ read file (ds, start of partition (eumel type) + 1.0, max sh length,
+ setup channel);
+ BOUND MODUL CONST old shard :: ds;
+ IF int (old shard, offset id 4) <> id (4)
+ THEN errorstop ("SHard auf Partition unbrauchbar") FI;
+ offset bst := unsigned (int (old shard, offset bad sector table pointer));
+ bad sector count := int (old shard, unsigned (offset bst)).
+
+enter bad sector low word :
+ int (new shard, new shard length, low word (bst [i]));
+ new shard length INCR 2.0.
+
+enter bad sector high word :
+ int (new shard, new shard length, high word (bst [i]));
+ new shard length INCR 2.0.
+END PROC add bad sector table to shard;
+
+(************ eliminate bad sector table from shard ****************)
+
+PROC eliminate bad sector table from shard (MODUL VAR shard) :
+ (* Entfernt die bad sector table (bst) aus dem shard falls sie sich am Ende
+ desselben befindet. Trägt korrekte neue Werte für den bst pointer und
+ shard laenge ein.
+ *)
+ REAL VAR shard length :: unsigned (int (shard, offset shard length)),
+ bst offset :: unsigned (int (shard, offset bad sector table pointer));
+ LET bst entry length = 4.0; (* bst entries sind Wort-Paare *)
+ IF bst offset = 0.0
+ THEN (* ist gar keine bst vorhanden, also schon prima eliminiert *)
+ ELIF bst ist am ende
+ THEN bst entfernen FI;
+ bst austragen.
+
+bst ist am ende :
+ bst offset + bst entry length * nr of bst entries + 2.0 =
+ shard length.
+
+nr of bst entries :
+ unsigned (int (shard, bst offset)).
+
+bst entfernen :
+ int (shard, offset shard length, unsigned (bst offset)).
+
+bst austragen :
+ int (shard, offset bad sector table pointer, 0).
+END PROC eliminate bad sector table from shard;
+
+(******************* installation nr *************************************)
+
+INT PROC installation nr :
+ actual installation nr
+END PROC installation nr;
+
+PROC installation nr (INT CONST new) :
+ actual installation nr := new
+END PROC installation nr;
+
+(*********************** Hilfsprozeduren **********************************)
+
+PROC kopf :
+ write head ("M o d u l - S H a r d Zusammenbau eines SHard").
+END PROC kopf;
+
+END PACKET setup eumel shardmontage;
+
diff --git a/system/setup/3.1/src/setup eumel 7: setupeumel b/system/setup/3.1/src/setup eumel 7: setupeumel
new file mode 100644
index 0000000..0504e97
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel 7: setupeumel
@@ -0,0 +1,1238 @@
+(*************************************************************************)
+(*** Hauptprogramm des setup-Eumel:Einstellen der EUMEL - Partitionen ***)
+(*** und SHard-Installation auf einer Festplatte. ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 07.04.89 ***)
+(*** I. Ley Version : 2.3 ***)
+(*** Anpassung an Modul-SHard : Lutz Prechelt, Karlsruhe ***)
+(*** -"- : Werner Metterhausen ***)
+(*** -"- : Martin Schönbeck ***)
+(*************************************************************************)
+(*** V 3.1 14.04.89 shard wird immer mit 'max sh size' geschriegen ***)
+(*** da mit 'ds pages' ggf teile fehlten, wenn innen ***)
+(*** unbenutzte pages (buffer) waren ***)
+(*** V 3.0 10.04.89 support fuer mehrere Laufwerke eingebaut ***)
+(*** ausgabe der module vor loeschen etc. entfernt ***)
+
+PACKET setup eumel DEFINES setup eumel, setup eumel endlos, version,
+show partition table:
+
+LET setup version = "Version 3.1";
+
+TEXT VAR stand :: "Stand : 18.04.89 (mit Modul-SHard Version 4.9)";
+
+PROC version (TEXT CONST vers): stand := vers END PROC version;
+
+PROC version: editget (stand) END PROC version;
+
+LET max partitions = 4,
+ max sh size = 128, (* Anzahl Bloecke *)
+ return = ""13"",
+ escape = ""27"";
+
+LET hauptmodul namentyp = "SHard *",
+ modul namentyp = "SHardmodul *",
+ sh name = "SHARD",
+ sh backup = "SHARD Sicherungskopie";
+
+ROW max partitions INT VAR part list;
+ROW max partitions INT VAR part type, part active,
+ part first track, part last track;
+ROW max partitions REAL VAR part start,
+ part size;
+
+ INT VAR zylinder,
+ startzeile tabelle :: 1,
+ startzeile menu :: 12,
+ active partition,
+ partitions,
+ partition, i, j, cx, cy, help;
+ TEXT VAR retchar,
+ meldung := "";
+ BOOL VAR testausgabe,
+ mit schreibzugriff := TRUE,
+ meldung eingetroffen := FALSE,
+ endlos :: FALSE,
+ at version;
+THESAURUS VAR minimum modulkollektion := empty thesaurus;
+DATASPACE VAR ds := nilspace;
+
+(************************* setup eumel endlos *****************************)
+
+PROC setup eumel endlos (BOOL CONST b) :
+ endlos := b;
+ IF endlos
+ THEN line;
+ putline ("Bitte geben Sie nun alle die Dateien an, die der Benutzer auf");
+ putline ("keinen Fall löschen darf. (Taste drücken)");
+ minimum modulkollektion := certain (all, emptythesaurus);
+ line (3);
+ putline ("Der setup eumel kann nun nach dem nächsten Aufruf nicht mehr ");
+ putline ("verlassen werden. ")
+ FI.
+END PROC setup eumel endlos;
+
+(******************** get/put actual partition data ************************)
+
+PROC get actual partition data :
+ get boot block;
+ zylinder := tracks;
+ FOR i FROM 1 UPTO max partitions REP
+ part type (i) := partition type (i);
+ part first track (i) := first track (i);
+ part last track (i) := last track (i);
+ part start (i) := partition start (i);
+ part size (i) := partition size (i);
+ part active (i) := partition word 0 (i);
+ IF partition active (i) THEN active partition := i FI
+ PER;
+ get number of installed partitions;
+ generate part list.
+
+get number of installed partitions :
+ partitions := 0;
+ FOR i FROM 1 UPTO max partitions REP
+ IF part type (i) <> 0 THEN partitions INCR 1 FI
+ PER.
+
+generate part list :
+ FOR i FROM 1 UPTO max partitions REP
+ IF part type (i) <> 0 THEN part list (i) := i
+ ELSE part list (i) := 0
+ FI;
+ PER;
+ schiebe nullen nach hinten;
+ sort part list.
+
+schiebe nullen nach hinten :
+ i := 1; INT VAR k := 0;
+ REP k INCR 1;
+ IF part list (i) = 0 THEN circle
+ ELSE i INCR 1
+ FI
+ UNTIL k = max partitions - 1 PER.
+
+circle :
+ FOR j FROM i UPTO max partitions - 1 REP
+ part list (j) := part list (j + 1)
+ PER;
+ part list (max partitions) := 0.
+
+sort part list :
+ FOR i FROM 2 UPTO partitions REP
+ FOR j FROM 1 UPTO i - 1 REP
+ IF part first track (part list (i)) < part first track (part list (j))
+ THEN tausche FI
+ PER
+ PER.
+
+tausche :
+ help := part list (i);
+ part list (i) := part list (j);
+ part list (j) := help.
+
+END PROC get actual partition data;
+
+PROC put actual partition data :
+ FOR i FROM 1 UPTO max partitions REP
+ IF partition exists (i) THEN put partition
+ ELSE clear partition (i)
+ FI;
+ PER;
+ IF mit schreibzugriff THEN put boot block FI.
+
+put partition :
+ IF is eumel (i) THEN partition type (i, part type (i));
+ first track (i, part first track (i));
+ last track (i, part last track (i));
+ partition start (i, part start (i));
+ partition size (i, part size (i))
+ FI;
+ partition word 0 (i, part active (i));
+ IF active partition = i
+ THEN partition active (i, TRUE)
+ ELSE partition active (i, FALSE)
+ FI.
+
+END PROC put actual partition data;
+
+(*************************** setup eumel ********************************)
+
+PROC setup eumel :
+ line; command dialogue (TRUE);
+ at version := yes ("System für AT", TRUE);
+ testausgabe := FALSE; (*yes ("Testversion", FALSE); *)
+ pruefe ob notwendige dateien vorhanden;
+ init modules list;
+ IF yes ("Leere Floppy für Systemsicherung eingelegt", FALSE)
+ THEN command dialogue (FALSE); save system; command dialogue (TRUE) FI;
+ IF NOT endlos THEN putline ("Verlassen mit ESC."); pause (40) FI;
+ terminal setup;
+ logo;
+ generate eumel.
+
+pruefe ob notwendige dateien vorhanden:
+ BOUND INT VAR y;
+ IF mit schreibzugriff THEN y := old (sh name);
+ y := old ("shget.exe");
+ y := old ("bootblock");
+ y := old ("configuration");
+ y := old ("AT-4.x")
+ FI.
+
+END PROC setup eumel;
+
+PROC generate eumel :
+ disable stop;
+ show partition table;
+ REP update table;
+ main menu;
+ action;
+ IF is error THEN fehler;
+ put line (error message);
+ put line ("Bitte betätigen Sie eine Taste !");
+ clear error;
+ pause;
+ IF mit schreibzugriff THEN terminal setup FI
+ FI
+ PER.
+
+action :
+ INT VAR choice;
+ clear error;
+ REP
+ cursor (cx, cy);
+ IF partitions < max partitions
+ THEN choice := get choice (0, max, retchar)
+ ELSE choice := get choice (2, max, 0, retchar)
+ FI;
+ IF escaped CAND NOT endlos THEN LEAVE generate eumel FI;
+ UNTIL retchar = return PER;
+ cl eop (1, startzeile menu - 1);
+ INT VAR unser kanal := channel;
+ SELECT choice OF
+ CASE 0 : programm ende
+ CASE 1 : create partition (TRUE)
+ CASE 2 : create partition (FALSE)
+ CASE 3 : activate partition
+ CASE 4 : delete partition
+ CASE 5 : delete partition table
+ CASE 6 : konfiguration anzeigen
+ CASE 7 : shard zusammenbauen
+ CASE 8 : modulkollektion aendern
+ CASE 9 : change drive
+
+ END SELECT;
+ continue (unser kanal).
+
+max :
+ 9.
+
+change drive:
+ cursor (1, startzeile menu);
+ put ("Bitte Laufwerksnummer angeben:");
+ get cursor (cx, cy);
+ put (" 0 - 3");
+ REP cursor (cx, cy);
+ INT VAR drive := get choice (0, 3, retchar);
+ IF sure escaped THEN LEAVE change drive FI;
+ UNTIL NOT escaped PER;
+ setup channel (28-drive);
+ show partition table.
+
+
+programm ende :
+ cursor (1, startzeile menu);
+ IF keine partition aktiv
+ THEN IF trotz warnung beenden THEN eumel beenden FI
+ ELSE IF yes ("Wollen Sie die Partitionierung Ihrer Festplatte beenden", FALSE)
+ THEN eumel beenden
+ FI FI.
+
+keine partition aktiv : active partition = 0.
+
+trotz warnung beenden :
+ put line ("ACHTUNG : Es ist keine Partition aktiv gesetzt !");
+ put line (" Sie können daher nicht von der Festplatte booten !");
+ line;
+ yes ("Wollen Sie trotzdem die Partitionierung der Festplatte beenden", FALSE).
+
+eumel beenden :
+ cl eop (1, startzeile menu - 1);
+ cursor (1, startzeile menu + 3);
+ shutup; terminal setup;
+ logo;
+ show partition table.
+
+shard zusammenbauen :
+ cl eop (1, startzeile menu);
+ IF yes ("Wollen Sie Ihren SHard neu konfigurieren", FALSE)
+ THEN shard sichern und vorlage beschaffen;
+
+ IF NOT is error THEN build shard (ds) FI;
+ IF is error OR NOT exists (sh name)
+
+ THEN forget (sh name, quiet); rename (sh backup, sh name);
+ putline ("Zusammenbau fehlgeschlagen. Alter SHard erhalten.");
+ pause (300);
+ FI;
+ forget (sh backup, quiet); forget (ds);
+ show partition table
+ FI.
+
+shard sichern und vorlage beschaffen :
+ forget (sh backup, quiet);
+ IF exists (shname)
+ THEN copy (sh name, sh backup);
+ FI;
+ forget (ds);
+ line;
+ IF yes (""3"Ist in einer existierenden Eumel-Partition ein SHard installiert,
+"13""10"der als Vorlage dienen soll", FALSE)
+ THEN INT VAR vorlage :: 69;
+ editget (1, startzeile menu + 4, "Partitiontyp: ", vorlage);
+ (* Das sollte man mal noch schöner machen !!! *)
+ read file (ds, start of partition (vorlage) + 1.0, max sh size,
+ setup channel)
+ ELSE ds := old (sh name) FI.
+
+
+konfiguration anzeigen :
+ hole anzuzeigenden ds;
+ line;
+ print configuration (ds, NOT yes ("Auf dem Drucker ausgeben", FALSE));
+ show partition table.
+
+hole anzuzeigenden ds:
+ forget (ds);
+ line;
+ IF yes ("Soll ein SHard aus einer Partition angezeigt werden", TRUE)
+ THEN INT VAR anzeige :: 69;
+ editget (1, startzeile menu + 4, "Partitiontyp: ", anzeige);
+ (* Das sollte man mal noch schöner machen !!! *)
+ read file (ds, start of partition (anzeige) + 1.0, max sh size,
+ setup channel)
+ ELSE ds := old (ONE ((all LIKE hauptmodul namentyp) + "SHARD")) FI.
+
+
+modulkollektion aendern :
+ THESAURUS VAR th;
+ TEXT VAR x :: "SHard";
+ INT VAR i ;
+ page;
+ th := (all LIKE hauptmodul namentyp) + (all LIKE modul namentyp) +
+ (all LIKE sh name) ;
+ (* Diese Ausgabe macht leider den Bildschirmaufbau kaputt *)
+ (* mit dem Erfolg, daß man dann nicht mehr sieht, was man *)
+ (* ankreuzt, deshalb auskommentiert *)
+ (*******
+ putline(" Alle SHards :");
+ line;
+ FOR i FROM 1 UPTO highest entry(th)
+ REP
+ putline(name(th,i))
+ PER;
+ *******)
+ putline(" Modulkollektion ändern");
+ line;
+ IF yes ("Wollen Sie irgendwelche Module löschen", FALSE)
+ THEN th := (all LIKE hauptmodul namentyp) + (all LIKE modul namentyp) +
+ (all LIKE sh name) - minimum modulkollektion;
+ forget (certain (th, emptythesaurus));
+ ELIF yes ("Wollen Sie Module vom Archiv holen", FALSE)
+ THEN put ("Archivname:"); editget (x); line;
+ archive (x);
+ th := ALL archive LIKE modul namentyp;
+ fetch (certain (th, emptythesaurus), archive);
+ release (archive)
+ FI;
+ init modules list;
+ show partition table.
+
+
+END PROC generate eumel;
+
+
+PROC show partition table :
+ IF NOT mit schreibzugriff THEN get actual partition data FI;
+ headline;
+ devide table;
+ columns;
+ underlines;
+ rows;
+ downline.
+
+head line :
+ cl eop (1, startzeile tabelle);
+ put center (startzeile tabelle, "Aktuelle Partitions - Tabelle", TRUE).
+
+devide table :
+ FOR i FROM 1 UPTO 8
+ REP
+ cursor (45, startzeile tabelle + i); out (inverse (""))
+ PER.
+
+columns :
+ cursor ( 1, startzeile tabelle + 2);
+ out ("Nr. System Typ Zustand Grösse Anfang Ende");
+ cursor (48, startzeile tabelle + 2);
+ out ("Platte : Zyl. / KB").
+
+underlines :
+ cursor ( 1, startzeile tabelle + 3);
+ out ("--------------------------------------------");
+ cursor (47, startzeile tabelle + 3);
+ out ("------------------------------").
+
+rows :
+ FOR i FROM 1 UPTO max partitions
+ REP cursor (2, startzeile tabelle + 3 + i);
+ put (text (i) + " :")
+ PER.
+
+downline :
+ put center (startzeile menu - 3, " EUMEL Installationssystem " + setup version
+ + " (IBM PC/" + rechner typ
+ + " und kompatible Rechner) ", TRUE);
+ put center (startzeile menu - 2, stand, TRUE).
+
+rechner typ :
+ IF at version THEN "AT"
+ ELSE "XT"
+ FI.
+
+END PROC show partition table;
+
+PROC main menu :
+ biete auswahl an;
+ IF meldung eingetroffen THEN melde FI;
+ IF testausgabe THEN ausgabe fuer test FI.
+
+ausgabe fuer test :
+ testrahmen;
+ test out.
+
+testrahmen :
+ FOR i FROM startzeile menu - 1 UPTO startzeile menu + 9
+ REP
+ cl eol (45, i);
+ put (inverse (""))
+ PER;
+ cursor (52, startzeile menu);
+ put ("Ecke für Test-Output");
+ cursor (52, startzeile menu).
+
+test out :
+ FOR i FROM 1 UPTO max partitions
+ REP
+ cursor (52, startzeile menu + 1 + i);
+ put (text (i) + ":");
+ put (part type (i));
+ put (part first track (i));
+ put (part last track (i));
+ IF active partition = i THEN put ("aktiv")
+ ELSE put ("inaktiv")
+ FI;
+ PER.
+
+melde :
+ cursor (1, 24);
+ put (inverse ("Meldung :"));
+ put (meldung);
+ meldung eingetroffen := FALSE.
+
+biete auswahl an :
+ cl eop (1, startzeile menu - 1); line;
+ IF partitions < max partitions
+ THEN putline (" EUMEL - Partition einrichten .............. 1")
+ ELSE line;
+ putline (" EUMEL - Partition")
+ FI;
+ cursor (20, startzeile menu + 1);
+ putline ("erneuern (Neuer SHard) .. 2");
+ putline (" aktivieren .............. 3");
+ putline (" löschen ................. 4");
+ putline (" Partitionstabelle löschen ................. 5");
+ putline (" SHard-Konfiguration anzeigen .............. 6");
+ putline (" SHard konfigurieren ....................... 7");
+ putline (" SHardmodule laden oder löschen ............ 8");
+ putline (" Bearbeitetes Laufwerk wechseln ............ 9");
+ putline (" SETUP-EUMEL beenden ....................... 0");
+ putline ("-----------------------------------------------");
+ put (" Ihre Wahl >>");
+ get cursor (cx, cy).
+
+END PROC main menu;
+
+PROC update table :
+ IF mit schreibzugriff THEN get actual partition data FI;
+ FOR i FROM 1 UPTO partitions REP update partition PER;
+ FOR i FROM partitions + 1 UPTO max partitions REP rubout partition PER;
+ zeige plattengroesse;
+ IF active partition = 0 THEN meldung := "ACHTUNG : Es ist keine Partition aktiv gesetzt !";
+ meldung eingetroffen := TRUE
+ FI.
+
+update partition :
+ partition := part list (i);
+ show partition.
+
+rubout partition :
+ cursor (5, startzeile tabelle + 3 + i);
+ out (" ").
+
+show partition :
+ cursor (5, startzeile tabelle + 3 + i);
+ put (name + type + zustand + groesse + startspur + endspur).
+
+name : subtext (subtext (part name, 1, 7)
+ + " ", 1, 8).
+
+type : text (part type (partition), 5) + " ".
+
+zustand : IF active partition = partition THEN (" aktiv ")
+ ELSE (" ")
+ FI.
+
+startspur : " " + text (part first track (partition), 5).
+endspur : text (part last track (partition), 6).
+groesse : text (part groesse, 5).
+
+zeige plattengroesse :
+ put gesamt;
+ put noch freie;
+ put maximaler zwischenraum.
+
+put maximaler zwischenraum :
+ cursor (48, startzeile tabelle + 6);
+ put ("gr. Lücke : " + text (maximaler zwischenraum, 5) + " / "
+ + kilobyte(maximaler zwischenraum)).
+
+put gesamt :
+ cursor (48, startzeile tabelle + 4);
+ put ("Gesamt : " + text (zylinder, 5) + " / "
+ + kilobyte(zylinder)).
+
+put noch freie :
+ cursor (48, startzeile tabelle + 5);
+ put ("Frei : " + text (freie zylinder, 5) + " / "
+ + kilobyte( freie zylinder)).
+
+END PROC update table;
+
+
+TEXT PROC kilobyte (INT CONST zylinderzahl):
+ TEXT VAR kb;
+ kb := text(round(real(zylinderzahl) * real(heads) * real(sectors) * 0.512,0));
+ subtext(kb,1,length(kb)-2)
+
+END PROC kilobyte;
+
+
+PROC create partition (BOOL CONST partition is new) :
+ IF NOT partition is new
+ THEN renew partition
+ ELIF freie part number gefunden CAND noch platz uebrig
+ THEN new partition
+ ELSE kein platz mehr FI.
+
+kein platz mehr :
+ fehler;
+ put ("Es kann keine neue Partition mehr eingerichtet werden.");
+ pause (300).
+
+noch platz uebrig : freie zylinder > 0.
+
+freie part number gefunden :
+ IF partitions < max partitions THEN suche nummer;
+ TRUE
+ ELSE FALSE
+ FI.
+
+suche nummer :
+ partition := 0;
+ REP partition INCR 1 UNTIL part type (partition) = 0 PER.
+
+new partition :
+ cl eop (1, startzeile menu);
+ IF yes ("Neue EUMEL - Partition einrichten", FALSE)
+ THEN INT VAR alte aktive partition := active partition;
+ IF NOT partition exists (partition)
+ THEN IF enter partition spezifikations
+ THEN IF mit schreibzugriff THEN check part and install FI
+ FI;
+ ELSE keine freie partition
+ FI FI.
+
+renew partition :
+ cl eop (1, startzeile menu);
+ IF yes ("Neuen SHard auf bestehende EUMEL - Partition schreiben", FALSE)
+ THEN enter part number;
+ IF mit schreibzugriff THEN check part and install FI
+ FI.
+
+enter part number :
+ put ("Welche Partition wollen Sie erneuern :");
+ get cursor (cx, cy);
+ put (" Abbruch mit <ESC>");
+ REP
+ REP cursor (cx, cy);
+ partition := get choice (1, 4, retchar);
+ IF sure escaped THEN LEAVE create partition FI;
+ partition := part list (partition)
+ UNTIL NOT escaped PER;
+ IF NOT (partition exists (partition) AND is eumel (partition))
+ THEN fehler; put ("Keine EUMEL - Partition");
+ pause (300); cl eop (1, 20);
+ FI
+ UNTIL partition exists (partition) AND is eumel (partition) PER.
+
+check part and install:
+ IF partition is new THEN put actual partition data FI;
+ IF testausgabe THEN put ("Keine Überprüfung schlechter Sektoren, da Testversion !")
+ ELSE trage schlechte sektoren ein;
+ FI;
+ IF is error AND partition is new
+ THEN active partition := alte aktive partition;
+ rubout partition;
+ LEAVE check part and install
+ ELIF NOT is error
+ THEN line;
+ put ("Shard wird auf die Partition geschrieben..."); line (2);
+ bringe shard auf platte (part type (partition));
+ ELSE line;
+ putline ("Fehler aufgetreten. Partition unverändert")
+ FI;
+ put ("Bitte betätigen Sie eine Taste !");
+ loesche eingabepuffer;
+ pause.
+
+trage schlechte sektoren ein:
+ INT VAR anzahl schlechter sektoren;
+ line (2);
+ putline ("Überprüfen der Partition nach schlechten Sektoren.");
+ add bad sector table to shard (part type (partition), old (sh name),
+ NOT partition is new, anzahl schlechter sektoren);
+ line;
+ IF NOT is error THEN put ("Ich habe " + bs zahl + " gefunden.") FI.
+
+bs zahl:
+ IF anzahl schlechter sektoren = 0
+ THEN "keine schlechten Sektoren"
+ ELIF anzahl schlechter sektoren > 1
+ THEN text (anzahl schlechter sektoren) + " schlechte Sektoren"
+ ELSE "einen schlechten Sektor"
+ FI.
+
+keine freie partition :
+ fehler;
+ put line ("Sie können nur auf freien Partitionen 'EUMEL' einrichten.");
+ put ("Die Partition " + text (partition) + " ist bereits mit einem System belegt !");
+ pause (300).
+
+END PROC create partition;
+
+BOOL PROC enter partition spezifikations :
+ cl eol (60, startzeile menu); put ("Abbruch mit <ESC>");
+ cl eol (1, startzeile menu + 2);
+ put ("Typ : EUMEL,");
+ INT VAR old end := part last track (partition);
+ enter part size;
+ enter part first track;
+ put end track;
+ cl eol (60, startzeile menu);
+ IF NOT eingaben ok THEN LEAVE enter partition spezifikations WITH FALSE FI;
+ cl eol (1, startzeile menu + 4);
+ part first track (partition) := int (start);
+ part last track (partition) := int (start) + int (size) - 1;
+ part start (partition) := first usable sector;
+ part size (partition) := first sector behind partition -
+ part start (partition);
+ active partition := partition;
+ part type (partition) := kleinste freie eumel nummer;
+ add to part list;
+ TRUE.
+
+eingaben ok :
+ cl eop (1, startzeile menu + 4);
+ yes ("Sind die Partitionsangaben korrekt", FALSE).
+
+enter part size :
+ get cursor (cx, cy);
+ REP
+ REP cursor (cx, cy);
+ put ("Welche Grösse :");
+ TEXT VAR size := groessenvorschlag;
+ loesche eingabepuffer;
+ editget (size, escape, "", retchar);
+ IF sure escaped
+ THEN LEAVE enter partition spezifikations WITH FALSE
+ FI
+ UNTIL NOT escaped PER;
+ IF NOT size ok THEN falsche groesse FI
+ UNTIL size ok AND not too big PER;
+ cl eol (1, y + 1);
+ cl eol (1, y + 2);
+ cl eol (cx, cy);
+ put ("Grösse : " + size + ";").
+
+size ok :
+ NOT size greater maxint
+ CAND size positiv
+ AND desired size <= maximaler zwischenraum.
+
+not too big:
+ INT VAR x,y;
+ get cursor(x,y);
+ IF real(kilobyte(int(size))) >= 16196.0
+ THEN line;
+ putline("Eine Partition grösser 16 MB ist nur bei einer + Version sinnvoll !");
+ yes("Eingabe korrekt",FALSE)
+ ELSE TRUE
+ FI.
+
+size greater maxint :
+ length (size) >= 5.
+
+size positiv :
+ desired size > 0.
+
+falsche groesse :
+ fehler;
+ put line ("Es kann keine Partition mit " + size + " Zylindern eingerichtet werden !");
+ IF NOT size greater maxint CAND size positiv
+ THEN put ("Die grösste zusammenhängende Anzahl Zylinder ist "
+ + text (maximaler zwischenraum) + ".")
+ ELSE put ("Bitte eine positive Grösse angeben !")
+ FI.
+
+groessenvorschlag :
+ text (maximaler zwischenraum).
+
+enter part first track :
+ get cursor (cx, cy);
+ REP
+ REP cursor (cx, cy);
+ put ("Start - Zylinder der Partition :");
+ TEXT VAR start := startvorschlag;
+ loesche eingabepuffer;
+ editget (start, escape, "", retchar);
+ IF sure escaped THEN part last track (partition) := old end;
+ LEAVE enter partition spezifikations WITH FALSE
+ FI
+ UNTIL NOT escaped PER;
+ IF NOT start ok THEN falscher start FI
+ UNTIL start ok PER;
+ cl eol (cx, cy);
+ put ("Start : " + start + ";").
+
+put end track :
+ put ("Ende : " + text (int (start) + int (size) - 1)).
+
+start ok :
+ length (start) < 5
+ CAND enough room
+ AND NOT in existing partition
+ AND NOT out of volume.
+
+out of volume : desired start > zylinder OR desired start < 0.
+
+in existing partition :
+ IF partitions = 0 THEN FALSE
+ ELSE i := 0;
+ REP
+ i INCR 1
+ UNTIL start of part i > desired start
+ OR last partition
+ OR error found PER;
+ IF error found THEN TRUE ELSE FALSE FI
+ FI.
+
+error found :
+ part index <> i AND
+ (start of part i <= desired start AND end spur i >= desired start).
+
+part index :
+ 0.
+
+desired start : int (start).
+
+start of part i : part first track (part list (i)).
+
+last partition : i = partitions.
+
+enough room :
+ desired start + desired size <= begin of next partition.
+
+desired size : int (size).
+
+begin of next partition :
+ IF partitions = 0 THEN zylinder
+ ELSE i := 0;
+ REP
+ i INCR 1;
+ UNTIL start of part i > desired start
+ OR last partition PER;
+ IF start of part i > desired start THEN start of part i
+ ELSE zylinder
+ FI
+ FI.
+
+falscher start :
+ fehler;
+ put ("Auf Zylinder " + start);
+ put ("kann keine Partition der Grösse " + size);
+ put ("beginnen !").
+
+startvorschlag :
+ text (best start position).
+
+best start position :
+ IF partitions = 0 THEN 0
+ ELSE best start spur vor und zwischen den partitionen
+ FI.
+
+best start spur vor und zwischen den partitionen :
+ INT VAR best start := 0, min size := zylinder;
+ FOR i FROM 0 UPTO partitions
+ REP
+ IF platz genug zwischen i und i plus 1 AND kleiner min size
+ THEN min size := platz zwischen i und i plus 1;
+ best start := start des zwischenraums
+ FI
+ PER;
+ best start.
+
+start des zwischenraums :
+ end spur i + 1.
+
+end spur i :
+ IF i = 0 THEN -1
+ ELSE part last track (part list (i))
+ FI.
+
+platz zwischen i und i plus 1 :
+ part first track i plus 1 - (end spur i + 1).
+
+part first track i plus 1 :
+ IF i = partitions THEN zylinder
+ ELSE part first track (part list (i + 1))
+ FI.
+
+platz genug zwischen i und i plus 1 :
+ platz zwischen i und i plus 1 >= int (size).
+
+kleiner min size : platz zwischen i und i plus 1 < min size.
+
+first usable sector:
+ IF int (start) = 0
+ THEN 1.0
+ ELSE real (heads * sectors) * real (start)
+ FI.
+
+first sector behind partition:
+ real (heads * sectors) * (real(start) + real (size)).
+
+kleinste freie eumel nummer :
+ IF partitions = 0 THEN 69
+ ELSE search for part type (69)
+ FI.
+
+END PROC enter partition spezifikations;
+
+INT PROC search for part type (INT CONST minimum) :
+ IF minimum exists THEN search for part type (minimum + 1)
+ ELSE minimum
+ FI.
+
+minimum exists :
+ BOOL VAR exists := FALSE;
+ INT VAR i;
+ FOR i FROM 1 UPTO partitions REP
+ IF part type (part list (i)) = minimum THEN exists := TRUE FI
+ PER;
+ exists.
+
+END PROC search for part type;
+
+PROC bringe shard auf platte (INT CONST eumel type):
+ IF mit schreibzugriff THEN
+ enable stop;
+ INT CONST old session :: session;
+ fixpoint;
+ IF session <> old session
+ THEN errorstop ("SHard auf Platte schreiben im RERUN !") FI;
+ write file ("shget.exe", start der eumel partition, 1, setup channel);
+ write file (sh name, start der eumel partition + 1.0,
+ max sh size, setup channel)
+ FI.
+
+start der eumel partition:
+ start of partition (eumel type).
+END PROC bringe shard auf platte;
+
+
+PROC add to part list :
+ IF part list leer THEN part list (1) := partition
+ ELIF neuer start vor letzter partition THEN fuege ein
+ ELSE haenge an
+ FI;
+ partitions INCR 1.
+
+part list leer : partitions = 0.
+
+neuer start vor letzter partition :
+ part first track (partition) < part first track (part list (partitions)).
+
+haenge an : part list (partitions + 1) := partition.
+
+fuege ein :
+ suche erste partition die spaeter startet;
+ schiebe restliste auf;
+ setze partition ein.
+
+suche erste partition die spaeter startet :
+ i := 0;
+ REP i INCR 1
+ UNTIL part first track (part list (i)) > part first track (partition) PER.
+
+schiebe restliste auf :
+ FOR j FROM partitions DOWNTO i
+ REP
+ part list (j + 1) := part list (j)
+ PER.
+
+setze partition ein :
+ part list (i) := partition.
+
+END PROC add to part list ;
+
+INT PROC maximaler zwischenraum :
+ IF partitions = 0 THEN zylinder
+ ELSE max (maximaler platz vor und zwischen den partitionen,
+ platz hinter letzter partition)
+ FI.
+
+maximaler platz vor und zwischen den partitionen :
+ help := platz vor erster partition;
+ FOR i FROM 1 UPTO partitions - 1
+ REP
+ help := max (help, begin of part i plus 1 - end of part i - 1)
+ PER;
+ help.
+
+platz vor erster partition :
+ part first track (part list (1)).
+
+platz hinter letzter partition :
+ zylinder - part last track (part list (partitions)) - 1.
+
+begin of part i plus 1 :
+ part first track (part list (i + 1)).
+
+end of part i :
+ part last track (part list (i)).
+
+END PROC maximaler zwischenraum;
+
+PROC activate partition :
+ enter part number;
+ IF NOT escaped THEN set partition active FI.
+
+set partition active :
+ IF yes ("Partition mit Typnummer " + text (part type (partition)) + " aktivieren", FALSE)
+ THEN active partition := partition;
+ put actual partition data
+ FI.
+
+enter part number :
+ cursor (60, startzeile menu); put ("Abbruch mit <ESC>");
+ cursor ( 1, startzeile menu);
+ put ("Welche Partition wollen Sie aktivieren :");
+ get cursor (cx, cy);
+ REP
+ REP cursor (cx, cy);
+ partition := get choice (1, 4, retchar);
+ IF sure escaped THEN LEAVE activate partition FI;
+ partition := part list (partition)
+ UNTIL NOT escaped PER;
+ IF NOT partition exists (partition) THEN fehler melden FI
+ UNTIL partition exists (partition) PER;
+ cl eol (60, startzeile menu);
+ cl eop (1, cy + 2).
+
+fehler melden :
+ partition gibt es nicht.
+
+partition gibt es nicht :
+ fehler;
+ put ("Diese Partition gibt es nicht.").
+
+END PROC activate partition;
+
+PROC delete partition :
+ enter part number;
+ IF NOT escaped THEN
+ IF yes ("Partition mit Typnummer " + text (part type (partition)) + " löschen", FALSE)
+ AND ganz sicher
+ THEN rubout partition
+ FI FI.
+
+enter part number :
+ cursor (60, startzeile menu); put ("Abbruch mit <ESC>");
+ cursor ( 1, startzeile menu);
+ put ("Welche Partition wollen Sie löschen :");
+ get cursor (cx, cy);
+ REP
+ REP cursor (cx, cy);
+ partition := get choice (1, 4, retchar);
+ IF sure escaped THEN LEAVE delete partition FI;
+ partition := part list (partition)
+ UNTIL NOT escaped PER;
+ IF NOT (partition exists (partition) AND is eumel (partition)) THEN fehler melden FI
+ UNTIL partition gueltig AND is eumel (partition) PER;
+ cl eol (60, startzeile menu);
+ cl eop (1, cy + 2).
+
+fehler melden :
+ IF NOT partition exists (partition) THEN partition gibt es nicht
+ ELSE keine eumel partition
+ FI.
+
+partition gibt es nicht :
+ fehler;
+ put ("Diese Partition gibt es nicht.").
+
+ganz sicher :
+ line;
+ yes ("Sind Sie sich ganz sicher", FALSE).
+
+END PROC delete partition;
+
+PROC delete partition table :
+ cursor ( 1, startzeile menu + 1);
+ put ("Es gehen ALLE Daten verloren, die sich auf Ihrer Platte befinden !");
+ line (2);
+ IF yes ("Wollen Sie wirklich die ganze Partitionstabelle löschen", FALSE)
+ THEN line;
+ IF yes ("Sind Sie sich ganz sicher", FALSE)
+ THEN loesche ganze tabelle
+ FI FI.
+
+loesche ganze tabelle :
+ FOR i FROM 1 UPTO max partitions
+ REP part type (i) := 0;
+ part first track (i) := 0;
+ part last track (i) := 0;
+ part start (i) := 0.0;
+ part size (i) := 0.0;
+ part list (i) := 0
+ PER;
+ partitions := 0;
+ active partition := 0;
+ IF mit schreibzugriff THEN clear partition table (-3475) FI.
+
+END PROC delete partition table;
+
+PROC rubout partition :
+ part type (partition) := 0;
+ part first track (partition) := 0;
+ part last track (partition) := 0;
+ IF active partition = partition THEN active partition := 0 FI;
+ del from part list;
+ put actual partition data.
+
+del from part list :
+ search for partition in part list;
+ delete it and set highest to 0;
+ partitions DECR 1.
+
+search for partition in part list :
+ i := 0;
+ REP i INCR 1 UNTIL part list (i) = partition PER.
+
+delete it and set highest to 0 :
+ FOR j FROM i UPTO partitions - 1
+ REP
+ part list (j) := part list (j + 1)
+ PER;
+ part list (partitions) := 0.
+
+END PROC rubout partition;
+
+INT PROC get choice (INT CONST von, bis, TEXT VAR retchar):
+ get choice (von, bis, von, retchar)
+END PROC get choice;
+
+INT PROC get choice (INT CONST von, bis, zusatz, TEXT VAR retchar):
+ LET return = ""13"",
+ escape = ""27"",
+ left = ""8"";
+ TEXT VAR buffer;
+ INT VAR cx, cy;
+ get cursor (cx, cy); out (" " + left);
+ REP
+ REP
+ cursor (cx, cy); buffer := incharety;
+ UNTIL input ok OR buffer = escape PER;
+ IF buffer = escape THEN retchar := escape;
+ LEAVE get choice WITH 0
+ FI;
+ out (buffer);
+ leseschleife bis left or ret;
+ IF retchar = left THEN out (left + " ") FI;
+ IF retchar = escape THEN LEAVE get choice WITH 0 FI
+ UNTIL retchar = return OR retchar = escape PER;
+ int (buffer).
+
+input ok : (buffer >= text (von) AND buffer <= text (bis)) OR buffer = text (zusatz).
+
+leseschleife bis left or ret:
+ REP
+ inchar (retchar)
+ UNTIL retchar = return OR retchar = left OR retchar = escape PER.
+
+END PROC get choice;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, BOOL CONST inverse):
+ put center (zeile, t, 80, inverse);
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ put center (zeile, t, gesamtbreite, FALSE);
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite,
+ BOOL CONST inverse):
+ IF inverse
+ THEN cursor (1, zeile);
+ out (""15"");
+ gesamtbreite - 2 TIMESOUT " ";
+ FI;
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t);
+ IF inverse
+ THEN cursor (gesamtbreite - 1, zeile);
+ out (""14"");
+ FI
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
+INT PROC partition groesse (INT CONST part) :
+ part last track (part) - part first track (part) + 1
+END PROC partition groesse;
+
+BOOL PROC is eumel (INT CONST partition) :
+ part type (partition) >= 69 AND part type (partition) <= 72
+END PROC is eumel;
+
+BOOL PROC partition exists (INT CONST partition) :
+ IF partition > 0 AND partition <= max partitions
+ THEN part type (partition) <> 0
+ ELSE FALSE
+ FI
+END PROC partition exists;.
+
+part groesse : partition groesse (partition).
+
+part name :
+ SELECT part type (partition) OF
+ CASE 1, 4 : "DOS"
+ CASE 69, 70, 71, 72 : "EUMEL"
+ OTHERWISE text (part type (partition))
+ END SELECT.
+
+escaped : retchar = escape.
+
+sure escaped :
+ IF escaped THEN cl eop (1, 20); cursor (1, 22);
+ yes ("Vorgang abbrechen", TRUE)
+ ELSE FALSE
+ FI.
+
+partition gueltig :
+ partition > 0
+ AND partition <= max partitions.
+
+freie zylinder :
+ zylinder - belegte zylinder.
+
+belegte zylinder :
+ help := 0;
+ FOR i FROM 1 UPTO partitions REP
+ help INCR partition groesse (part list (i))
+ PER;
+ help.
+
+keine eumel partition :
+ fehler;
+ put line ("Sie dürfen mit diesem System nur 'EUMEL' - Partitionen manipulieren.");
+ put ("Die Partition " + text (partition) + " ist nicht vom Typ 'EUMEL' !").
+
+fehler :
+ cl eop (1, 20);
+ put (""7"" + inverse ("FEHLER :")); line (2).
+
+loesche eingabepuffer :
+ REP UNTIL incharety = "" PER. ;
+
+PROC logo :
+ page;
+ put center (3, "S E T U P - E U M E L "+ setup version);
+ put center (5, "für");
+ put center (7, "M O D U L - S H A R D");
+ put center (13, "======================================================");
+ put center (15, "(für IBM " + typ + " und Kompatible)");
+ put center (20, stand);
+ pause (50);
+ collect heap garbage.
+
+typ :
+ IF at version THEN "AT" ELSE "XT" FI.
+END PROC logo;
+
+END PACKET setup eumel;
+
+setup eumel
+
+
+
+
+
+
+
diff --git a/system/setup/3.1/src/setup eumel erzeugen b/system/setup/3.1/src/setup eumel erzeugen
new file mode 100644
index 0000000..7a50898
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel erzeugen
@@ -0,0 +1,15 @@
+check off;
+insert("setup eumel -1: mini eumel dummies");
+insert("setup eumel 0: /S");
+insert("setup eumel 1: basisoperationen");
+insert("setup eumel 2: modulzugriffe");
+insert("setup eumel 3: modulkonfiguration");
+insert("setup eumel 5: partitionierung");
+insert("setup eumel 6: shardmontage");
+insert("setup eumel 7: setupeumel");
+putline("Jetzt 'setup eumel endlos' nicht vergessen");
+
+
+
+
+
diff --git a/system/setup/3.1/src/setup eumel erzeugen-M b/system/setup/3.1/src/setup eumel erzeugen-M
new file mode 100644
index 0000000..ad85301
--- /dev/null
+++ b/system/setup/3.1/src/setup eumel erzeugen-M
@@ -0,0 +1,14 @@
+check off;
+insert("setup eumel 0: /M");
+insert("setup eumel 1: basisoperationen");
+insert("setup eumel 2: modulzugriffe");
+insert("setup eumel 3: modulkonfiguration");
+insert("setup eumel 5: partitionierung");
+insert("setup eumel 6: shardmontage");
+insert("setup eumel 7: setupeumel");
+putline("Jetzt 'setup eumel endlos' nicht vergessen");
+
+
+
+
+
diff --git a/system/setup/3.1/src/shget.exe b/system/setup/3.1/src/shget.exe
new file mode 100644
index 0000000..902d697
--- /dev/null
+++ b/system/setup/3.1/src/shget.exe
Binary files differ
diff --git a/system/std.graphik/1.8.7/doc/Altes Handbuch - Teil 10 - Graphik b/system/std.graphik/1.8.7/doc/Altes Handbuch - Teil 10 - Graphik
new file mode 100644
index 0000000..36fa31e
--- /dev/null
+++ b/system/std.graphik/1.8.7/doc/Altes Handbuch - Teil 10 - Graphik
@@ -0,0 +1,831 @@
+#type ("trium10")##limit (13.5)#
+#block##start(2.5,2.5)##pagelength(21.0)##pagenr("%",418)##setcount(22)#
+#headeven#
+% EUMEL-Benutzerhandbuch
+
+
+
+#end#
+#headodd#
+ TEIL 10: Graphik %
+
+
+
+#end#
+#type("triumb14")#
+#ib(9)##center#TEIL 10: Graphik#ie(9)#
+#type("trium10")#
+#free(2.0)#
+#on("bold")##ib(9)##type("triumb14")#1. Übersicht#ie(9)#
+#type("trium10")#
+
+ #limit(12.0)##on("italics")#Dieser Teil des Benutzer-Handbuchs beschreibt die Graphik-
+ Möglichkeiten des EUMEL-Systems. Die Graphik-Pakete ge­
+ hören nicht zum EUMEL-Standard, sondern sind Anwender­
+ pakete, die im Quellcode ausgeliefert und von jeder Installation
+ in das System aufgenommen werden können. Unter Umständen
+ müssen Programme erstellt werden, die die Anpassungen für
+ spezielle graphische Geräte einer Installation vornehmen.
+#limit(13.5)##off("italics")#
+
+Das Graphik-System ermöglicht es, durch ELAN-Programme geräteunab­
+hängige Informationen für Zeichnungen ("#ib#Graphiken#ie#") zu erstellen. Die Graphik
+erzeugenden Programme brauchen dabei keine gerätespezifischen Größen sowie
+gerätespezifischen Unterprogramme zu enthalten. Sie befassen sich somit
+ausschließlich mit der Erzeugung der problemorientierten Information für die
+Konstruktion einer Zeichnung. Nach der geräteunabhängigen Erzeugung einer
+Graphik kann diese auf unterschiedlichen Geräten ausgegeben werden (z.B. erst
+auf einem Terminal zur Kontrolle und dann auf einem Plotter).
+
+Die EUMEL-Graphik umfaßt zwei- und dreidimensionale Graphik. Dabei
+entspricht die Y-Achse bei der zweidimensionalen Graphik der Z-Achse (Höhe)
+bei der dreidimensionalen Graphik. Im dreidimensionalen Fall sind perspektivi­
+sche, orthografische und schiefwinklige Projektionen mit beliebigen Betrach­
+tungswinkeln möglich.
+
+Bei der EUMEL-Graphik wird streng zwischen Erzeugung und Manipulation von
+Graphiken (Bildern) auf der einen und Darstellung der erzeugten Bilder auf der
+anderen Seite unterschieden. Für die Erzeugung und Manipulation der Graphi­
+ken existiert der Typ PICTURE, für die Darstellung der Bilder gibt es den Typ
+PICFILE. Dabei müssen Ausschnitt, Maßstab, Betrachtungswinkel und Pro­
+jektionsart erst bei der Darstellung festgelegt werden. Diese Konstruktion des
+Graphik-Systems hat folgende Vorteile:
+
+a) Programme, die Graphik-Informationen erzeugen, sind geräteunabhängig.
+ Das bedeutet, daß Programmierer sich ausschließlich mit einem logischen
+ Problem zu befassen brauchen und nicht mit gerätespezifischen Besonder­
+ heiten.
+
+b) Graphiken können auf mehreren unterschiedlich gearteten Geräten mehrmals
+ dargestellt werden, ohne daß das erzeugende Programm geändert oder neu
+ gestartet werden muß. Z.B. kann ein Programmierer eine Graphik erst auf
+ dem Terminal auf Richtigkeit und Größenverhältnisse überprüfen, bevor er die
+ Zeichnung auf einem Plotter zeichnen läßt.
+
+c) Graphiken können leicht geändert (z.B. vergrößert oder in eine Richtung
+ gestreckt) werden, ohne daß das erzeugende Programm erneut durchlaufen
+ werden muß. Zudem können Graphiken aneinander oder übereinander gelegt
+ werden.
+
+d) Graphiken mit unterschiedlichen Farben, Strichen usw. können leicht erzeugt
+ werden.
+
+e) Der Anschluß von neuen Graphik-Geräten durch Benutzer ist leicht möglich,
+ ohne daß die Graphik erzeugenden Programme modifiziert werden müssen.
+
+f) Plotter können wie Drucker an einen SPOOLER gehängt werden.
+
+g) Bilder können als PICFILEs gespeichert und versandt werden.
+#free(2.0)#
+#ib(9)##type("triumb14")#Erzeugung von Bildern#ie(9)#
+#type("trium10")#
+
+Bilder entstehen in Objekten vom Datentyp
+
+#type("modern12")#
+ PICTURE
+#type("trium10")#
+
+Diese müssen mit der Prozedur
+
+#type("modern12")#
+ nilpicture
+#type("trium10")#
+
+initialisiert werden. Sie enthalten dann ein leeres Bild, dessen Dimension noch
+nicht festgelegt ist. Die Dimension eines PICTUREs wird mit dem ersten
+Schreibzugriff ('move' oder 'draw') festgelegt. Ein PICTURE kann immer nur
+entweder zwei- oder dreidimensional sein. Außerdem kann einem PICTURE mit
+der Prozedur
+
+#type("modern12")#
+ pen
+#type("trium10")#
+
+genau ein virtueller Stift zugeordnet oder der aktuelle Stift erfragt werden.
+
+Die Erzeugung eines Bildes basiert auf dem Modell eines Plotters. Der (virtuelle)
+Zeichenstift kann mit
+
+#type("modern12")#
+ move
+#type("trium10")#
+
+ohne zu zeichnen an beliebige Stellen gefahren werden (reine Positionierung).
+Mit
+
+#type("modern12")#
+ draw
+#type("trium10")#
+
+wird der Stift veranlaßt, eine Linie von der aktuellen zur angegebenen Zielposi­
+tion zu zeichnen. 'move' löst also Bewegungen mit gehobenem, 'draw' solche mit
+gesenktem Stift aus. Um auch 'relatives' Zeichnen zu ermöglichen, existiert die
+Prozedur
+
+#type("modern12")#
+ where
+#type("trium10")#
+
+die die aktuelle Stiftposition liefert.
+#free(2.0)#
+#ib(9)##type("triumb14")#Manipulation von Bildern#ie(9)#
+#type("trium10")#
+
+Erstellte Bilder können als Ganzes manipuliert werden. Die Prozeduren
+
+#type("modern12")#
+ translate (* verschieben *)
+ stretch (* strecken bzw. stauchen *)
+ rotate (* drehen *)
+ reflect (* spiegeln *)
+#type("trium10")#
+
+verändern jeweils das ganze Bild. Es ist aber auch möglich, mehrere Bilder
+zusammenzufügen. Mit
+
+#type("modern12")#
+ CAT
+#type("trium10")#
+
+kann ein weiteres Bild angefügt werden. Dabei müssen allerdings beide
+PICTURE die gleiche Dimension haben. In solchen als ganzes manipulierten
+Bildern kann man ohne Einschränkung mit 'draw' und 'move' weiterzeichnen.
+#free(2.0)#
+#ib(9)##type("triumb14")#Darstellung#ie(9)#
+#type("trium10")#
+
+Für die Darstellung der erzeugten Bilder existiert der Typ
+
+#type("modern12")#
+ PICFILE
+#type("trium10")#
+
+Dieser besteht aus max. 128 PICTUREs, die mit den Prozeduren
+
+#type("modern12")#
+ put
+ get
+#type("trium10")#
+
+eingegeben bzw. ausgegeben werden können. PICFILE wird durch Datenräume
+realisiert, deshalb erfolgt die Assoziation an einen benannten Datenraum ähnlich
+wie beim FILE. Dafür wird die Prozedur
+
+#type("modern12")#
+ picture file
+#type("trium10")#
+
+verwandt. Ein neuer PICFILE enthält genau ein leeres PICTURE. Die Darstellung
+der PICFILEs auf Zeichengeräten erfolgt mit der Prozedur
+
+#type("modern12")#
+ plot
+#type("trium10")#
+
+Da die Graphiken aber in "Weltkoordinaten" erzeugt werden und die spätere
+Darstellung vollkommen unbeachtet bleibt, müssen gewisse Darstellungspara­
+meter für die Zeichnung gesetzt werden. Diese Parameter werden im PICFILE
+abgelegt und gelten jeweils für den gesamten PICFILE. Dadurch ist es möglich,
+einen PICFILE mit spezifizierter Darstellungsart über einen SPOOLER an einen
+Plotter zu senden oder die bei der letzten Betrachtung gewählte Darstellung mit
+in dem PICFILE gespeichert zu halten. Für die Darstellung können den virtuellen
+Stiften mit der Prozedur
+
+#type("modern12")#
+ select pen
+#type("trium10")#
+
+reale Stifte zugeordnet werden. Voreingestellt ist für alle virtuellen Stifte:
+Standardfarbe, Standardstärke, durchgängige Linie.
+
+Indem man einigen virtuellen Stiften den leeren Stift als realen Stift zuordnet,
+kann man einzelne PICTUREs ausblenden. Sowohl bei der Darstellung von
+zwei- als auch dreidimensionaler Graphik kann die gewählte Zeichenfläche auf
+dem Endgerät mit der Prozedur
+
+#type("modern12")#
+ viewport
+#type("trium10")#
+
+festgelegt werden. Voreingestellt ist das Quadrat mit der größtmöglichen Seiten­
+länge, d.h. der kürzeren Seite der hardwaremäßigen Zeichenfläche.
+#free(2.0)#
+#ib(9)##type("triumb14")#Darstellung zweidimensionaler Graphik#ie(9)#
+#type("trium10")#
+
+Bei der Darstellung zweidimensionaler Bilder muß der zu zeichnende Ausschnitt
+(das 'Fenster') angegeben werden. Mit der Prozedur
+
+#type("modern12")#
+ window
+#type("trium10")#
+
+wird durch Angabe der minimalen und maximalen X- bzw. Y-Koordinaten ein
+Fenster definiert. Da das so definierte Fenster auf die ganze (mit 'viewport'
+definierbare) Zeichenfläche abgebildet wird, ist der Abbildungsmaßstab durch das
+Zusammenspiel von 'viewport' und 'window' bestimmt. Da bei 'viewport' stan­
+dardmäßig das maximale Zeichenquadrat voreingestellt ist, wird in diesem Fall
+durch gleiche X- und Y-Fenstergröße eine winkeltreue Darstellung erreicht.
+#free(2.0)#
+#ib(9)##type("triumb14")#Darstellung dreidimensionaler Graphik#ie(9)#
+#type("trium10")#
+
+Im dreidimensionalen Fall wird das Fenster ebenfalls mit
+
+#type("modern12")#
+ window
+#type("trium10")#
+
+definiert, wobei dann allerdings auch der Bereich der dritten Dimension
+(Z-Koordinaten) zu berücksichtigen ist. Da die dreidimensionale Graphik auf
+eine zweidimensionale Fläche projiziert wird, können aber noch weitere Darstel­
+lungsparameter angegeben werden. Der Betrachtungswinkel wird mit Hilfe der
+Prozedur
+
+#type("modern12")#
+ view
+#type("trium10")#
+
+angegeben. Zur Spezifikation der gewünschten Projektionsart gibt es
+
+#type("modern12")#
+ orthographic (* orthographische Projektion *)
+ perspective (* perspektivische Projektion,
+ der Fluchtpunkt ist frei wählbar *)
+ oblique (* schiefwinklige Projektion *)
+#type("trium10")#
+#free(2.0)#
+#ib(9)##type("triumb14")#Beispiel (Sinuskurve)#ie(9)#
+#type("modern12")#
+
+ funktion zeichnen;
+ bild darstellen .
+
+funktion zeichen :
+ PICTURE VAR pic :: nilpicture;
+ REAL VAR x := -pi;
+ move (pic, x, sin (x));
+ REP x INCR 0.1;
+ draw (pic, x, sin (x))
+ UNTIL x >= pi PER .
+
+bild darstellen :
+ PICFILE VAR p :: picture file ("sinus");
+ window (p, -pi, pi, -1.0, 1.0);
+ put (p, pic);
+ plot (p) .
+#type("trium10")#
+#free(2.0)#
+#ib(9)##type("triumb14")#Beispiel (Würfel)#ie(9)#
+#type("modern12")#
+
+ wuerfel zeichen;
+ wuerfel darstellen.
+
+wuerfel zeichnen :
+ zeichne vorderseite;
+ zeichne rueckseite;
+ zeichne verbindungskanten.
+
+zeichne vorderseite :
+ PICTURE VAR vorderseite :: nilpicture;
+ move (vorderseite, 0.0, 0.0, 0.0);
+ draw (vorderseite, 1.0, 0.0, 0.0);
+ draw (vorderseite, 1.0, 0.0, 1.0);
+ draw (vorderseite, 0.0, 0.0, 1.0);
+ draw (vorderseite, 0.0, 0.0, 0.0).
+
+zeichne rueckseite :
+ PICTURE VAR rueckseite :: translate
+ (vorderseite, 0.0, 1.0, 0.0).
+
+zeichne verbindungskanten :
+ PICTURE VAR verbindungskanten :: nilpicture;
+ move (verbindungskanten, 0.0, 0.0, 0.0);
+ draw (verbindungskanten, 0.0, 1.0, 0.0);
+
+ move (verbindungskanten, 1.0, 0.0, 0.0);
+ draw (verbindungskanten, 1.0, 1.0, 0.0);
+
+ move (verbindungskanten, 1.0, 0.0, 1.0);
+ draw (verbindungskanten, 1.0, 1.0, 1.0);
+
+ move (verbindungskanten, 0.0, 0.0, 1.0);
+ draw (verbindungskanten, 0.0, 1.0, 1.0).
+
+wuerfel darstellen :
+ PICFILE VAR p := picture file ("wuerfel");
+ put (p, vorderseite);
+ put (p, rueckseite);
+ put (p, verbindungskanten);
+ window (p, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0);
+ view (p, 0.0, 40.0, 20.0);
+ orthographic (p);
+ plot (p).
+#type("trium10")#
+#free(2.0)#
+#ib(9)##type("triumb14")#Beschreibung der Graphik-Prozeduren#ie(9)#
+#type("trium10")#
+
+ #limit(12.0)##on("italics")#Zweidimensionale PICTUREs brauchen weniger Speicherplatz
+ als dreidimensionale. Daher werden in einigen Fehlermeldun­
+ gen unterschiedliche Größen angegeben.
+#limit(13.5)##off("italics")#
+
+:=
+ OP := (PICTURE VAR dest, PICTURE CONST source)
+ Zweck: Zuweisung
+
+ OP := (PICFILE VAR dest, DATASPACE CONST source)
+ Zweck: Assoziiert die PICFILE Variable 'dest' mit der DATASPACE CONST
+ 'source' und initialisiert die PICFILE Variable sofern nötig.
+ Fehlerfall:
+ * dataspace is no PICFILE
+ Der anzukoppelnde Datenraum hat einen falschen Typ.
+
+#ib#CAT#ie#
+ OP CAT (PICTURE VAR dest, PICTURE CONST source)
+ Zweck: Aneinanderfügen von zwei PICTURE's.
+ Fehlerfälle:
+ * OP CAT: left dimension <> right dimension
+ Es können nur PICTUREs mit gleicher Dimension angefügt werden.
+ * OP CAT: Picture overflow
+ Die beiden PICTURE überschreiten die maximale Größe eines
+ Pictures.
+
+#ib#act picture#ie#
+ PICTURE PROC act picture (PICFILE VAR p)
+ Zweck: Liefert das PICTURE des PICFILEs 'p', auf das mit 'backward' o.ä.
+ positioniert wurde.
+
+#ib#backward#ie#
+ PROC backward (PICFILE VAR p)
+ Zweck: Positioniert den PICFILE 'p' um ein PICTURE zurück.
+ Fehlerfall:
+ * backward at begin of file
+ Es wurde versucht vor den Anfang des PICFILEs zu positionieren.
+
+#ib#draw#ie#
+ PROC draw (PICTURE VAR pic, REAL CONST x, y)
+ Zweck: Die Prozedur zeichnet in dem (zweidimensionalen) Bild 'pic' eine
+ Linie von der aktuellen Position zur Position (x, y).
+ Fehlerfälle:
+ * picture overflow
+ Zu viele Befehle in einem PICTURE (z. Zeit max. 1927)
+ * picture is three dimensional
+ Ein PICTURE kann nur entweder zwei- oder dreidimensional sein.
+
+ PROC draw (PICTURE VAR pic, REAL CONST x, y, z)
+ Zweck: Die Prozedur zeichnet in dem (dreidimensionalen) Bild 'pic' eine
+ gerade Linie von der aktuellen Position zur Position (x, y, z).
+ Fehlerfälle:
+ * picture overflow
+ Zu viele Befehle in einem PICTURE (z. Zeit max. 1310)
+ * picture is only two dimensional
+ Ein PICTURE kann nur entweder zwei- oder dreidimensional sein.
+
+ PROC draw (PICTURE VAR pic, TEXT CONST text)
+ Zweck: Der angegebene Text wird in das Bild 'pic' eingetragen. Der Anfang
+ ist dabei die aktuelle Stiftposition. Diese wird nicht verändert.
+ Fehlerfall:
+ * picture overflow
+ Der Text paßt nicht mehr in das PICTURE.
+
+ PROC draw (PICTURE VAR pic, TEXT CONST text,
+ REAL CONST angle, height)
+ Zweck: Der angegebene Text wird unter dem Winkel 'angle' gegenüber der
+ Waagerechten und in der Größe 'height' in das PICTURE 'pic'
+ eingetragen. Der Anfang ist dabei die aktuelle Stiftposition. Diese
+ wird nicht verändert.
+ Fehlerfall:
+ * picture overflow
+ Der Text paßt nicht mehr in das PICTURE.
+
+ PROC draw (PICFILE VAR pic, REAL CONST x, y)
+ Zweck: Die Prozedur zeichnet in dem aktuellen (zweidimensionalen)
+ PICTURE des PICFILEs 'p' eine gerade Linie. Der (virtuelle) Stift wird
+ von der aktuellen Position zur Position (x, y) gefahren. Falls das
+ aktuelle PICTURE zu voll ist, wird automatisch auf das nächste
+ umgeschaltet.
+ Fehlerfälle:
+ * picfile overflow
+ Das letzte PICTURE ist voll (z. Zeit max. 128 PICTURE)
+ * picture is threedimensional
+ Das aktuelle PICTURE ist dreidimensional.
+
+ PROC draw (PICTFILE VAR pic, REAL CONST x, y, z)
+ Zweck: s. o.
+ Fehlerfälle:
+ * picfile overflow
+ Das letzte PICTURE ist voll (z. Zeit max. 128)
+ * picfile is only twodimensional
+ Das aktuelle PICTURE ist zweidimensional.
+
+ PROC draw (PICTFILE VAR pic, TEXT CONST text)
+ Zweck: Der angegebene Text wird in das aktuelle PICTURE des PICFILEs 'p'
+ eingetragen. Falls das aktuelle PICTURE zu voll ist, wird automatisch
+ auf das nächste umgeschaltet. Der Anfang ist dabei die aktuelle
+ Stiftposition. Diese wird nicht verändert.
+ Fehlerfall:
+ * picfile overflow
+ Das letzte PICTURE ist voll (z. Zeit max. 128)
+
+ PROC draw (PICFILE VAR pic, TEXT CONST text,
+ REAL CONST angle, height)
+ Zweck: Der angegebene Text wird unter dem Winkel 'angle' gegenüber der
+ Waagerechten und in der Größe 'height' in das aktuelle PICTURE
+ des PICFILES 'p' eingetragen. Falls das aktuelle PICTURE zu voll ist,
+ wird automatisch auf das nächste umgeschaltet. Der Anfang ist
+ dabei die aktuelle Stiftposition. Diese wird nicht verändert.
+ Fehlerfall:
+ * picfile overflow
+ Das letzte PICTURE ist voll (z. Zeit max. 128)
+
+#ib#eof#ie#
+ BOOL PROC eof (PICFILE CONST p)
+ Zweck: Liefert 'TRUE' wenn hinter das Ende des PICFILEs positioniert
+ wurde.
+
+#ib#extrema#ie#
+ PROC extrema (PICTURE CONST p,
+ REAL VAR x min, x max, y min, y max)
+ Zweck: Die Prozedur liefert die größten und kleinsten X- und Y-Koordi­
+ naten des PICTUREs 'p'. Diese werden in die Parameter 'x min', 'x
+ max', 'y min' und 'y max' eingetragen.
+
+ PROC extrema (PICTURE CONST p,
+ REAL VAR x min, x max, y min, y max, z min, z max)
+ Zweck: s.o.
+
+ PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max)
+ Zweck: s.o.
+
+ PROC extrema (PICFILE VAR p,
+ REAL VAR x min, x max, y min, y max, z min, z max)
+ Zweck: s.o.
+
+#ib#forward#ie#
+ PROC forward (PICFILE VAR p)
+ Zweck: Positioniert den PICFILE um ein PICTURE weiter.
+ Fehlerfall:
+ * picfile overflow
+ Es sollte hinter das Ende des PICFILEs positioniert werden.
+
+#ib#get#ie#
+ PROC get (PICFILE VAR p, PICTURE VAR pic)
+ Zweck: Liest ein PICTURE aus einem PICFILE und positioniert auf das
+ Nächste.
+ Fehlerfall:
+ * input after end of picfile
+ Es sollte nach dem Ende des Picfiles gelesen werden.
+
+#ib#move#ie#
+ PROC move (PICTURE VAR pic, REAL CONST x, y)
+ Zweck: Der (virtuelle) Stift wird zur Position (x, y) gefahren.
+ Fehlerfälle:
+ * picture overflow
+ Zu viele Befehle in einem PICTURE (z. Zeit max. 1927 'moves')
+ * picture is three dimensional
+ Ein PICTURE kann nur entweder zwei- oder dreidimensional sein.
+
+ PROC move (PICTURE VAR pic, REAL CONST x, y, z)
+ Zweck: Der (virtuelle) Stift wird zur Position (x, y, z) gefahren.
+ Fehlerfälle:
+ * picture overflow
+ Zu viele Befehle in einem PICTURE (z. Zeit max. 1310)
+ * picture is only twodimensional
+ Ein PICTURE kann nur entweder zwei- oder dreidimensional sein.
+
+ PROC move (PICFILE VAR p, REAL CONST x, y)
+ Zweck: Der (virtuelle) Stift wird zur Position (x, y) gefahren. Falls das aktuelle
+ PICTURE des PICFILEs 'p' zu voll ist, wird automatisch auf das
+ nächste umgeschaltet.
+ Fehlerfall:
+ * picfile overflow
+ Das letzte PICTURE ist voll (z. Zeit max. 128 PICTUREs)
+
+ PROC move (PICFILE VAR p, REAL CONST x, y, z)
+ Zweck: Der (virtuelle) Stift wird zur Position (x, y, z) gefahren. Falls das
+ aktuelle PICTURE des PICFILEs 'p' zu voll ist, wird automatisch auf
+ das nächste umgeschaltet.
+ Fehlerfall:
+ * picfile overflow
+ Das letzte PICTURE ist voll (z. Zeit max. 128 PICTUREs)
+
+#ib#nilpicture#ie#
+ PICTURE PROC nilpicture
+ Zweck: Die Prozedure liefert ein leeres PICTURE zur Initialisierung.
+
+#ib#oblique#ie#
+ PROC oblique (PICFILE VAR p, REAL CONST a, b)
+ Zweck: Bei dem (dreidimensionalen!) Bild 'p' wird 'schiefwinklig' als
+ gewünschte Projektionsart eingestellt. Dabei ist (a, b) der Punkt in
+ der X-Y-Ebene, auf den der Einheitsvector in Z-Richtung
+ abgebildet werden soll.
+
+#ib#orthographic#ie#
+ PROC orthographic (PICFILE VAR p)
+ Zweck: Bei dem (dreidimensionalen!) Bild 'p' wird "orthografisch" als Pro­
+ jektionsart eingestellt. Bei der orthografischen Projektion wird ein
+ dreidimensionaler Körper mit parallelen Strahlen senkrecht auf die
+ Projektionsebene abgebildet.
+
+#ib#pen#ie#
+ INT PROC pen (PICTURE CONST pic)
+ Zweck: Liefert die Nummer des 'virtuellen Stifts'.
+
+ PICTURE PROC pen (PICTURE CONST pic, INT CONST pen)
+ Zweck: Liefert ein PICTURE mit dem Inhalt 'pic' und dem 'virtuellen Stift' mit
+ der Nummer 'pen'. Möglich sind die Nummern 1 - 16.
+ Fehlerfälle:
+ * PROC pen: pen [No] < 1
+ Der gewünschte Stift ist kleiner als 1.
+ * PROC pen: pen [No] > 16
+ Der gewünschte Stift ist größer als 16.
+
+#ib#perspective#ie#
+ PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz)
+ Zweck: Bei den dreidimensionalen PICTUREs des PICFILE's 'p' wird
+ "perspektivisch" als gewünschte Projektionsart eingestellt. Der Punkt
+ (cx, cy, cz) ist der Fluchtpunkt der Projektion, d.h. alle Parallelen zur
+ Blickrichtung schneiden sich in diesem Punkt.
+
+#ib#pic no#ie#
+ INT PROC pic no (PICFILE CONST p)
+ Zweck: Liefert die Nummer des aktuellen PICTUREs.
+
+#ib#picture file#ie#
+ DATASPACE PROC picture file (TEXT CONST name)
+ Zweck: Die Prozedur dient zur Assoziation eines benannten Datenraumes mit
+ einem PICFILE (s. Operator ':=').
+
+#ib#plot#ie#
+ PROC plot (TEXT CONST name)
+ Zweck: Der PICFILE mit dem Namen 'name' wird entspechend der angege­
+ benen Darstellungsart gezeichnet. Diese Parameter ('perspective',
+ 'orthographic', 'oblique', 'view', 'window' etc.) müssen vorher
+ eingestellt werden.
+ Fehlerfall:
+ * FILE does not exist
+ Es existiert kein PICFILE mit dem Namen 'name'
+
+ PROC plot (PICFILE VAR p)
+ Zweck: Der PICFILE 'p' wird entspechend der angegebenen Darstellungsart
+ gezeichnet. Diese Parameter müssen vorher eingestellt werden.
+
+ #on("bold")#Zweidimensional:
+#off("bold")#
+ obligat: 'window' (zweidimensional)
+ optional: 'view' (zweidimensional)
+ 'select pen'
+ 'viewport'
+
+ #on("bold")#Dreidimensional:
+#off("bold")#
+ obligat: 'window' (dreidimensional)
+ optional: 'view' (dreidimensional)
+ 'orthographic', 'perspective', 'oblique'
+ 'viewport'
+ 'select pen'
+
+#ib#put#ie#
+ PROC put (PICFILE VAR p, PICTURE CONST pic)
+ Zweck: Schreibt ein PICTURE in einen PICFILE und positioniert um eins
+ vor.
+ Fehlerfall:
+ * picfile overflow
+ Der PICFILE ist voll. (z. Z. max. 128 PICTURE)
+
+#ib#reset#ie#
+ PROC reset (PICFILE VAR p)
+ Zweck: Positioniert auf den Anfang eines Picfiles.
+
+#ib#rotate#ie#
+ PICTURE PROC rotate (PICTURE CONST pic, REAL CONST alpha)
+ Zweck: Das PICTURE 'pic' wird um den Punkt (0, 0) um den Winkel 'alpha'
+ (im Gradmaß) im mathematisch positiven Sinn gedreht.
+
+ PICTURE PROC rotate (PICTURE CONST pic,
+ REAL CONST alpha, beta, gamma)
+ Zweck: Das dreidimensionale PICTURE 'pic' wird um den Winkel 'alpha',
+ 'beta' oder 'gamma' im mathematisch positiven Sinn gedreht. Der
+ Winkel 'alpha' dreht um die X-Achse, der Winkel 'beta' um die
+ Y-Achse und 'gamma' um die Z-Achse. Es darf dabei nur jeweils
+ ein Winkel von 0.0 verschieden sein. Alle Winkel werden im
+ Gradmaß angegeben.
+
+#ib#select pen#ie#
+ PROC select pen (PICFILE VAR p,
+ INT CONST pen, colour, thickness, linetype)
+ Zweck: Für die Darstellung des Bildes 'p' soll dem "virtuellen Stift" 'pen' ein
+ realer Stift zugeordnet werden, der möglichst die Farbe 'colour' und
+ die Dicke 'thickness' hat und dabei Linien mit dem Typ 'line type'
+ zeichnet. Es wird die beste Annäherung für das Ausgabegerät für
+ diese Parameter genommen. Dabei gelten folgende Vereinbarun­
+ gen:
+
+ Farbe: negative Farben setzten den Hintergrund, positive Farben
+ zeichnen im Vordergrund.
+
+ 0 Löschstift (falls vorhanden)
+ 1 Standardfarbe des Endgeräts (schwarz oder weiß)
+ 2 rot
+ 3 blau
+ 4 grün
+ 5 schwarz
+ 6 weiß > 20 nicht normierte Sonderfarben
+
+ Dicke: 0
+ Standardstrichstärke des Endgerätes > 0
+ Strichstärke in 1/10 mm
+
+ Typ:
+ 0 keine sichtbare Linie
+ 1 durchgängige Linie
+ 2 gepunktete Linie
+ 3 kurz gestrichelte Linie
+ 4 lang gestrichelte Linie
+ 5 Strichpunktlinie
+
+ Die hier aufgeführten Möglichkeiten müssen nicht an allen grafischen
+ Endgeräten vorhanden sein. Der geräteabhängige Graphik-Treiber
+ wählt jeweils die für ihn bestmögliche Annäherung.
+
+ Fehlerfälle:
+ * pen < 1
+ * pen > 16
+
+#ib#size#ie#
+ INT PROC size (PICFILE CONST p)
+ Zweck: Liefert die aktuelle Größe eines PICFILEs in Bytes.
+
+#ib#stretch#ie#
+ PICTURE PROC stretch (PICTURE CONST pic, REAL CONST xc, yc)
+ Zweck: Das PICTURE 'pic' wird in X-Richtung um den Faktor 'xc', in
+ Y-Richtung um den Faktor 'yc' gestreckt (bzw. gestaucht). Dabei
+ bewirkt der Faktor
+ c > 1 eine Streckung
+ 0 < c < 1 eine Stauchung
+ c < 0 zusätzlich eine Achsenspiegelung
+
+ PICTURE PROC stretch (PICTURE CONST pic, REAL CONST xc, yc, zc)
+ Zweck: Das dreidimensionale PICTURE 'pic' wird entsprechend den
+ angegeben Faktoren 'xc', 'yc' und 'zc' gestreckt. Wirkung s.o.
+
+#ib#translate#ie#
+ PICTURE PROC translate (PICTURE CONST pic, REAL CONST dx, dy)
+ Zweck: Das PICTURE 'pic' wird um 'dx' und 'dy' verschoben.
+ Fehlerfall:
+ * picture is threedimensional
+ 'pic' ist dreidimensional.
+
+ PICTURE PROC translate (PICTURE CONST pic, REAL CONST dx, dy, dz)
+ Zweck: Das PICTURE 'pic' wird um 'dx', 'dy' und 'dz' verschoben.
+ Fehlerfall:
+ * picture is twodimensional
+ Das PICTURE 'pic' ist zweidimensional
+
+#ib#two dimensional#ie#
+ PROC two dimensional (PICFILE VAR p)
+ Zweck: Setzt als Projektionsart zweidimensional.
+
+#ib#view#ie#
+ PROC view (PICFILE VAR p, REAL CONST alpha, phi, theta)
+ Zweck: Dreidimensionale Bilder werden häufig nicht direkt von vorne
+ dargestellt, sondern für die Betrachtung gedreht. Mit der Prozedur
+ 'view' kann diese Betrachtungsrichtung durch die Polarwinkel 'phi'
+ und 'theta' angegeben werden. Mit dem Winkel 'alpha' kann dann
+ das Bild um den Mittelpunkt der Zeichenfläche gedreht werden.
+ Dadurch kann ein Bild auch auf einem Terminal hochkant gestellt
+ werden. Voreingestellt ist 'phi = 0, theta = 0 und alpha = 0', d.h.
+ direkt von oben.
+
+ Im Gegensatz zu 'rotate' hat 'view' keine Wirkung auf das eigentli­
+ che Bild (PICFILE), sondern nur auf die gewählte Darstellung. So
+ addieren sich zwar aufeinanderfolgende "Rotationen", 'view' aber
+ geht immer von der Nullstellung aus. Auch kann das Bild durch eine
+ "Rotation" ganz oder teilweise aus oder in das Darstellungsfenster
+ ('window') gedreht werden. Bei 'view' verändern sich die Koordina­
+ ten der Punkte nicht, d.h. das Fenster wird mitgedreht.
+
+#ib#viewport#ie#
+ PROC viewport (PICFILE VAR p,
+ REAL CONST hormin, hormax, vertmin, vertmax)
+ Zweck: Die Zeichenfläche auf dem Endgerät, auf dem das Bild dargestellt
+ werden soll, wird spezifiziert. Dabei wird sowohl die Größe als auch
+ die relative Lage der Zeichenfläche definiert. Der linke untere
+ Eckpunkt der physikalischen Zeichenfläche des Gerätes hat die
+ Koordinaten (0.0, 0.0). Die definierte Zeichenfläche erstreckt sich
+
+#type("modern12")#
+ 'hormin' - 'hormax' in der Horizontalen,
+ 'vertmin' - 'vertmax' in der Vertikalen.
+#type("trium10")#
+
+ So liegt der linke untere Eckpunkt dann bei (hormin, vertmin), der
+ rechte obere bei (hormax, vertmax).
+
+ Damit sowohl geräteunabhängige als auch maßstabsgerechte
+ Zeichnungen möglich sind, können die Koordinaten in zwei Arten
+ spezifiziert werden :
+
+ a) Gerätekoordinaten
+ Die Koordinaten können Werte von 0.0 bis 2.0 annehmen. Dabei
+ hat die kürzere Seite der physikalischen Zeichenfläche defini­
+ tionsgemäß die Länge 1.0.
+
+ b) absolute Koordinaten
+ Die Werte werden in cm angegeben. Für die Maximalwerte sind
+ nur Werte größer als 2.0 möglich.
+
+ Voreingestellt ist
+
+#type("modern12")#
+ viewport (0.0, 1.0, 0.0, 1.0),
+#type("trium10")#
+
+ d.h. das größtmöglichste Quadrat, beginnend in der linken unteren
+ Ecke der physikalischen Zeichenfläche. In vielen Fällen wird diese
+ Einstellung ausreichen, so daß der Anwender kein eigenes 'viewport'
+ definieren muß.
+
+ Der Abbildungsmaßstab wird durch das Zusammenspiel von 'view­
+ port' und 'window' festgelegt (siehe dort). Dabei ist insbesondere
+ darauf zu achten, daß winkeltreue Darstellungen nur bei gleichem
+ X- und Y-Maßstab möglich sind. Da man oft quadratische Fenster
+ ('window') verwendet, wurde als Standardfall auch ein quadratisches
+ 'viewport' gewählt.
+
+#ib#where#ie#
+ PROC where (PICTURE CONST pic, REAL VAR x, y)
+ Zweck: Die aktuelle Stiftposition wird in 'x' und 'y' eingetragen.
+ Fehlerfall:
+ * picture is threedimensional
+ Das PICTURE 'pic' ist dreidimensional
+
+ PROC where (PICTURE CONST pic, REAL VAR x, y, z)
+ Zweck: Die aktuelle Stiftposition wird in 'x', 'y' und 'z' eingetragen.
+ Fehlerfall:
+ * picture is twodimensional
+ Das PICTURE 'pic' ist zweidimensional
+
+#ib#window#ie#
+ PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max)
+ Zweck: Für die Darstellung eines zweidimensionalen Bildes wird das
+ darzustellende Fenster definiert. Alle Bildpunkte, deren X-Koordi­
+ naten im Intervall [x min, x max] und deren Y-Koordinaten im
+ Intervall [y min, y max] liegen, gehören zum definierten Fenster.
+ Vektoren, die über dieses Fenster hinausgehen, werden abge­
+ schnitten. Dieses Fenster wird auf die spezifizierte Zeichenfläche
+ abgebildet. (Das ist standardmäßig das größtmögliche Quadrat auf
+ dem ausgewählten Gerät).
+
+ Der Darstellungsmaßstab ergibt sich als
+
+#type("modern12")#
+ x max - x min
+ -----------------------------------------
+ horizontale Seitenlänge der Zeichenfläche
+
+ y max - y min
+ -----------------------------------------
+ vertikale Seitenlänge der Zeichenfläche
+#type("trium10")#
+
+ Für eine winkeltreue Darstellung müssen X- und Y-Maßstab
+ gleich sein! Einfach können winkeltreue Darstellung erreicht
+ werden, wenn das Fenster eine quadratische Form hat. Die
+ Zeichenfläche ('viewport') ist dementsprechend als Quadrat vorein­
+ gestellt.
+
+ PROC window (PICFILE VAR p,
+ REAL CONST x min, x max, y min, y max, z min, z max)
+ Zweck: Für die Darstellung eines dreidimensionalen Bildes wird das darzu­
+ stellende Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im
+ Intervall [x min, x max] und deren Y-Koordinaten im Intervall [y min,
+ y max] und deren Z-Koordinaten im Intervall [z min, z max] liegen,
+ gehören zum definierten Fenster. Dieses dreidimensionale Fenster
+ (Quader) wird entsprechend der eingestellten Projektionsart (ortho­
+ grafisch, perspektivisch oder schiefwinklig) und den Betrachtungs­
+ winkeln (s. 'view') auf die spezifizierte Zeichenfläche abgebildet. (Das
+ ist standardmäßig das größtmögliche Quadrat auf dem ausgewählten
+ Gerät.) Linien, die außerhalb dieses Quadrates liegen, werden
+ abgeschnitten.
+
+ Anders als im zweidimensionalen Fall ist das Problem der Maßstäbe
+ nicht mehr nur durch das Zusammenspiel von 'window' und 'view­
+ port' zu beschreiben. Hier spielen auch Projektionsart und Dar­
+ stellungswinkel eine Rolle. Falls alle Darstellungswinkel den Wert 0.0
+ haben, gilt das für den zweidimensionalen Fall gesagte für die Ebene
+ (y = 0.0) entsprechend.
+
+#ib#write is possible#ie#
+ BOOL PROC write is possible (PICTURE CONST pic, INT CONST space)
+ Zweck: Liefert 'TRUE', falls 'space' Bytes Platz in 'pic' vorhanden ist.
+
+
+
+
+
+
diff --git a/system/std.graphik/1.8.7/doc/GRAPHIK.book b/system/std.graphik/1.8.7/doc/GRAPHIK.book
new file mode 100644
index 0000000..435d9e4
--- /dev/null
+++ b/system/std.graphik/1.8.7/doc/GRAPHIK.book
@@ -0,0 +1,897 @@
+#type ("times8")##limit (11.0)##start (2.2, 1.5)##pagelength (17.4)##block#
+
+#head#
+#type ("triumb14")#
+#center#EUMEL-Grafik-System
+
+#type ("times8")#
+#end#
+#type ("triumb14")# Teil 10: Graphik#type ("times8")#
+
+
+#type ("trium12")#
+#on("b")#1. Übersicht#off("b")#
+#type ("times8")#
+
+#limit (7.0)##type("times6")#
+ #on("i")#Dieser Teil des Benutzer-Handbuchs beschreibt die Graphik-
+ Fähigkeiten des EUMEL-Systems. Die Graphik-Pakete gehö­
+ ren nicht zum Eumel-Standard, sondern sind Anwenderpake­
+ te, die im Quellcode ausgeliefert und von jeder Installation in das
+ System aufgenommen werden können. #off("i")#
+#limit (11.0)#
+#foot#
+ Eventuell müssen Programme erstellt werden, die die Anpassungen für spezielle graphische Geräte einer Installation
+ vornehmen, soweit diese nicht von den EUMEL-Anbietern bezogen werden können.
+#end#
+
+#type("times8")#
+ Das #on("b")#Graphik-System#off("b")# ermöglicht es, durch ELAN-Programme geräteunabhängige Infor­
+ mationen für Zeichnungen (#on("i")#Graphiken#off("i")#) zu erstellen. Die Graphik erzeugenden Programme
+ brauchen dabei keine geräteabhängigen Größen oder Unterprogramme zu enthalten. Sie
+ befassen sich somit ausschließlich mit der Erzeugung der problemorientierten Information
+ für die Konstruktion einer Zeichnung. Nach der geräteunabhängigen Erzeugung einer
+ Graphik kann diese auf unterschiedlichen Geräten ausgegeben werden (z.B. erst auf einem
+ Terminal zur Kontrolle und dann auf einem Plotter).
+
+ Die EUMEL-Graphik umfaßt zwei- und dreidimensionale Graphik. Im dreidimensiona­
+ len Fall sind perspektivische, orthografische und schiefwinklige Projektionen mit beliebi­
+ gen Betrachtungswinkeln möglich.
+
+ Bei der EUMEL-Graphik wird streng zwischen Erzeugung und Manipulation von Gra­
+ phiken auf der einen und der Darstellung der erzeugten Bilder auf der anderen Seite
+ unterschieden. Für die Erzeugung und Manipulation der Graphiken wird von den Paketen
+ #on("i")#picture#off("i")# und #on("i")#picfile#off("i")# der Datentype #on("b")#PICTURE#off("b")# bzw. #on("b")#PICFILE#off("b")# zur Verfügung gestellt. Dabei
+ müssen Ausschnitt, Maßstab, Betrachtungswinkel und Projektionsart erst bei der Darstel­
+ lung festgelegt werden. Diese Konstruktion des Graphik-Systems hat folgende Vorteile:
+
+ a) Programme, die Graphik-Information erzeugen, sind geräteunabhängig. Das bedeu­
+ tet, das der Programmierer sich ausschließlich mit einem logischen Problem befassen
+ muß und nicht mit gerätespezifischen Besonderheiten.
+
+ b) Graphiken können auf mehreren unterschiedlich gearteten Geräten mehrmals darge­
+ stellt werden, ohne daß das erzeugende Programm geändert oder neu gestartet werden
+ muß. Z.B. kann ein Programmierer eine Graphik erst auf dem Terminal überprüfen,
+ bevor er die Graphik auf einem Plotter zeichnen läßt.
+
+ c) Graphiken können leicht geändert (z. B. vergrößert oder in eine Richtung gestreckt
+ o.ä.) werden, ohne daß sie erneut erzeugt werden müssen. Zudem können Graphiken
+ aneinander oder übereinander gelegt werden.
+
+ d) Graphiken mit unterschiedlichen Farben, Strichen usw. können leicht erzeugt werden.
+
+ e) Der Anschluß von neuen Graphik.Geräten durch Benutzer ist leicht möglich, ohe daß
+ die Graphik-Programme geändert werden müssen.
+
+ f) Plotter können wie Drucker an einen Spooler gehängt werden.
+
+ g) Bilder können als PICFILEs gespeichert und versandt werden.
+
+ h) Es können auch auf Systemen ohne graphische Ausgabegeräte Graphiken erzeugt
+ werden.
+
+ i) Es können mit einfachen Mitteln universelle Unterprogrammpakete erstellt werden,
+ um die Standardzeichnungen (Darstellen einer Funktion, Balken oder Liniendiagram­
+ me, Achsen etc.) zu erstellen.
+
+
+#type ("trium12")#
+#on("b")#2. Erzeugung von Bildern#off("b")#
+#type ("times8")#
+
+ Bilder entstehen in Objektion vom Datentyp #on("b")#PICTURE#off("b")#. Diese müssen mit der Prozedur
+ #on("i")#nilpicture#off("i")# initialisiert werden. Sie enthalten dann ein leeres Bild, dessen Dimension noch
+ nicht festgelegt ist. Die Dimension eines #on("i")#PICTURE#off("i")#s wird mit dem ersten Schreibzugriff
+ (#on("i")#move, draw#off("i")# o.ä.) festgelegt. Ein #on("i")#PICTURE#off("i")# kann immer nur entweder zwei- oder
+ dreidimensional sein.
+ Außerdem kann einem #on("i")#PICTURE#off("i")# mit der Prozedur #on("i")#pen#off("i")# genau ein virtueller Stift zugeord­
+ net oder der aktuelle Stift erfragt werden (Standardeinstellung: 1).
+
+ Für Erzeugung eines Bildes wird ein virtueller Zeichenstift benutzt, dem bei der Darstel­
+ lung jeweils genau ein realer Stift zugeordnet wird. Dieser Stift kann mit der Prozedur
+ #on("b")#move#off("b")# oder #on("b")#move r #off("b")#auf eine bestimmte Stelle positioniert werden ohne zu zeichnen. Mit
+ #on("b")#draw#off("b")# oder #on("b")#draw r#off("b")# wird eine Linie von der letzten Position zur angegebene Position
+ gezeichnet. Die aktuelle Stiftposition kann dabei mit #on("b")#where#off("b")# abgefragt werden.
+ Außerdem existiert noch die Prozedur #on("b")#draw#off("b")# die einen Text zur Beschriftung der Zeich­
+ nung darstellt, sowie #on("b")#bar#off("b")# zum Zeichnen eines Balkens für Balkendiagramme, #on("b")#circle#off("b")# zum
+ Zeichnen eines Kreisbogens für Kreisdiagramme und #on("b")#mark#off("b")# zum Markiern von Positionen.
+ Dabei wird die aktuelle Stiftposition aber nicht verändert.
+
+#type ("trium12")#
+#on("b")#3. Manipulation von PICTUREs#off("b")#
+#type ("times8")#
+
+ Erstellte PICTUREs können auch als Ganzes manipuliert werde. Dazu dienen die Prozedu­
+ ren #on("b")#translate, stretch#off("b")# und #on("b")#rotate#off("b")#. Es ist auch möglich mehrere PICTURE mit dem Opera­
+ tor #on("b")#CAT#off("b")# aneinanderzufügen, wenn beide PICTURE die gleiche Dimension haben. In
+ solcherart manipulierten Bildern kann ohne Einschränkung weitergezeichnet werden,
+ solange die maximale Größe nicht überschritten wird.
+
+#type ("trium12")#
+#on("b")#4. Darstellung und Speicherung #off("b")#
+#type ("times8")#
+
+ Für die Darstellung und Speicherung der erzeugten Bilder existiert der Typ #on("b")#PICFILE#off("b")#.
+ Dieser besteht aus eienm Datenraum mit max. 1024 PICTUREs, die mit den Prozeduren #on("b")#
+ delete picture, insert picture, read picture, write picture, get picture#off("b")# und #on("b")#put picture#off("b")# einge­
+ geben bzw. ausgegeben werden können.
+ Für die Positionierung innerhalb eines PICFILES stehen die Prozeduren #on("b")#to pic, up, down,
+ eof, picture no, pictures#off("b")# zur Verfügung.
+ Für die Assoziation mit einem benannten Datenraum existiert ähnlich wie beim Datentyp
+ FILE die Prozedur #on("b")#picture file#off("b")#; unbenannte Datenräume können mit dem Operator #on("b")#:=#off("b")#
+ assoziert werden.
+ Die Darstellung des PICFILES auf einem Zeichengerät erfolgt mit der Prozdur #on("b")#plot#off("b")#.
+ Da die Graphiken aber in #on("i")#Weltkoordinaten#off("i")# erzeugt werden und die spätere Darstellung
+ vollkommen unbeachtet bleibt, müssen gewisse Darstellungsparameter für die Zeichnung
+ gesetzt werden. Dies Parameter werden im PICFILE abgelegt und gelten jeweils für alle
+ darin enthaltenen PICTURE. Dadurch ist es möglich, einen PICFILE mit spezifierter
+ Darstellungsart über einen SPOOLER an einen Plotter zu senden oder die bei der letzten
+ Betrachtung gewählte Darstellung beizubehalten oder zu ändern.
+ Für die Darstellung können den virtuellen Stiften mit der Prozedur #on("b")#select pen#off("b")# reale Stifte
+ zugeordnet werden. Voreingestellt ist für alle virtuellen Stifte die Standardfarbe, Standard­
+ stärke und durchgängige Linie. Mit #on("b")#background#off("b")# kann eine bestimmte Hintergrundfarbe
+ gewählt werden.
+ Indem man einem PICTURE den Stift 0 zuordnet, kann man dieses auch Ausblenden
+ wenn es bei dieser Darstellung stört.
+ Die Größe der realen Zeichenfläche kann mit #on("b")#viewport#off("b")# eingestellt werden, wobei die
+ gesamte Zeichenfäche voreingestellt ist. Dadurch können auch mehrere PICFILE auf ein
+ Blatt oder einen Bildschirm gezeichnet werden, wenn man durch Angabe von #on("i")#background
+  (0)#off("i")# das Löschen der Zeichenfläche unterdrückt.
+
+
+#type ("trium12")#
+#on("b")#5. Darstellung zweidimensionaler Graphik#off("b")#
+#type ("times8")#
+
+ Bei der Darstellung zweidimensionaler Bilder muß der zu zeichnende Ausschnitt (das
+ #on("i")#Fenster#off("i")#) angegeben werden. Mit der Prozedur #on("b")#window#off("b")# wird durch Angabe der minimalen
+ und maximalen X- bzw. Y-Koordinaten ein Fenster definiert. Linien, die über dieses
+ Fenster hinausgehen, werden abgeschnitten. Dadurch kann man einen beliebigen Detailaus­
+ schnitt eines Bildes ausgeben, ohne das Bild neu generieren zu müssen.
+ Da das so definierte Fenster auf die mit #on("i")#viewport#off("i")# definierte Zeichenfläche abgebildet wird,
+ ist der Abbildungsmaßstab durch das Zusammenspiel von #on("i")#viewport#off("i")# und #on("i")#window#off("i")# bestimmt.
+ Wenn eine Winkeltreue Darstellung erreicht werdenn soll, muß das Verhältnis der durch
+ #on("i")#viewport#off("i")# eingestellten Breite und Höhe und das Verhältnis des durch #on("i")#window#off("i")# eingestellten
+ Ausschnitts gleich sein.
+
+#type ("trium12")#
+#on("b")#6. Darstellung dreidimensionaler Graphik#off("b")#
+#type ("times8")#
+
+ Bei dreidimensionalen Zeichnungen wird das Fenster ebenfalls mit #on("b")#window#off("b")# definiert,
+ wobei dann allerdings auch der Wertebereich der dritten Dimension (Z-Koordinaten) zu
+ berücksichtigen ist. Auch hierbei werden Linien, die über die spezifierte Darstellungs­
+ fläche hinausgehen abgeschnitten. Das Abschneiden erfolgt allerdings erst nach der Projek­
+ tion auf die Darstellungsfläche, so daß auch Vektoren zu sehen sind, die über das mit
+ #on("i")#window#off("i")# angegebene Quader hinausgehen, wenn ihre Projektion innerhalb der Zeichen­
+ fläche liegt.
+ Da die dreidimensionale Graphik auf eine zweidimensionale Fläche projeziert wird,
+ können aber noch weitere Darstellungsparameter angegeben werden. Der Betrachtungswin­
+ kel wird mit Hilfe der Prozedur #on("b")#view#off("b")# angegeben. Ebenfalls kann mit #on("b")#view#off("b")# der Winkel der
+ Y-Achse zur Horizontalen angegeben werden.
+ Zur Spezifikation der gewünschten Projektionsart existieren #on("b")#orthographic#off("b")# (orthographische
+ Projektion), #on("b")#perspective#off("b")# (perspektivische Projektion, der Fluchtpunkt ist frei wählbar) und
+ #on("b")#oblique#off("b")# (schiefwinklige Projektion).
+
+#page#
+#type ("trium12")#
+#on("b")#7. Beispiele#off("b")#
+#type ("times8")#
+
+ #on("u")#Sinuskurve#off("u")#
+
+#type("micro")#
+initialisiere picfile;
+zeichne überschrift;
+zeichne achsen;
+zeichne sinuskurve;
+wähle darstellung;
+plot (p) .
+
+initialisiere picfile:
+ PICFILE VAR p :: picture file ("SINUS") .
+
+zeichne überschrift:
+ PICTURE VAR überschrift :: nilpicture;
+ move (überschrift, -pi/2.0, 1.0);
+ draw (überschrift, "sinus (x) [-pi, +pi]", 0.0, 1.0, 0.6);
+ put picture (p, überschrift) .
+
+ zeichne achsen:
+ PICTURE VAR achsen :: nilpicture;
+ zeichne x achse;
+ zeichne y achse;
+ put picture (p, achsen) .
+
+ zeichne x achse:
+ move (achsen, -pi, 0.0);
+ draw (achsen, pi, 0.0) .
+
+ zeichne y achse:
+ move (achsen, 0.0, -1.0);
+ draw (achsen, 0.0, +1.0) .
+
+ zeichne sinuskurve:
+ PICTURE VAR sinus :: nilpicture;
+ REAL VAR x :: -pi;
+
+ move (sinus, x, sin (x));
+ REP x INCR 0.1;
+ draw (sinus, x, sin (x))
+ UNTIL x >= pi PER;
+
+ put picture (p, sinus) .
+
+ wähle darstellung:
+ window (p, -pi, pi, -1.0, 1.3);
+ viewport (p, 0.0, 0.0, 0.0, 0.0) .
+
+#page#
+#type ("times8")#
+ #on("u")#Achsenkreuz#off("u")#
+
+#type("micro")#
+initialisiere picfile;
+zeichne die x achse;
+zeichne die y achse;
+zeichne die z achse;
+stelle das achsenkreuz dar .
+
+initialisiere picfile:
+ PICFILE VAR p :: picture file ("KREUZ") .
+
+ zeichne die x achse:
+ PICTURE VAR x achse := nilpicture;
+ move (x achse, -1.0, 0.0, 0.0);
+ draw (x achse, "-X", 0.0, 0.0, 0.0);
+ draw (x achse, 1.0, 0.0, 0.0);
+ draw (x achse, "+X", 0.0, 0.0, 0.0);
+ put picture (p, x achse) .
+
+ zeichne die y achse:
+ PICTURE VAR y achse := nilpicture;
+ move (y achse, 0. 0, -1.0, 0.0);
+ draw (y achse, "-Y", 0.0, 0.0, 0.0);
+ draw (y achse, 0.0, 1.0, 0.0);
+ draw (y achse, "+Y", 0.0, 0.0, 0.0);
+ put picture (p, y achse) .
+
+ zeichne die z achse:
+ PICTURE VAR z achse := nilpicture;
+ move (z achse, 0. 0, 0.0, -1.0);
+ draw (z achse, "-Z", 0.0, 0.0, 0.0);
+ draw (z achse, 0.0, 0.0, 1.0);
+ draw (z achse, "+Z", 0.0, 0.0, 0.0);
+ put picture (p, z achse) .
+
+ stelle das achsenkreuz dar:
+ viewport (p, 0. 0, 1.0, 0.0, 1.0);
+ window (p, -1.1, 1.1, -1.1, 1.1);
+ oblique (p, 0.25, 0.15);
+ plot (p) .
+
+#foot#
+ #type("times6")#
+ Diese beiden Beispielprogramme befinden sich ebenfalls auf dem STD-Archive unter dem Namen #on("i")#Beispiel.Sinus#off("i")# und
+ #on("i")#Beispiel.Kreuz#off("i")#.
+#end#
+
+#page#
+#type ("triumb14")# Beschreibung der Graphik-Prozeduren
+#type ("times8")#
+
+
+#type ("trium12")#
+#on("b")#1. PICTURE-Prozeduren#off("b")#
+#type ("times8")#
+
+#limit (7.0)##type("times6")#
+ #on("i")#Zweidimensionale PICTURES brauchen weniger Speicherplatz
+ als dreidimensionale. Daher werden in einigen Fehlermeldungen
+ unterschiedliche Größen angegeben.
+
+#limit (11.0)##type("times8")#
+
+#type("times10")##on("b")#:=#off("b")##type("times8")#
+ OP := (PICTURE VAR l, PICTURE CONST r)
+ Zweck: Zuweisung
+
+#type("times10")##on("b")#CAT#off("b")##type("times8")#
+ OP CAT (PICTURE VAR l, PICTURE CONST r)
+ Zweck: Aneinanderfügen von zwei PICTURE.
+ Fehlerfälle:
+ * left dimension <> right dimension
+ Es können nur PICTURE mit gleicher Dimension angefügt werden.
+ * Picture overflow
+ Die beiden PICTURE überschreiten die maximale Größe eines PICTURE.
+
+#type("times10")##on("b")#nilpicture#off("b")##type("times8")#
+ PICTURE PROC nilpicture
+ Zweck: Die Prozedur liefert ein leeres PICTURE zur Initialisierung.
+
+ PICTURE PROC nilpicture (INT CONST pen)
+ Zweck: Die Prozedur liefert ein leeres PICTURE mit dem Stift #on("i")#pen#off("i")# zur Initialisierung.
+
+#type("times10")##on("b")#draw#off("b")##type("times8")#
+ PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, ­
+ width)
+ Zweck: Der angegebene Text wird unter dem Winkel #on("i")#angle#off("i")# gegenüber der Waagerech­
+ ten mit der Zeichenhöhe #on("i")#hight#off("i")# und der Breite #on("i")#width#off("i")# gezeichnet. #on("i")#angle#off("i")# wird in
+ Winkelgrad angegeben. #on("i")#height#off("i")# und #on("i")#width#off("i")# werden in #on("i")#Prozenten#off("i")# der Breite bzw.
+ Höhe der Zeichenfläche angegeben, bei 0 wird
+ die Standardhöhe- und breite angenommen.
+ Der Anfang ist dabei die aktuelle Stiftposition, die nicht verändert wird. Es könne
+ auch die Steuerzeichen ""1"", ""2"", ""3"", ""10"", ""13"" benutzt werden,
+ wobei sie immer in der Richtung #on("i")#angle#off("i")# wirken.
+ Fehlerfälle:
+ * Picture overflow
+ Der Text paßt nicht mehr in das PICTURE.
+
+#type("times10")##on("b")#draw#off("b")##type("times8")#
+ PROC draw (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y, z).
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC draw (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y).
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+#type("times10")##on("b")#draw r#off("b")##type("times8")#
+ PROC draw r (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Zeichnen einer Linie der Länge (x, y, z) relativ zur aktuellen Position.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC draw r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie der Länge (x, y) relativ zur aktuellen Position.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+#type("times10")##on("b")#move#off("b")##type("times8")#
+ PROC move (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Die aktuelle Position wird auf (x, y, z) gesetzt.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC move (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird auf (x, y) gesetzt.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+#type("times10")##on("b")#move r#off("b")##type("times8")#
+ PROC move r (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Die aktuelle Position wird um (x, y, z) erhöht.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC move r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird um (x, y) erhöht.
+ Position.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+
+#type("times10")##on("b")#bar#off("b")##type("times8")#
+ PROC bar (PICTURE VAR p, REAL CONST width, hight, INT CONST pattern):
+ Zweck: Die Prozedur zeichnet an der aktuellen Position einen Balken mit dem Muster
+ #on("i")#pattern#off("i")#:
+ 0 = Leerer Balken
+ 1 = Gepunkteter Balken
+ 2 = Gefüllter Balken
+ 3 = Horizontale Linien
+ 4 = Vertikale Linien
+ 5 = Gekreuzte Linien
+ 6 = Diagonale Linien von Links nach Rechts
+ 7 = Diagonale Linien von Rechts nach Links
+ 8 = Gekreuzte diagonale Linien
+ > 8 = nicht normiertes Sondermuster
+ Die aktuelle Stiftposition wird dabei nicht verändert.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+ PROC bar (PICTURE VAR p, REAL CONST from, to, hight, INT CONST pattern):
+ Zweck: Die Prozedur zeichnet einen Balken von der Position #on("i")#from#off("i")# zur Position #on("i")#to#off("i")# und der
+ Höhe #on("i")#height#off("i")# mit dem Muster #on("i")#pattern#off("i")#.
+ s.o.
+
+#type("times10")##on("b")#circle#off("b")##type("times8")#
+ PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern)
+ Zweck: Die Prozedur zeichnet an der aktuellen Position ein Kreissegment vom Winkel
+ #on("i")#from#off("i")# bis #on("i")#to#off("i")# (im Gradmaß) mit dem Muster #on("i")#pattern#off("i")# (s.o.). Der #on("i")#radius#off("i")# wird in
+ Prozenten der Diagonalen der Zeichenfläche angegeben.
+ Die aktuelle Stiftposition wird dabei nicht verändert. Dieses Kreissegment ist in
+ jedem Fall 2-dimensional, so das es durch Drehungen nicht verändert wird.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+#type("times10")##on("b")#mark#off("b")##type("times8")#
+ PROC mark (PICTURE VAR p, REAL CONST size, INT CONST no)
+ Zweck: Es wird ein Marker mit der Größe #on("i")#size#off("i")# in Prozenten der Diagonalen der Zeichen­
+ fläche an der aktuellen Stiftposition ausgegeben, ohne diese zu verändern. Es
+ sollten dabei mindestens 10 verschiedene Marker gewählt werden können.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+#type("times10")##on("b")#dim#off("b")##type("times8")#
+ INT PROC dim (PICTURE CONST pic)
+ Zweck: Liefert die Dimension eines PICTURE.
+
+#type("times10")##on("b")#pen#off("b")##type("times8")#
+ INT PROC pen (PICTURE CONST p)
+ Zweck: Liefert den virtuellen Stift des PICTURE
+
+ PICTURE PROC pen (PICTURE CONST p, INT CONST pen)
+ Zweck: Setzen des (virtuellen) Stiftes eines PICTURE.
+ Bei #on("i")#pen#off("i")# = 0 wird das Picture nicht gezeichnet.
+ Fehlerfälle:
+ * pen out of range
+ Der gewünschte Stift ist kleiner als 0 oder größer als 16.
+
+#type("times10")##on("b")#extrema#off("b")##type("times8")#
+ PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max)
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE.
+ Fehlerfälle:
+ * Picture is three dimensional
+
+ PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max,  
+ z min, z max)
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE.
+ Fehlerfälle:
+ * Picture is two dimensional
+
+#type("times10")##on("b")#where#off("b")##type("times8")#
+ PROC where (PICTURE CONST p, REAL VAR x, y, z)
+ Zweck: Die Prozedur liefert die aktuelle Stiftposition.
+ Fehlerfälle:
+ * Picture is two dimensional
+
+ PROC where (PICTURE CONST p, REAL VAR x, y, z)
+ Zweck: Die Prozedur liefert die aktuelle Stiftposition. Fehlerfälle:
+ * Picture is three dimensional
+
+#type("times10")##on("b")#rotate#off("b")##type("times8")#
+ PROC rotate (PICTURE VAR p, REAL CONST angle)
+ Zweck: Das PICTURE wird um den Punkt (0, 0) um den Winkel #on("i")#angle#off("i")# (im Gradmaß) im
+ mathematisch positiven Sinn gedreht.
+
+ PROC rotate (PICTURE CONST p, REAL CONST phi, theta, lambda)
+ Zweck: Das PICTURE wird um den Winkel #on("i")#lambda#off("i")# um die Drehachse #on("i")#(phi, theta)#off("i")# ge­
+ dreht.
+
+#type("times10")##on("b")#stretch#off("b")##type("times8")#
+ PROC stretch (PICTURE VAR pic, REAL CONST sx, sy)
+ Zweck: Das PICTURE wird in X-Richtung um den Faktor #on("i")#sx#off("i")#, in Y-Richtung um den
+ Faktor #on("i")#sy#off("i")# gestreckt (bzw. gestaucht). Dabei bewirkt der Faktor
+ s > 1 eine Streckung
+ 0 < s < 1 eine Stauchung
+ s < 0 zusätzlich eine Achsenspiegelung.
+ Fehlerfälle:
+ * Picture is three dimensional
+
+ PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz)
+ Zweck: s. o.
+ Fehlerfälle:
+ * Picture is two dimensional
+
+#type("times10")##on("b")#translate#off("b")##type("times8")#
+ PROC translate (PICTURE VAR p, REAL CONST dx, dy)
+ Zweck: Das PICTURE wird um #on("i")#dx#off("i")# und #on("i")#dy#off("i")# verschoben. Fehlerfälle:
+ * Picture is three dimensional
+
+ PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz)
+ Zweck: Das PICTURE wird um #on("i")#dx, dy#off("i")# und #on("i")#dz#off("i")# verschoben. Fehlerfälle:
+ * Picture is two dimensional
+
+
+#type ("trium12")#
+#on("b")#2. PICFILE-Prozeduren#off("b")#
+#type ("times8")#
+
+#type("times10")##on("b")#plot#off("b")##type("times8")#
+ PROC plot (TEXT CONST name)
+ Zweck: Der PICFILE mit dem Namen #on("i")#name#off("i")# wird entsprechend der angegebenen Dar­
+ stellungsart gezeichnet. Diese Parameter (#on("i")#perspective, orthographic, oblique, view,
+ window etc.#off("i")#) müssen vorher eingestellt werden.
+ Fehlerfälle:
+ * PICFILE does not exist
+ Es existiert kein PICFILE mit dem Namen #on("i")#name#off("i")#
+
+ PROC plot (PICFILE VAR p)
+ Zweck: Der PICFILE #on("i")#p#off("i")# wird entsprechend der angegebenen Darstellungsart gezeichnet.
+ Diese Parameter müssen vorher eingestellt werden:
+
+ #on("b")#zweidimensional:#off("b")#
+ obligat: #on("i")#window#off("i")# (zweidimensional)
+ optional: #on("i")#view#off("i")# (zweidimensional)
+ #on("i")#viewport#off("i")#
+ #on("i")#select pen#off("i")#
+
+ #on("b")#dreidimensional:#off("b")#
+ obligat: #on("i")#window#off("i")# (dreidimensional)
+ optional: #on("i")#view#off("i")# (dreidimensional)
+ #on("i")#orthographic | perspective | oblique#off("i")#
+ #on("i")#viewport#off("i")#
+ #on("i")#select pen#off("i")#
+
+
+#type("times10")##on("b")#select pen#off("b")##type("times8")#
+ PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type)
+ Zweck: Für die Darstellung des Bildes #on("i")#p#off("i")# soll dem #on("i")#virtuellen#off("i")# Stift #on("i")#pen#off("i")# ein realer Stift
+ zugeordnet werden, der möglichst die Farbe #on("i")#colour#off("i")# und die Dicke #on("i")#thickness#off("i")# hat
+ und dabei Linien mit dem Typ #on("i")#line type#off("i")# zeichnet. Es wird die beste Annäherung
+ für das Ausgabegerät genommen.
+ Dabei gelten folgende Vereinbarungen:
+
+ #on("b")#Farbe:#off("b")# Negative Farben werden XOR gezeichnet (dunkel wird hell und hell wird
+ dunkel), Farbe 0 ist der Löschstift und positive Farben überschreiben
+ (ersetzen) den alten Punkt mit folgenden Werten:
+
+ 1 Standardfarbe des Endgerätes
+ 2 rot
+ 3 blau
+ 4 grün
+ 5 schwarz
+ 6 weiß
+ > 6 nicht normierte Sonderfarben
+
+
+ #on("b")#Dicke:#off("b")# 0 Standardstrichstärke des Endgerätes
+ > 0 Strichstärke in 1/10 mm.
+
+
+ #on("b")#Linientyp:#off("b")#
+ 0 keine sichtbare Linie
+ 1 durchgängige Linie
+ 2 gepunktete Linie
+ 3 kurz gestrichelte Linie
+ 4 lang gestrichelte Linie
+ 5 Strichpunktlinie
+ > 5 nicht normierte Linie
+
+
+ Die hier aufgeführten Möglichkeiten müssen nicht an allen graphischen Endge­
+ räten vorhanden sein. Der geräteabhängige Graphik-Treiber wählt jeweils die
+ bestmögliche Annäherung.
+
+ Fehlerfälle:
+ * pen out of range
+ #on("i")#pen#off("i")# muss im Bereich 1-16 sein.
+
+#type("times10")##on("b")#background#off("b")##type("times8")#
+ PROC background (PICFILE VAR p, INT CONST colour)
+ Zweck: Der Hintergrund wird auf die Farbe #on("i")#colour#off("i")# (s.o.) gesetzt wenn möglich.
+ Bei der Angabe #on("i")#background (p, 0)#off("i")# wird das Löschen des Bildschirms unterdrückt,
+ so daß das Zeichen mehrerer PICFILE auf einem Blatt möglich wird.
+
+ INT PROC background (PICFILE CONST p):
+ Zweck: Liefert die eingestellte Hintergrundfarbe.
+
+#type("times10")##on("b")#view#off("b")##type("times8")#
+ PROC view (PICFILE VAR p, REAL CONST alpha)
+ Zweck: Setzt den Winkel der Y-Achse zur Senkrechten auf #on("i")#alpha#off("i")# Grad, falls diese nicht
+ senkrecht auf der Betrachtungsebene steht.
+
+ PROC view (PICFILE VAR p, REAL CONST phi, theta)
+ Zweck: Dreidimensionale Bilder werden häufig nicht direkt von vorne dargestellt, son­
+ dern für die Betrachtung gedreht. Mit der Prozedur #on("i")#view#off("i")# kann die Betrachtungs­
+ richtung durch die Polarwinkel #on("i")#phi#off("i")# und #on("i")#theta#off("i")# (im Gradmass) angegeben werden.
+ Voreingestellt ist #on("i")#phi#off("i")# = 0 und #on("i")#theta#off("i")# = 0, d.h. senkrecht von oben (Die #on("i")#X-
+ Achse#off("i")# bildet die Horizontale und die #on("i")#Y-Achse#off("i")# bildet die Vertikale).
+ Im Gegensatz zu #on("i")#rotate#off("i")# hat #on("i")#view#off("i")# keine Wirkung auf das eigentliche Bild (die
+ PICTURE werden nicht verändert), sondern nur auf die gewählte Darstellung. So
+ addieren sich zwar aufeinanderfolgende #on("i")#Rotationen#off("i")#, #on("i")#view#off("i")# aber geht immer von der
+ Nullstellung aus. Auch kann das Bild durch eine #on("i")#Rotation#off("i")# ganz oder teilweise aus
+ oder in das Darstellungsfenster (#on("i")#window#off("i")# gedreht werden. Bei #on("i")#view#off("i")# verändern sich
+ die Koordinaten der Punkte nicht, d. h. das Fenster wird mitgedreht.
+
+ PROC view (PICFILE VAR p, REAL CONST x, y, z)
+ Zweck: Wie oben, nur werden die Winkel nicht in Polarkoordinaten angegeben, sondern
+ es wird die Blickrichtung als Vektor in Karthesischen Koordinaten angegeben.
+ (Der Betrachtungsvektor muß nicht normiert sein).
+
+#type("times10")##on("b")#viewport#off("b")##type("times8")#
+ PROC viewport (PICFILE VAR p, REAL CONST hormin, hormax, vertmin, vertmax)
+ Zweck: Die Zeichenfläche auf dem Endgerät, auf dem das Bild dargestellt werden soll,
+ wird spezifiziert. Dabei wird sowohl die Größe als auch die relative Lage der
+ Zeichenfläche definiert. Der linke untere Eckpunkt der physikalischen Zeichen­
+ fläche des Gerätes hat die Koordinaten (0, 0). Die definierte Zeichenfläche er­
+ streckt sich
+
+ #on("i")#hormin - hormax#off("i")# in der Horizontalen,
+ #on("i")#vertmin - vertmax#off("i")# in der Vertikalen.
+
+ So liegt der linke untere Eckpunkt dann bei (#on("i")#hormin, hormax#off("i")#), der rechte obere
+ Eckpunkt bei (#on("i")#hormax, vertmax#off("i")#).
+
+ Damit sowohl geräteunabhängige als auch maßstabgetreue Zeichnungen möglich
+ sind, können die Koordinaten in drei Arten spezifiziert werden:
+ a) #on("b")#Gerätekoordinaten#off("b")#
+ Die Koordinaten können Werte von 0.0 bis 2.0 annehmen. Dabei hat die
+ kürzere Seite der physikalischen Zeichenfläche definitionsgemäß die Länge
+ 1.0.
+ b) #on("b")#Absolute Koordinaten#off("b")#
+ Die Werte werden in #on("i")#cm#off("i")# angegeben. Dabei müssen die Maximalwerte aber
+ größer als 2.0 sein, da sonst Fall a) angenommen wird.
+ c) #on("b")#Maximale Zeichenfläche#off("b")# Bei der Angabe (0.0, 0.0, 0.0, 0.0) wird die maxi­
+ male physikalische Zeichenfläche eingestellt.
+
+ Voreingestellt ist
+ viewport (0.0, 0.0, 0.0, 0.0)
+ d.h. die größtmögliche physikalische Zeichenfläche, beginnend mit der linken
+ unteren Ecke.
+ Der Abbildungsmaßstab wird durch das Zusammenspiel von #on("i")#viewport#off("i")# und
+ #on("i")#window#off("i")# festgelegt (s. dort). Dabei ist insbesondere darauf zu achten, daß winkel­
+ treue Darstellung nur bei gleichen Verhältnissen von X-Bereich und Breite bzw.
+ von Y-Bereich und Höhe möglich ist.
+
+
+#type("times10")##on("b")#window#off("b")##type("times8")#
+ PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max)
+ Zweck: Für die Darstellung eines zweidimensionalen Bildes wird das darzustellende
+ Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im Intervall [#on("i")#x min, x
+ max#off("i")#] und deren Y-Koordinaten im Bereich [#on("i")#y min, y max#off("i")#] liegen, gehören zum
+ definierten Fenster.Vektoren, die außerhalb dieses Fensters liegen, gehen über die
+ durch #on("i")#viewport#off("i")# Fläche hinaus und werden abgeschnitten.
+
+ Der Darstellungsmaßstab ergibt sich als
+
+ #ub#               x max - x min               #ue#
+ horizontale Seitenlänge der Zeichenfläche
+
+
+ #ub#               y max - y min               #ue#
+ vertikale Seitenlänge der Zeichenfläche
+
+ PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max,  
+ z min, z max)
+
+ Zweck: Für die darstellung eines dreidimensionalen Bildes wird das darzustellende Fenster
+ definiert. Alle Bildpunkte, deren X-Koordinaten im Intervall [#on("i")#x min, x max#off("i")#],
+ deren Y-Koordinaten im Bereich [#on("i")#y min, y max#off("i")#] und deren Z-Koordinaten im
+ Bereich [#on("i")#z min, z max#off("i")#] liegen, gehören zum definierten Fenster. Dieses dreidi­
+ mensionale Fenster (#on("i")#Quader#off("i")#) wird entsprechend der eingestellten Projektionsart
+ (orthographisch, perspektivisch oder schiefwinklig) und den Betrachtungswinkeln
+ (s. #on("i")#view#off("i")#) auf die spezifizierte Zeichenfläche abgebildet.
+ Anders als im zweidimensionalen Fall ist das Problem der Maßstaäbe nicht mehr
+ nur durch das Zusammenspiel von #on("i")#window#off("i")# und #on("i")#viewport#off("i")# zu beschreiben. Hier
+ spielen auch die Projektionsart und Darstellungswinkel herein.
+
+#type("times10")##on("b")#oblique#off("b")##type("times8")#
+ PROC oblique (PICFILE VAR p, REAL CONST a, b)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("i")#p#off("i")# wird #on("u")#schiefwinklig#off("u")# als gewünschte Projek­
+ tionsart eingestellt. Dabei ist (#on("i")#a, b#off("i")#) der Punkt auf der X-Y-Ebene, auf den der
+ EinheitsVektor der Z-Richtung abgebildet werden soll.
+
+#type("times10")##on("b")#orthographic#off("b")##type("times8")#
+ PROC orthographic (PICFILE VAR p)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("i")#p#off("i")# wird #on("u")#orthographisch#off("u")# als gewünschte Projek­
+ tionsart eingestellt. Bei der orthographischen Projektion wird ein dreidimensio­
+ naler Körper mit parallelen Strahlen senkrecht auf der Projektionsebene abge­
+ bildet.
+
+#type("times10")##on("b")#perpective#off("b")##type("times8")#
+ PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("i")#p#off("i")# wird #on("u")#perspektivisch#off("u")# als gewünschte Projek­
+ tionsart eingestellt. Der Punkt (#on("i")#cx, 1/cy, cz#off("i")#) ist der Fluchtpunkt der Projektion,
+ d. h. alle Parallen zur Z-Achse schneiden sich in diesem Punkt.
+
+#type("times10")##on("b")#extrema#off("b")##type("times8")#
+ PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max)
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE.
+
+ PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max)
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE.
+
+#type ("trium12")#
+#on("b")#3. Prozeduren zur Manipulation von PICFILE#off("b")#
+#type("times 8")#
+
+#type("times10")##on("b")#:=#off("b")##type("times8")#
+ OP := (PICFILE VAR l, PICFILE CONST r)
+ Zweck: Zuweisung des PIFILEs #on("i")#r#off("i")# an das PICFILE #on("i")#l#off("i")#
+
+ OP := (PICFILE VAR p, DATASPACE CONST d)
+ Zweck: Assoziert die PICFILE Variable #on("i")#p#off("i")# mit dem Datenraum #on("i")#d#off("i")# und initialisiert die
+ Variable, wenn nötig.
+ Fehlerfälle:
+ * dataspace is no PICFILE
+ Der anzukoppelnde Datenraum hat einen unzulässigen Typ
+
+#type("times10")##on("b")#picture file#off("b")##type("times8")#
+ DATASPACE PROC picture file (TEXT CONST name)
+ Zweck: Assoziaten eines benannten Datenraumes mit einem PICFILE (s.o.).
+
+#type("times10")##on("b")#to pic#off("b")##type("times8")#
+ PROC to pic (PICFILE VAR p, INT CONST pos)
+ Zweck: Positioniert auf das PICTURE Nummer #on("i")#pos#off("i")#.
+ Fehlerfälle:
+ * Position underflow
+ Es wurde eine Position kleiner Null angegeben.
+ * Position after eof
+ Es wurde versucht, hinter das Ende eines PICFILE zu positionieren. Die letzte
+ erlaubte Position ist #on("i")#pictures (p)+1#off("i")#.
+
+#type("times10")##on("b")#up#off("b")##type("times8")#
+ PROC up (PICFILE VAR p)
+ Zweck: Positioniert genau ein PICTURE zurück.
+ Fehlerfall:
+ * Position underflow
+ Es wurde versucht, vor das erste PICTURE zu positionieren
+
+ PROC up (PICFILE VAR p, INT CONST n)
+ Zweck: Positioniert genau #on("i")#n#off("i")# Picture zurück.
+ Fehlerfall:
+ * Position underflow
+ Es wurde versucht, vor das erste PICTURE zu positionieren
+
+#type("times10")##on("b")#down#off("b")##type("times8")#
+ PROC down (PICFILE VAR p)
+ Zweck: Positioniert genau ein PICTURE vorwärts.
+ Fehlerfall:
+ * Position after eof
+ Es wurde versucht, hinter das Ende eines PICFILE zu positionieren. Die letzte
+ erlaubte Position ist #on("i")#pictures (p)+1#off("i")#.
+
+ PROC down (PICFILE VAR p, INT CONST n)
+ Zweck: Positioniert genau #on("i")#n#off("i")# Picture vorwärts.
+ Fehlerfall:
+ * Position after eof
+ Es wurde versucht, hinter das Ende eines PICFILE zu positionieren Die letzte
+ erlaubte Position ist #on("i")#pictures (p)+1#off("i")#.
+
+#type("times10")##on("b")#delete picture#off("b")##type("times8")#
+ PROC delete picture (PICFILE VAR p)
+ Zweck: Löscht das aktuelle PICTURE
+
+#type("times10")##on("b")#insert picture#off("b")##type("times8")#
+ PROC insert picture (PICFILE VAR p)
+ Zweck: Fügt ein PICTURE #on("u")#vor#off("u")# der aktuellen Position ein.
+
+#type("times10")##on("b")#read picture#off("b")##type("times8")#
+ PROC read picture (PICFILE CONST p, PICTURE VAR pic)
+ Zweck: Liest das aktuelle PICTURE.
+
+#type("times10")##on("b")#write picture#off("b")##type("times8")#
+ PROC write picture (PICFILE VAR p, PICTURE CONST pic)
+ Zweck: Schreibt das PICTURE #on("i")#pic#off("i")# auf der aktuellen Position.
+
+#type("times10")##on("b")#put picture#off("b")##type("times8")#
+ PROC put picture (PICFILE VAR p, PICTURE CONST pic)
+ Zweck: Schreibt das PICTURE #on("i")#pic#off("i")# an die aktuelle Position und erhöht diese um 1.
+
+#type("times10")##on("b")#get picture#off("b")##type("times8")#
+ PROC get picture (PICFILE VAR p, PICTURE VAR pic)
+ Zweck: Liest das PICTURE #on("i")#pic#off("i")# an dir aktuellen Position und erhöht diese um 1.
+
+#type("times10")##on("b")#eof#off("b")##type("times8")#
+ BOOL PROC eof (PICFILE CONST p)
+ Zweck: Liefert genau dann #on("i")#TRUE#off("i")#, wenn das Ende eines PICFILE erreicht ist.
+
+#type("times10")##on("b")#picture no#off("b")##type("times8")#
+ INT PROC picture no (PICFILE CONST p)
+ Zweck: Liefert die Nummer des aktuellen PICTURE.
+
+#type("times10")##on("b")#pictures#off("b")##type("times8")#
+ INT PROC pictures (PICFILE CONST p)
+ Zweck: Liefert die Anzahl PICTURE eines PICFILE.
+
+
+#page#
+#type ("trium12")#
+#on("b")#4. Auslieferungsumfang#off("b")#
+#type ("times8")#
+
+ Die EUMEL-GRAPHIK wird auf einer Diskette mit folgendem Inhalt ausgeliefert.
+ Archive #on("i")#Graphik#off("i")#:
+
+ "gen Graphik"
+ "gen Plotter"
+ "GRAPHIK.book"
+ "GRAPHIK.Picfile"
+ "GRAPHIK.Transform"
+ "GRAPHIK.Plot"
+ "GRAPHIK.Plotter"
+ "GRAPHIK.Server"
+ "GRAPHIK.vektor plot"
+ "ZEICHENSATZ"
+ "PC.plot"
+ "HP7475.plot"
+ "Beispiel.Kreuz"
+ "Beispiel.Sinus"
+
+
+
+ #on("u")#Dateiinhalte#off("u")#
+
+ 1. "gen Graphik" Installationsprogramm für Terminals
+ 2. "gen Plotter" Installationsprogramm für Plotter
+ 3. "GRAPHIK.book" enthält diese Beschreibung.
+ 4. "GRAPHIK.Picfile" enthält die Pakete #on("i")#picture#off("i")# und #on("i")#picfile#off("i")#.
+ 5. "GRAPHIK.Transform" stellt das Paket #on("i")#transformation#off("i")# zur Verfügung, in dem
+ interne Prozeduren zur Projektion definiert werden.
+ 6. "GRAPHIK.Plot" definiert die Prozedur #on("i")#plot#off("i")# zur Darstellung eines
+ PICFILES auf dem Terminal
+ 7. "GRAPHIK.Plotter" definiert die Prozedur #on("i")#plotter#off("i")# zur Darstellung eines
+ PICFILES auf dem Plotter
+ 8. "GRAPHIK.Server" Server für einen Plotter-Spool
+ 9. "GRAPHIK.vektor plot" enthält Hilfsprogramme, die bei der Erstellung einer
+ eigenen Terminalanpassung benutzt werden können.
+ 10. "ZEICHENSATZ" enthält einen Zeichensatz für Terminals die im Graphik
+ Modus keinen Text ausgeben können.
+ 11. "PC.plot" Terminalanpassung für IBM-PC und ähnliche.
+ 12. "HP7475.plot" Terminalanpassung für HP7474-Plotter und Geräte mit
+ HP-GL.
+ 13. "Beispiel.Kreuz" Beispielprogramm
+ 14. "Beispiel.Sinus" Beispielprogramm
+
+#type ("trium12")#
+#on("b")#5. Installation#off("b")#
+#type ("times8")#
+
+
+ In der Datei #on("i")#gen Graphik#off("i")# ist ein Installationspragramm enthalten. Nach dem Starten des
+ Programms mit #on("i")#run ("gen Graphik")#off("i")# fragt es nach dem Dateinamen der Terminalanpas­
+ sung.
+ Steht keine Terminalanpassung für ein Endgerät zur Verfügung (und kann auch nicht
+ beschafft werden) so kann man durch Insertieren der Datei #on("i")#GRAPHIK.Picfile#off("i")# lediglich die
+ Leistungen der Pakete #on("i")#Picture#off("i")# und #on("i")#Picfile#off("i")# nutzen, ohne die erzeugten Graphiken darstellen
+ zu können.
+ Zur Benutzung eines #on("i")#Plotters#off("i")# über einen Spooler wird die Datei #on("i")#gen Plotter#off("i")# gestartet.
+
+
+ Beispiel:
+ 1. archive ("Graphik")
+ 2. fetch all (archive)
+ 3. release (archive)
+ 4. run ("gen Graphik")
+ <-- PC.Plot
+
+
+#type ("trium12")#
+#on("b")#6. Besonderheiten der PC.plot-Anpassung#off("b")#
+#type ("times8")#
+
+
+ Da der IBM-PC verschiedene Graphik- und Text-Modi kennt, wird durch das Pro­
+ gramm #on("i")#PC.plot#off("i")# die Prozedur #on("i")#graphik#off("i")# zusätzlich zur Verfügung gestellt. Sie erlaubt es den
+ PC in verschiedenen Graphik-Modi zu betreiben.
+
+ PROC graphik (INT CONST modus, pause)
+
+ Modus: 0 --- Keine Graphik (normaler Textmodus)
+ 1 --- hochauflösende Graphik, 50 Zeilen,
+ 640 * 400 Punkte, einfarbig
+ 2 --- hochauflösende Graphik, 25 Zeilen,
+ 640 * 400 Punkte, einfarbig
+ 3 --- mittlere Auflösung, 640 * 200 Punkte, 3 Farben
+ 4 --- IBM-PC Auflösung, 320 * 200 Punkte, 3 Farben.
+
+ Pause: Da der PC bei #on("i")#end plot#off("i")# wieder in den Normalmodus umschaltet und die Graphik
+ dann nicht mehr zu sehen ist, kann man eine #on("i")#pause#off("i")# angeben. Die hier eingestellte
+ Zeit ist aber nicht die Länge der Pause, sondern der Kehrwert der Blinkfrequenz
+ proportional.
+
+
diff --git a/system/std.graphik/1.8.7/doc/graphik beschreibung b/system/std.graphik/1.8.7/doc/graphik beschreibung
new file mode 100644
index 0000000..53ebe49
--- /dev/null
+++ b/system/std.graphik/1.8.7/doc/graphik beschreibung
@@ -0,0 +1,661 @@
+#type ("basker12")##limit (16.0)##block#
+
+#head#
+#type ("triumb18")#
+#center#EUMEL-Grafik-System
+#type ("basker12")#
+#end#
+ #on("italics")#gescheit, gescheiter,
+ gescheitert#off("italics")#
+
+#type ("basker14")#
+#on("bold")#Beschreibung der Graphik-Prozeduren#off("bold")#
+#type ("basker12")#
+
+ #on("italics")#Zweidimensionale PICTURE brauchen weniger Speicherplatz als dreidimen­
+ sionale. Daher werden in einigen Fehlermeldungen unterschiedliche Größen
+ angegeben.#off("italics")#
+
+#on("underline")#Picture-Prozeduren#off("underline")#
+PICTURE
+
+
+:=
+ OP := (PICTURE VAR l, PICTURE CONST r)
+ Zweck: Zuweisung
+
+CAT
+ OP CAT (PICTURE VAR l, PICTURE CONST r)
+ Zweck: Aneinanderfügen von zwei PICTURE.
+ Fehlerfälle:
+ * left dimension <> right dimension
+ Es können nur PICTURE mit gleicher Dimension angefügt werden.
+ * Picture overflow
+ Die beiden PICTURE überschreiten die maximale Größe eines
+ PICTURE.
+
+nilpicture
+ PICTURE PROC nilpicture
+ Zweck: Die Prozedur liefert ein leeres PICTURE zur Initialisierung.
+
+draw
+ PROC draw (PICTURE VAR p, TEXT CONST text)
+ Zweck: Der angegebene Text wird gezeichnet. Der Anfang ist dabei die aktuelle
+ Stiftposition, die nicht verändert wird.
+ Fehlerfälle:
+ * Picture overflow
+ Der Text paßt nicht mehr in das PICTURE.
+
+ PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle,
+ height, bright)
+ Zweck: Der angegebene Text wird unter dem Winkel #on("italics")#angle#off("italics")# gegenüber der
+ Waagerechten mit der Zeichenhöhe #on("italics")#hight#off("italics")# und der Breite #on("italics")#bright#off("italics")# gezeich­
+ net. Der Anfang ist dabei die aktuelle Stiftposition, die nicht verändert
+ wird.
+ Fehlerfälle:
+ * Picture overflow
+ Der Text paßt nicht mehr in das PICTURE.
+
+ PROC draw (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y, z).
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC draw (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y).
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+draw r PROC draw r (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Zeichnen einer Linie der Länge (x, y, z) relativ zur aktuellen Position.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC draw r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie der Länge (x, y) relativ zur aktuellen Position.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+draw cm
+ PROC draw cm (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y) cm.
+ Dabei werden die angegebenen Projektionsparameter nicht beachtet,
+ sondern die Angaben in #on("bold")#Zentimeter#off("bold")# berechnet.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+draw cm r
+ PROC draw cm r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie der Länge (x, y) cm relativ zur aktuellen Position.
+ Dabei werden die angegebenen Projektionsparameter nicht beachtet,
+ sondern die Angaben in #on("bold")#Zentimeter#off("bold")# berechnet.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+move
+ PROC move (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Die aktuelle Position wird auf (x, y, z) gesetzt.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC move (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird auf (x, y) gesetzt.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+move r
+ PROC move r (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Die aktuelle Position wird um (x, y, z) erhöht.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC move r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird um (x, y) erhöht.
+ Position.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+move cm
+ PROC move cm (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird auf (x, y) cm gesetzt. Dabei werden die an­
+ gegebenen Projektionsparameter nicht beachtet, sondern die Angaben in #on("bold")#
+ Zentimeter#off("bold")# berechnet.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+move cm r
+ PROC move cm r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird um (x, y) cm erhöht. Dabei werden die an­
+ gegebenen Projektionsparameter nicht beachtet, sondern die Angaben in #on("bold")#
+ Zentimeter#off("bold")# berechnet.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+bar
+ PROC bar (PICTURE VAR p, REAL CONST width, hight, INT CONST
+ pattern):
+ Zweck: Die Prozedur zeichnet an der aktuellen Position einen Balken mit dem
+ Muster #on("italics")#pattern#off("italics")#: 0 = Leerer Balken
+ 1 = Gepunkteter Balken
+ 2 = Gefüllter Balken
+ 3 = Horizontale Linien
+ 4 = Vertikale Linien
+ 5 = Gekreuzte Linien
+ 6 = Diagonale Linien von Links nach Rechts
+ 7 = Diagonale Linien von Rechts nach Links
+ 8 = Gekreuzte diagonale Linien.
+ Die aktuelle Stiftposition wird dabei nicht verändert.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+ * Unknown pattern
+ Das angegebene Muster liegt nicht im Bereich 0-8
+
+circle
+ PROC circle (PICTURE VAR p, REAL CONST from, to, INT CONST
+ pattern)
+ Zweck: Die Prozedur zeichnet an der aktuellen Position ein Kreissegment vom
+ Winkel #on("italics")#from#off("italics")# bis #on("italics")#to#off("italics")# (im Gradmaß) mit dem Muster #on("italics")#pattern#off("italics")# (s.o.). Die
+ aktuelle Stiftposition wird dabei nicht verändert.
+ Fehlerfälle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+ * Unknown pattern
+ Das angegebene Muster liegt nicht im Bereich 0-8
+
+dim
+ INT PROC dim (PICTURE CONST pic)
+ Zweck: Liefert die Dimension eines PICTURE.
+
+pen
+ INT PROC pen (PICTURE CONST p)
+ Zweck: Liefert den virtuellen Stift des PICTURE
+
+ PROC pen (PICTURE VAR p, INT CONST pen)
+ Zweck: Setzen des (virtuellen) Stiftes eines PICTURE. Bei pen=0 wird das
+ Picture nicht gezeichnet.
+ Fehlerfälle:
+ * pen out of range
+ Der gewünschte Stift ist kleiner als 0 oder größer als 16.
+
+extrema
+ PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y
+ max)
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE.
+ Fehlerfälle:
+ * Picture is three dimensional
+
+ PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y
+ max, z min, z max)
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICTURE.
+ Fehlerfälle:
+ * Picture is two dimensional
+
+where
+ PROC where (PICTURE CONST p, REAL VAR x, y, z)
+ Zweck: Die Prozedur liefert die aktuelle Stiftposition (Angaben mit #on("italics")#cm#off("italics")# werden
+ dabei nicht berücksichtigt).
+ Fehlerfälle:
+ * Picture is two dimensional
+
+ PROC where (PICTURE CONST p, REAL VAR x, y, z)
+ Zweck: Die Prozedur liefert die aktuelle Stiftposition (Angaben mit #on("italics")#cm#off("italics")# werden
+ dabei nicht berücksichtigt).
+ Fehlerfälle:
+ * Picture is three dimensional
+
+rotate:
+ PROC rotate (PICTURE VAR p, REAL CONST angle)
+ Zweck: Das PICTURE wird um den Punkt (0, 0) um den Winkel #on("italics")#angle#off("italics")# (im
+ Gradmaß) im mathematisch positiven Sinn gedreht.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verändert.
+
+ PROC rotate (PICTURE CONST p, REAL CONST phi, theta, lambda ) :
+ PICTURE 1-397
+ Zweck: Das PICTURE wird um den Winkel #on("italics")#lambda#off("italics")# um die Drehachse #on("italics")#(phi,
+ theta)#off("italics")# gedreht.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verändert.
+
+stretch
+ PROC stretch (PICTURE VAR pic, REAL CONST sx, sy)
+ Zweck: Das PICTURE wird in X-Richtung um den Faktor #on("italics")#sx#off("italics")#, in Y-Rich­
+ tung um den Faktor #on("italics")#sy#off("italics")# gestreckt (bzw. gestaucht). Dabei bewirkt der
+ Faktor
+ s > 1 eine Streckung
+ 0 < s < 1 eine Stauchung
+ s < 0 zusätzlich eine Achsenspiegelung.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verändert.
+ Fehlerfälle:
+ * Picture is three dimensional
+
+ PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz)
+ Zweck: s. o.
+ Fehlerfälle:
+ * Picture is two dimensional
+
+translate
+ PROC translate (PICTURE VAR p, REAL CONST dx, dy)
+ Zweck: Das PICTURE wird um #on("italics")#dx#off("italics")# und #on("italics")#dy#off("italics")# verschoben.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verändert.
+ Fehlerfälle:
+ * Picture is three dimensional
+
+ PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz)
+ Zweck: s. o.
+ Fehlerfälle:
+ * Picture is two dimensional
+
+plot PROC plot (PICTURE CONST p)
+ Zweck: Das Picfile wird gezeichnet.
+ Achtung: Es wird kein #on("italics")#begin plot#off("italics")# oder #on("italics")#end plot#off("italics")# durchgeführt. Es wird
+ auch kein Stift gsetzt und die Projektionsparameter bleiben
+ unverändert.
+
+
+#on("underline")#Graphische PICFILE-Prozeduren#off("underline")#
+plot
+ PROC plot (TEXT CONST name)
+ Zweck: Der PICFILE mit dem Namen #on("italics")#name#off("italics")# wird entsprechend der angegebenen
+ Darstellungsart gezeichnet. Diese Parameter (#on("italics")#perspective, orthographic,
+ oblique, view, window etc.#off("italics")#) müssen vorher eingestellt werden.
+ Fehlerfälle:
+ * PICFILE does not exist
+ Es existiert kein PICFILE mit dem Namen #on("italics")#name#off("underline")#
+
+ PROC plot (PICFILE VAR p)
+ Zweck: Der PICFILE #on("italics")#p#off("italics")# wird entsprechend der angegebenen Darstellungsart ge­
+ zeichnet. Diese Parameter müssen vorher eingestellt werden:
+
+ #on("bold")#zweidimensional:#off("bold")#
+ obligat: #on("italics")#window#off("italics")# (zweidimensional)
+ optional: #on("italics")#view#off("italics")# (zweidimensional)
+ #on("italics")#viewport#off("italics")#
+ #on("italics")#select pen#off("italics")#
+
+ #on("bold")#dreidimensional:#off("bold")#
+ obligat: #on("italics")#window#off("italics")# (dreidimensional)
+ optional: #on("italics")#view#off("italics")# (dreidimensional)
+ #on("italics")#orthographic | perspective | oblique#off("italics")#
+ #on("italics")#viewport#off("italics")#
+ #on("italics")#select pen#off("italics")#
+
+
+select pen
+ PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line
+ type,
+ BOOL VAR hidden lines) Zweck: Für die
+ Darstellung des Bildes #on("italics")#p#off("italics")# soll dem #on("italics")#virtuellen#off("italics")# Stift #on("italics")#pen#off("italics")# ein realer Stift
+ zugeordnet werden, der möglichst die Farbe #on("italics")#colour#off("italics")# und die Dicke #on("italics")#thick­
+ ness#off("italics")# hat und dabei Linien mit dem Typ #on("italics")#line type#off("italics")# zeichnet. Es wird die
+ beste Annäherung für das Ausgabegerät genommen.
+ Wenn #on("italics")#hidden lines#off("italics")# auf TRUE gesetzt wird, werden bei dreidimensionalen
+ Zeichnungen die verdeckten Linien mitgezeichnet, ansonsten werden sie
+ unterdrückt. Um sicherzustellen, das der Algorithmus auch funktioniert,
+ müssen die Linien allerdings von vorn nach hinten gezeichnet werden. Es
+ ist also nicht möglich, das Bild so zu drehen, das die hinteren Linien
+ zuerst gezeichnet werden.
+ Dabei gelten folgende Vereinbarungen:
+
+ #on("bold")#Farbe:#off("bold")# Negative Farben werden XOR gezeichnet (dunkel wird hell und
+ hell wird dunkel), Farbe 0 ist der Löschstift und positive Farben
+ überschreiben (ersetzen) den alten Punkt mit folgenden Werten:
+
+ 1 Standardfarbe des Endgerätes
+ 2 rot
+ 3 blau
+ 4 grün
+ 5 schwarz
+ 6 weiß
+ > 6 nicht normierte Sonderfarben
+
+
+ #on("bold")#Dicke:#off("bold")# 0 Standardstrichstärke des Endgerätes, ansonsten Strichstärke in
+ 1/10 mm.
+
+
+ #on("bold")#Linientyp:#off("bold")#
+ 0 keine sichtbare Linie
+ 1 durchgängige Linie
+ 2 gepunktete Linie
+ 3 kurz gestrichelte Linie
+ 4 lang gestrichelte Linie
+ 5 Strichpunktlinie
+ > 5 nicht normierte Linie
+
+ #on("bold")#Verdeckte Linien:#off("bold")#
+ TRUE Verdeckte Linien werden mitgezeichnet
+ FALSE Verdeckte Linien werden unterdrückt (nur bei drei­
+ dimensionalen PICTURE)
+
+ Die hier aufgeführten Möglichkeiten müssen nicht an allen graphischen
+ Endgeräten vorhanden sein. Der geräteabhängige Graphik-Treiber wählt
+ jeweils die bestmögliche Annäherung.
+
+ Fehlerfälle:
+ * pen out of range
+ #on("italics")#pen#off("italics")# muss im Bereich 1-16 sein.
+
+background
+ PROC background (PICFILE VAR p, INT CONST colour)
+ Zweck: Der Hintergrund wird auf die Farbe #on("italics")#colour#off("italics")# (s.o.) gesetzt wenn möglich.
+
+ INT PROC background (PICFILE CONST p):
+ Zweck: Liefert die eingestellte Hintergrundfarbe.
+
+view
+ PROC view (PICFILE VAR p, REAL CONST alpha)
+ Zweck: Setzt den Winkel der Y-Achse zur Senkrechten auf #on("italics")#alpha#off("italics")# Grad, falls
+ diese nicht senkrecht zur Betrachtungsebene steht.
+
+ PROC view (PICFILE VAR p, REAL CONST phi, theta)
+ Zweck: Dreidimensionale Bilder werden häufig nicht direkt von vorne dargestellt,
+ sondern für die Betrachtung gedreht. Mit der Prozedur #on("italics")#view#off("italics")# kann die
+ Betrachtungsrichtung durch die Polarwinkel #on("italics")#phi#off("italics")# und #on("italics")#theta#off("italics")# (im Gradmass)
+ angegeben werden. Voreingestellt ist #on("italics")#phi#off("italics")# = 0 und #on("italics")#theta#off("bold")# = 0, d.h. senk­
+ recht von oben.
+
+ Im Gegensatz zu #on("italics")#rotate#off("italics")# hat #on("italics")#view#off("italics")# keine Wirkung auf das eigentliche Bild
+ (PICFILE), sondern nur auf die gewählte Darstellung. So addieren sich
+ zwar aufeinanderfolgende #on("italics")#Rotationen#off("italics")#, #on("italics")#view#off("italics")# aber geht immer von der
+ Nullstellung aus. Auch kann das Bild durch eine #on("italics")#Rotation#off("italics")# ganz oder
+ teilweise aus oder in das Darstellungsfenster (#on("italics")#window#off("italics")# gedreht werden. Bei
+ #on("italics")#view#off("italics")# verändern sich die Koordinaten der Punkte nicht, d. h. das Fenster
+ wird mitgedreht.
+
+ PROC view (PICFILE VAR p, REAL CONST x, y, z)
+ Zweck: Wie oben, nur werden die Winkel nicht in Polarkoordinaten angegeben,
+ sondern es wird die Blickrichtung als Vektor in Karthesischen Koordina­
+ ten angegeben. (Die Länge darf ungleich 1 sein).
+
+viewport
+ PROC viewport (PICFILE VAR p, REAL CONST hormin, hormax, vertmin,
+ vertmax) : 1-709
+ Zweck: Die Zeichenfläche auf dem Endgerät, auf dem das Bild dargestellt werden
+ soll, wird spezifiziert. Dabei wird sowohl die Größe als auch die relative
+ Lage der Zeichenfläche definiert. Der linke untere Eckpunkt der physi­
+ kalischen Zeichenfläche des Gerätes hat die Koordinaten (0, 0). Die
+ definierte Zeichenfläche erstreckt sich
+
+ #on("italics")#hormin - hormax#off("italics")# in der Horizontalen,
+ #on("italics")#vertmin - vertmax#off("italics")# in der Vertikalen.
+
+ So liegt der linke untere Eckpunkt dann bei (#on("italics")#hormin, hormax#off("italics")#), der rechte
+ obere Eckpunkt bei (#on("italics")#hormax, vertmax#off("italics")#).
+
+ Damit sowohl geräteunabhängige als auch maßstabgetreue Zeichnungen
+ möglich sind, können die Koordinaten in zwei Arten spezifiziert werden:
+ a) #on("bold")#Gerätekoordinaten#off("bold")#
+ Die Koordinaten können Werte von 0.0 bis 2.0 annehmen. Dabei
+ hat die kürzere Seite der physikalischen Zeichenfläche definitionsge­
+ mäß die Länge 1.0.
+ b) #on("bold")#Absolute Koordinaten#off("bold")#
+ Die Werte werden in #on("italics")#cm#off("italics")# angegeben. Dabei müssen die Maximal­
+ werte aber größer als 2.0 sein, da sonst Fall a) angenommen wird.
+
+ Voreingestellt ist
+
+ viewport (0.0, 1.0, 0.0, 1.0)
+
+ d.h. das größtmögliche Quadrat, beginnend mit der linken unteren Ecke
+ der physikalischen Zeichenfläche. In vielen Fällen wird diese Einstellung
+ ausreichen, so daß der Anwender kein eigenes #on("italics")#viewport#off("italics")# definieren muss.
+
+ Der Abbildungsmaßstab wird durch das Zusammenspiel von #on("italics")#viewport#off("italics")# und
+ #on("italics")#window#off("italics")# festgelegt (s. dort). Dabei ist insbesondere darauf zu achten, daß
+ winkeltreue Darstellung nur bei gleichen X- und Y-Maßstab möglich
+ ist. Da man oft quadratische Fenster (#on("italics")#window#off("italics")#) verwendet, wurde als
+ Standardeinstellung auch ein quadratisches #on("italics")#viewport#off("italics")# gewählt.
+
+ Hinweis: Mit der Prozedur #on("italics")#check limit#off("italics")# aus dem PACKET #on("italics")#basis plot#off("italics")# kann die
+ Überprüfung der Grenzen des eingestellten #on("italics")#viewport#off("italics")#-Bereiches ein-
+ bzw. ausgeschaltet werden. Bei eingeschateter Überprüfung, werden
+ Linien, die den Bereich überschreiten, am Rand abgetrennt.
+
+
+window
+ PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max)
+ Zweck: Für die Darstellung eines zweidimensionalen Bildes wird das darzustel­
+ lende Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im In-
+ tervall [#on("italics")#x min, x max#off("italics")#] und deren Y-Koordinaten im Bereich [#on("italics")#y min, y
+ max#off("italics")#] liegen, gehören zum definierten Fenster.Vektoren, die außerhalb
+ dieses Fensters liegen, gehen über die durch #on("italics")#viewport#off("italics")# Fläche hinaus
+ (s.dort).
+
+ Der Darstellungsmaßstab ergibt sich als
+
+ #ub#               x max - x min               #ue#
+ horizontale Seitenlänge der Zeichenfläche
+
+
+ #ub#               y max - y min               #ue#
+ vertikale Seitenlänge der Zeichenfläche
+
+ PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max,
+ z min, z max)
+
+ Zweck: Für die darstellung eines dreidimensionalen Bildes wird das darzustellende
+ Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im Intervall [#on("italics")#x
+ min, x max#off("italics")#], deren Y-Koordinaten im Bereich [#on("italics")#y min, y max#off("italics")#] und
+ deren Z-Koordinaten im Bereich [#on("italics")#z min, z max#off("italics")#] liegen, gehören zum
+ definierten Fenster. Dieses dreidimensionale Fenster (#on("italics")#Quader#off("italics")#) wird ent­
+ sprechend der eingestellten Projektionsart (orthographisch, perspektivisch
+ oder schiefwinklig) und den Betrachtungswinkeln (s. #on("italics")#view#off("italics")#) auf die spezi­
+ fizierte Zeichenfläche abgebildet.
+ Anders als im zweidimensionalen Fall ist das Problem der Maßstaäbe
+ nicht mehr nur durch das Zusammenspiel von #on("italics")#window#off("italics")# und #on("italics")#viewport#off("italics")# zu
+ beschreiben. Hier spielen auch die Projektionsart und Darstellungswinkel
+ herein.
+
+oblique:
+ PROC oblique (PICFILE VAR p, REAL CONST a, b)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#schiefwinklig#off("underline")# als gewünschte
+ Projektionsart eingestellt. Dabei ist (#on("italics")#a, b#off("italics")#) der Punkt auf der X-Y-
+ Ebene, auf den der Einheitsvektor der Z-Richtung abgebildet werden
+ soll.
+
+orthographic
+ PROC orthographic (PICFILE VAR p)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#orthographisch#off("underline")# als gewünschte
+ Projektionsart eingestellt. Bei der orthographischen Projektion wird ein
+ dreidimensionaler Körper mit parallelen Strahlen senkrecht auf der Pro­
+ jektionsebene dabgebildet.
+
+perpective
+ PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#perspectivisch#off("underline")# als gewünschte
+ Projektionsart eingestellt. Der Punkt (#on("italics")#cx, 1/cy, cz#off("underline")#) ist der Fluchtpunkt der
+ Projektion, d. h. alle Parallen zur Z-Achse schneiden sich in diesem
+ Punkt.
+
+extrema
+ PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max)
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE.
+
+ PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z
+ min,z max) : 1-651
+ Zweck: Die Prozedur liefert die größten und kleinsten Werte des PICFILE.
+
+
+#on("underline")#Prozeduren zur Manipulation von PICFILE#off("underline")#
+:=
+ OP := (PICFILE VAR p, DATASPACE CONST d)
+ Zweck: Assoziert die PICFILE Variable #on("italics")#p#off("italics")# mit dem Datenraum #on("italics")#d#off("italics")# und initialisiert
+ die Variable, wenn nötig.
+ Fehlerfälle:
+ * dataspace is no PICFILE
+ Der anzukoppelnde Datenraum hat einen unzulässigen Typ
+
+picture file
+ DATASPACE PROC picture file (TEXT CONST name)
+ Zweck: Assoziaten eines benannten Datenraumes mit einem PICFILE (s.o.).
+
+put
+ PROC put (FILE VAR f, PICFILE VAR p)
+ Zweck: Schreibt den Inhalt eines PICFILE in ein FILE. Die Informationen
+ werden im internen Format abgelegt.
+
+get
+ PROC get (PICFILE VAR p, FILE VAR f)
+ Zweck: Liest den Inhalt eines PICFILE aus einem FILE. Die Informationen
+ müssen mit #on("italics")#put#off("italics")# geschrieben worden sein.
+ Fehlerfall:
+ * Picfile overflow
+ Es können nur maximal 1024 Picture (Sätze) in einem PICFILE abgelegt
+ werden.
+
+to first pic
+ PROC to first pic (PICFILE VAR p)
+ Zweck: Positioniert auf das erste PICTURE.
+
+to eof
+ PROC to last pic (PICFILE VAR p)
+ Zweck: Positioniert hinter das letzte PICTURE.
+
+to pic
+ PROC to pic (PICFILE VAR p, INT CONST pos)
+ Zweck: Positioniert auf das PICTURE Nummer #on("italics")#pos#off("italics")#.
+ Fehlerfälle:
+ * Position underflow
+ Es wurde eine Position kleiner Null angegeben. * Position after
+ eof Es wurde versucht, hinter das Ende eines PICFILE zu positionieren
+
+up
+ PROC up (PICFILE VAR p)
+ Zweck: Positioniert genau ein PICTURE zurück.
+ Fehlerfall:
+ * Position underflow
+ Es wurde versucht, vor das erste PICTURE zu positionieren
+
+ PROC up (PICFILE VAR p, INT CONST n)
+ Zweck: Positioniert genau #on("italics")#n#off("italics")# Picture zurück.
+ Fehlerfall:
+ * Position underflow
+ Es wurde versucht, vor das erste PICTURE zu positionieren
+
+down
+ PROC down (PICFILE VAR p)
+ Zweck: Positioniert genau ein PICTURE vorwärts.
+ Fehlerfall:
+ * Position after eof
+ Es wurde versucht, hinter das Ende eines PICFILE zu positionieren
+
+ PROC down (PICFILE VAR p, INT CONST n)
+ Zweck: Positioniert genau #on("italics")#n#off("italics")# Picture vorwärts.
+ Fehlerfall:
+ * Position after eof
+ Es wurde versucht, hinter das Ende eines PICFILE zu positionieren
+
+is first picture
+ BOOL PROC is first picture (PICFILE CONST p)
+ Zweck: Liefert genau dann #on("italics")#TRUE#off("italics")#, wenn das erste PICTURE erreicht ist.
+
+eof
+ BOOL PROC eof (PICFILE CONST p)
+ Zweck: Liefert genau dann #on("italics")#TRUE#off("italics")#, wenn das Ende eines PICFILE erreicht ist.
+
+picture no
+ INT PROC picture no (PICFILE CONST p)
+ Zweck: Liefert die Nummer des aktuellen PICTURE.
+
+pictures
+ INT PROC pictures (PICFILE CONST p)
+ Zweck: Liefert die Anzahl PICTURE eines PICFILE.
+
+delete picture
+ PROC delete picture (PICFILE VAR p)
+ Zweck: Löscht das aktuelle PICTURE
+
+insert picture
+ PROC insert picture (PICFILE VAR p)
+ Zweck: Fügt ein PICTURE #on("underline")#vor#off("underline")# der aktuellen Position ein.
+
+read picture
+ PROC read picture (PICFILE CONST p, PICTURE VAR pic)
+ Zweck: Liest das aktuelle PICTURE.
+
+write picture
+ PROC write picture (PICFILE VAR p, PICTURE CONST pic)
+ Zweck: Schreibt das PICTURE #on("italics")#pic#off("italics")# auf der aktuellen Position.
+
+put picture
+ PROC write picture (PICFILE VAR p, PICTURE CONST pic)
+ Zweck: Schreibt das PICTURE #on("italics")#pic#off("italics")# hinter das letzte PICTURE des PICFILE.
+ Die aktuelle Position wird nicht verändert.
+
+#page#
+ #on("italics")#Wo wir sind, da klappt nichts,
+ aber wir können nicht überall sein !#off("italics")#
+
+#type ("basker14")#
+#on("bold")#Kurzbeschreibung des Graphik-Editors#off("bold")#
+#type ("basker12")#
+
+In der Kommondozeile werden folgende Informationen angezeigt:
+
+#on("revers")#LEN nnnnn <...Name...> DIM n PEN nn Picture nnnn
+#off("revers")#
+
+
+Folgende Kommandos stehen zur Verfügung:
+
+ PICTURE PROC pic neu
+ PICFILE PROC picfile neu
+ PROC neu zeichnen
+
+ OP UP n (n PICTURE up)
+ OP DOWN n (n PICTURE down)
+ OP T n (to PICTURE n)
+
+ PROC oblique (REAL CONST a, b)
+ PROC orthographic
+ PROC perspective (REAL CONST cx, cy, cz)
+ PROC window (BOOL CONST dev)
+ PROC window (REAL CONST x min, x max, y min, y max)
+ PROC window (REAL CONST x min, x max, y min, y max, z min, z max)
+ PROC viewport (REAL CONST h min, h max, v min, v max)
+ PROC view (REAL CONST alpha)
+ PROC view (REAL CONST phi, theta)
+ PROC view (REAL CONST x, y, z)
+
+ PROC pen (INT CONST n)
+ PROC select pen (INT CONST pen, colour, thickness, line type, BOOL CONST
+ hidden)
+ PROC background (INT CONST colour)
+
+ PROC extrema pic
+ PROC extrema picfile
+ PROC selected pen
+
+ PROC rotate (REAL CONST angle)
+ PROC rotate (REAL CONST phi, theta, lambda )
+ PROC stretch (REAL CONST sx, sy)
+ PROC stretch (REAL CONST sx, sy, sz)
+ PROC translate (REAL CONST dx, dy)
+ PROC translate (REAL CONST dx, dy, dz)
+
diff --git a/system/std.graphik/1.8.7/source-disk b/system/std.graphik/1.8.7/source-disk
new file mode 100644
index 0000000..8e7ff34
--- /dev/null
+++ b/system/std.graphik/1.8.7/source-disk
@@ -0,0 +1 @@
+grundpaket/05_std.graphik.img
diff --git a/system/std.graphik/1.8.7/src/Beispiel.Kreuz b/system/std.graphik/1.8.7/src/Beispiel.Kreuz
new file mode 100644
index 0000000..e29f24a
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/Beispiel.Kreuz
@@ -0,0 +1,41 @@
+initialisiere picfile;
+zeichne die x achse;
+zeichne die y achse;
+zeichne die z achse;
+stelle das achsenkreuz dar .
+
+initialisiere picfile:
+ PICFILE VAR p :: picture file ("KREUZ") .
+
+zeichne die x achse:
+ PICTURE VAR x achse := nilpicture;
+ move (x achse, -1.0, 0.0, 0.0);
+ draw (x achse, "-X", 0.0, 0.0, 0.0);
+ draw (x achse, 1.0, 0.0, 0.0);
+ draw (x achse, "+X", 0.0, 0.0, 0.0);
+ put picture (p, x achse) .
+
+zeichne die y achse:
+ PICTURE VAR y achse := nilpicture;
+ move (y achse, 0.0, -1.0, 0.0);
+ draw (y achse, "-Y", 0.0, 0.0, 0.0);
+ draw (y achse, 0.0, 1.0, 0.0);
+ draw (y achse, "+Y", 0.0, 0.0, 0.0);
+ put picture (p, y achse) .
+
+zeichne die z achse:
+ PICTURE VAR z achse := nilpicture;
+ move (z achse, 0.0, 0.0, -1.0);
+ draw (z achse, "-Z", 0.0, 0.0, 0.0);
+ draw (z achse, 0.0, 0.0, 1.0);
+ draw (z achse, "+Z", 0.0, 0.0, 0.0);
+ put picture (p, z achse) .
+
+stelle das achsenkreuz dar:
+ viewport (p, 0.0, 1.0, 0.0, 1.0);
+ window (p, -1.1, 1.1, -1.1, 1.1);
+ oblique (p, 0.25, 0.15);
+ plot (p) .
+
+
+
diff --git a/system/std.graphik/1.8.7/src/Beispiel.Sinus b/system/std.graphik/1.8.7/src/Beispiel.Sinus
new file mode 100644
index 0000000..beac7cd
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/Beispiel.Sinus
@@ -0,0 +1,45 @@
+initialisiere picfile;
+zeichne überschrift;
+zeichne achsen;
+zeichne sinuskurve;
+wähle darstellung;
+plot (p) .
+
+initialisiere picfile:
+ PICFILE VAR p :: picture file ("SINUS") .
+
+zeichne überschrift:
+ PICTURE VAR überschrift :: nilpicture;
+ move (überschrift, -pi/2.0, 1.0);
+ draw (überschrift, "sinus (x) [-pi, +pi]", 0.0, 1.0, 0.6);
+ put picture (p, überschrift) .
+
+zeichne achsen:
+ PICTURE VAR achsen :: nilpicture;
+ zeichne x achse;
+ zeichne y achse;
+ put picture (p, achsen) .
+
+zeichne x achse:
+ move (achsen, -pi, 0.0);
+ draw (achsen, pi, 0.0) .
+
+zeichne y achse:
+ move (achsen, 0.0, -1.0);
+ draw (achsen, 0.0, +1.0) .
+
+zeichne sinuskurve:
+ PICTURE VAR sinus :: nilpicture;
+ REAL VAR x :: -pi;
+
+ move (sinus, x, sin (x));
+ REP x INCR 0.1;
+ draw (sinus, x, sin (x))
+ UNTIL x >= pi PER;
+
+ put picture (p, sinus) .
+
+wähle darstellung:
+ window (p, -pi, pi, -1.0, 1.3);
+ viewport (p, 0.0, 0.0, 0.0, 0.0) .
+
diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Picfile b/system/std.graphik/1.8.7/src/GRAPHIK.Picfile
new file mode 100644
index 0000000..3accf52
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/GRAPHIK.Picfile
@@ -0,0 +1,738 @@
+PACKET picture DEFINES (*Autor: Heiko.Indenbirken *)
+ PICTURE, (*Stand: 12.03.1985 *)
+ :=, CAT, nilpicture, (*Änderung: 20.08.85/10:38 *)
+ draw, draw r, (*Änderung: 05.08.86/12:21 *)
+ move, move r,
+ mark, bar, circle,
+ length, dim, pen, where,
+ extrema, rotate, stretch, translate,
+ picture:
+
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ bar 2 key = 6,
+ bar 3 key = 7,
+ circle key = 8,
+ mark key = 9,
+ max length = 31974;
+
+LET overflow = "Picture overflow",
+ pen range = "pen out of range [0-16]",
+ dim 3 = "Picture is 3 dimensional",
+ dim 2 = "Picture is 2 dimensional",
+ dim init = "Picture isn't initialized",
+ wrong key = "wrong key code",
+ nil = "",
+ zero = ""0"";
+
+TYPE PICTURE = STRUCT (INT dim, pen, TEXT points);
+
+
+INT VAR read pos;
+REAL VAR x, y, z;
+TEXT VAR r1 :: 8*zero, r2 :: 16*zero, r3 :: 24*zero, i1 :: 2*zero;
+
+OP := (PICTURE VAR l, PICTURE CONST r) :
+ CONCR (l) := CONCR (r)
+END OP :=;
+
+OP CAT (PICTURE VAR l, PICTURE CONST r) :
+ check dim (l, r.dim);
+ IF length (l.points) > max length - length (r.points)
+ THEN errorstop (overflow) FI;
+
+ l.points CAT r.points
+END OP CAT;
+
+PICTURE PROC nilpicture :
+ PICTURE : (0, 1, nil)
+END PROC nilpicture;
+
+PICTURE PROC nilpicture (INT CONST pen):
+ PICTURE : (0, pen, nil)
+END PROC nilpicture;
+
+PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, bright):
+ write (p.points, text, angle, height, bright, text key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p.points, x, y, z, draw key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p.points, x, y, draw key)
+END PROC draw;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p.points, x, y, z, draw r key)
+END PROC draw r;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p.points, x, y, draw r key)
+END PROC draw r;
+
+PROC move (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p.points, x, y, z, move key)
+END PROC move;
+
+PROC move (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p.points, x, y, move key)
+END PROC move;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p.points, x, y, z, move r key)
+END PROC move r;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p.points, x, y, move r key)
+END PROC move r;
+
+PROC bar (PICTURE VAR p, REAL CONST width, height, INT CONST pattern):
+ check dim (p, 2);
+ write (p.points, width, height, pattern, bar 2 key)
+END PROC bar;
+
+PROC bar (PICTURE VAR p, REAL CONST from, to, height, INT CONST pattern):
+ check dim (p, 2);
+ write (p.points, from, to, height, pattern, bar 3 key)
+END PROC bar;
+
+PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern):
+ check dim (p, 2);
+ write (p.points, radius, from, to, pattern, circle key)
+END PROC circle;
+
+PROC mark (PICTURE VAR p, REAL CONST size, INT CONST no):
+ write (p.points, size, no, mark key)
+END PROC mark;
+
+PROC write (TEXT VAR points, REAL CONST x, y, z, INT CONST key) :
+ IF length (points) < max length
+ THEN points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ points CAT r3
+ ELSE errorstop (overflow) FI
+END PROC write;
+
+PROC write (TEXT VAR points, REAL CONST x, y, INT CONST key) :
+ IF length (points) < max length
+ THEN points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ points CAT r2
+ ELSE errorstop (overflow) FI
+END PROC write;
+
+PROC write (TEXT VAR points, REAL CONST x, y, INT CONST n, key) :
+ IF length (points) < max length
+ THEN points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ points CAT r2;
+ replace (i1, 1, n);
+ points CAT i1
+ ELSE errorstop (overflow) FI
+END PROC write;
+
+PROC write (TEXT VAR points, REAL CONST x, y, z, INT CONST n, key) :
+ IF length (points) < max length
+ THEN points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ points CAT r3;
+ replace (i1, 1, n);
+ points CAT i1
+ ELSE errorstop (overflow) FI
+END PROC write;
+
+PROC write (TEXT VAR points, TEXT CONST t, REAL CONST angle, height, bright,
+ INT CONST key) :
+ IF max length - length (points) >= length (t)
+ THEN points CAT code (key);
+ replace (i1, 1, length (t));
+ points CAT i1;
+ points CAT t;
+ replace (r3, 1, angle);
+ replace (r3, 2, height);
+ replace (r3, 3, bright);
+ points CAT r3
+ FI;
+END PROC write;
+
+PROC write (TEXT VAR points, REAL CONST size, INT CONST no, key) :
+ IF length (points) < max length
+ THEN points CAT code (key);
+ replace (r1, 1, size);
+ points CAT r1;
+ replace (i1, 1, no);
+ points CAT i1;
+ ELSE errorstop (overflow) FI
+END PROC write;
+
+PROC check dim (PICTURE VAR p, INT CONST dim):
+ IF p.dim = dim
+ THEN
+ ELIF p.dim = 0
+ THEN p.dim := dim
+ ELSE errorstop (dimension) FI .
+
+dimension:
+ IF p.dim = 2
+ THEN dim 2
+ ELIF p.dim = 3
+ THEN dim 3
+ ELSE dim init FI .
+
+END PROC check dim;
+
+INT PROC length (PICTURE CONST p):
+ length (p.points)
+END PROC length;
+
+INT PROC dim (PICTURE CONST pic) :
+ pic.dim
+END PROC dim;
+
+PICTURE PROC pen (PICTURE CONST p, INT CONST pen) :
+ IF pen < 0 OR pen > 16
+ THEN errorstop (pen range) FI;
+
+ PICTURE:(p.dim, pen, p.points)
+END PROC pen;
+
+INT PROC pen (PICTURE CONST p) :
+ p.pen
+END PROC pen;
+
+PROC where (PICTURE CONST p, REAL VAR x, y) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0
+ ELIF p.dim = 3
+ THEN errorstop (dim 3)
+ ELSE x := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ y := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1
+ FI
+END PROC where;
+
+PROC where (PICTURE CONST p, REAL VAR x, y, z) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0; z := 0.0
+ ELIF p.dim = 2
+ THEN errorstop (dim 2)
+ ELSE x := subtext (p.points, length (p.points)-23, length (p.points)-16) RSUB 1;
+ y := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ z := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1;
+ FI
+END PROC where;
+
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max, z min, z max) :
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ z min := max real; z max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE text key : read pos INCR next int + 24
+ CASE bar 2 key : read pos INCR 18
+ CASE bar 3 key, circle key : read pos INCR 26
+ CASE mark key: read pos INCR 4
+ OTHERWISE errorstop (wrong key) END SELECT .
+
+calc extrema :
+ x := next real; y := next real; z := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real; z INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max):
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE text key : read pos INCR next int + 24
+ CASE bar 2 key : read pos INCR 18
+ CASE bar 3 key, circle key : read pos INCR 26
+ CASE mark key: read pos INCR 4
+ OTHERWISE errorstop (wrong key) END SELECT .
+
+calc extrema :
+ x := next real; y := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC rotate (PICTURE VAR p, REAL CONST angle) :
+ REAL CONST s :: sind( angle ), c := cosd( angle );
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( 1.0, 0.0, 0.0 ),
+ ROW 3 REAL : ( 0.0, c , s ),
+ ROW 3 REAL : ( 0.0, -s , c ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC rotate;
+
+PROC rotate (PICTURE VAR p, REAL CONST phi, theta, lambda ) :
+ REAL CONST s :: sind ( theta ), c :: cosd ( theta ),
+ s p :: sind ( phi ), s l :: sind ( lambda ),
+ ga :: cosd ( phi ), c l :: cosd ( lambda ),
+ be :: s p * s l, al :: s p * c l, c1 :: 1.0 - c;
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( al*al*c1 + c , be*al*c1+ga*s, ga*al*c1-be*s ),
+ ROW 3 REAL : ( al*be*c1-ga*s, be*be*c1 + c , ga*be*c1+al*s ),
+ ROW 3 REAL : ( al*ga*c1+be*s, be*ga*c1-al*s, ga*ga*c1 + c ),
+ ROW 3 REAL : ( 0.0 , 0.0 , 0.0 )))
+END PROC rotate;
+
+PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) :
+ stretch (pic, sx, sy, 1.0)
+END PROC stretch;
+
+PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( sx, 0.0, 0.0),
+ ROW 3 REAL : (0.0, sy, 0.0),
+ ROW 3 REAL : (0.0, 0.0, sz),
+ ROW 3 REAL : (0.0, 0.0, 0.0)))
+END PROC stretch;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy) :
+ translate (p, dx, dy, 0.0)
+END PROC translate;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : (1.0, 0.0, 0.0),
+ ROW 3 REAL : (0.0, 1.0, 0.0),
+ ROW 3 REAL : (0.0, 0.0, 1.0),
+ ROW 3 REAL : ( dx, dy, dz)))
+END PROC translate;
+
+PROC transform (PICTURE VAR p, ROW 4 ROW 3 REAL CONST a) :
+ INT CONST pic length := length (p.points);
+ INT VAR begin pos;
+ read pos := 0;
+ x := 0.0; y := 0.0; z := 0.0;
+ IF p.dim = 2
+ THEN transform 2 dim pic
+ ELSE transform 3 dim pic FI .
+
+transform 2 dim pic:
+ WHILE read pos < pic length
+ REP transform 2 dim position PER .
+
+transform 2 dim position:
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 2 dim point
+ CASE move key : transform 2 dim point
+ CASE move r key : transform 2 dim point
+ CASE draw r key : transform 2 dim point
+ CASE text key : read pos INCR next int + 24
+ CASE bar 2 key : read pos INCR 18
+ CASE bar 3 key, circle key : read pos INCR 26
+ CASE mark key: read pos INCR 4
+ OTHERWISE errorstop (wrong key) END SELECT .
+
+transform 2 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real;
+ transform (a, x, y, z);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ replace (p.points, begin pos, r2) .
+
+transform 3 dim pic:
+ WHILE read pos < pic length
+ REP transform 3 dim position PER .
+
+transform 3 dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 3 dim point
+ CASE move key : transform 3 dim point
+ CASE move r key : transform 3 dim point
+ CASE draw r key : transform 3 dim point
+ CASE text key : read pos INCR next int + 24
+ CASE bar 2 key : read pos INCR 18
+ CASE bar 3 key, circle key : read pos INCR 26
+ CASE mark key: read pos INCR 4
+ OTHERWISE errorstop (wrong key) END SELECT .
+
+transform 3 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real; z := next real;
+ transform (a, x, y, z);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ replace (p.points, begin pos, r3) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC transform;
+
+PROC transform (ROW 4 ROW 3 REAL CONST a, REAL VAR x, y, z) :
+ REAL CONST ox :: x, oy :: y, oz :: z;
+ x := ox*a(1)(1) + oy*a(2)(1) + oz*a(3)(1) + a(4)(1);
+ y := ox*a(1)(2) + oy*a(2)(2) + oz*a(3)(2) + a(4)(2);
+ z := ox*a(1)(3) + oy*a(2)(3) + oz*a(3)(3) + a(4)(3)
+END PROC transform;
+
+PROC picture (PICTURE CONST pic, TEXT VAR points, INT VAR dim, pen):
+ dim := pic.dim;
+ pen := pic.pen;
+ points := pic.points;
+END PROC picture;
+
+END PACKET picture;
+
+PACKET picfile DEFINES (*Autor: Heiko Indenbirken *)
+ (*Stand: 23.02.1985 *)
+ PICFILE, :=, picture file, (*Änderung: 13.10.89/23:11 *)
+ select pen, selected pen, background,
+ set values, get values,
+ view, viewport, window,
+ oblique, orthographic, perspective,
+ extrema,
+
+ to pic, up, down,
+ eof, picture no, pictures,
+ delete picture, insert picture,
+ read picture, write picture,
+ get picture, put picture:
+
+
+LET no picfile = "dataspace is no PICFILE",
+ pen range = "pen out of range",
+ pos under = "Position underflow",
+ pos over = "Position overflow",
+ pic over = "PICFILE overflow";
+
+LET max pics = 1024,
+ pic dataspace = 1103;
+
+
+TYPE PICFILE = BOUND STRUCT (INT size, pos, background,
+ ROW 16 ROW 3 INT pens,
+ ROW 3 ROW 2 REAL sizes,
+ ROW 2 ROW 2 REAL limits,
+ ROW 4 REAL angles,
+ ROW 2 REAL obliques,
+ ROW 3 REAL perspectives
+ ROW max pics PICTURE pic);
+
+INT VAR i;
+
+OP := (PICFILE VAR l, PICFILE CONST r):
+ EXTERNAL 260
+END OP :=;
+
+OP := (PICFILE VAR p, DATASPACE CONST d) :
+ IF type (d) = pic dataspace
+ THEN CONCR (p) := d
+ ELIF type (d) < 0
+ THEN type (d, pic dataspace) ;
+ CONCR (p) := d ;
+ init picfile dataspace ;
+ ELSE errorstop (no picfile) FI .
+
+init picfile dataspace :
+ r.size := 0;
+ r.pos := 1;
+ r.background := 0;
+ r.sizes := ROW 3 ROW 2 REAL : (ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0));
+ r.limits := ROW 2 ROW 2 REAL : (ROW 2 REAL : (0.0, 0.0),
+ ROW 2 REAL : (0.0, 0.0));
+ r.angles := ROW 4 REAL : (0.0, 0.0, 0.0, 0.0);
+ r.obliques := ROW 2 REAL : (0.0, 0.0);
+ r.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0);
+ FOR i FROM 1 UPTO 16
+ REP r.pens [i] := ROW 3 INT : (1, 0, 1) PER .
+
+r : CONCR (CONCR (p)).
+END OP :=;
+
+DATASPACE PROC picture file (TEXT CONST name) :
+ IF exists (name)
+ THEN old (name)
+ ELSE new (name) FI
+END PROC picture file;
+
+PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type):
+ IF pen < 1 OR pen > 16
+ THEN errorstop (pen range) FI;
+ p.pens [pen] := ROW 3 INT : (colour, thickness, line type)
+END PROC select pen;
+
+PROC selected pen (PICFILE CONST p, INT CONST pen,
+ INT VAR colour, thickness, line type):
+ IF pen < 1 OR pen > 16
+ THEN errorstop (pen range) FI;
+ colour := p.pens [pen][1];
+ thickness := p.pens [pen][2];
+ line type := p.pens [pen][3];
+END PROC selected pen;
+
+INT PROC background (PICFILE CONST p):
+ p.background
+END PROC background;
+
+PROC background (PICFILE VAR p, INT CONST colour):
+ p.background := colour
+END PROC background;
+
+PROC get values (PICFILE CONST p,
+ ROW 3 ROW 2 REAL VAR size,
+ ROW 2 ROW 2 REAL VAR limits,
+ ROW 4 REAL VAR angles,
+ ROW 2 REAL VAR oblique,
+ ROW 3 REAL VAR perspective) :
+ size := p.sizes;
+ limits := p.limits;
+ angles := p.angles;
+ oblique := p.obliques;
+ perspective := p.perspectives;
+
+END PROC get values;
+
+PROC set values (PICFILE VAR p,
+ ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 4 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ p.sizes := size;
+ p.limits := limits;
+ p.angles := angles;
+ p.obliques := oblique;
+ p.perspectives := perspective;
+
+END PROC set values;
+
+PROC view (PICFILE VAR p, REAL CONST alpha):
+ p.angles [1] := alpha
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST phi, theta):
+ p.angles [2] := sind (theta) * cosd (phi);
+ p.angles [3] := sind (theta) * sind (phi);
+ p.angles [4] := cosd (theta);
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST x, y, z):
+ p.angles [2] := x;
+ p.angles [3] := y;
+ p.angles [4] := z
+END PROC view;
+
+PROC viewport (PICFILE VAR p,REAL CONST hor min,hor max,vert min,vert max) :
+ p.limits := ROW 2 ROW 2 REAL : (ROW 2 REAL : (hor min, hor max),
+ ROW 2 REAL : (vert min, vert max))
+END PROC viewport;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) :
+ window (p, x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, z min, z max) :
+ p.sizes := ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max),
+ ROW 2 REAL : (y min, y max),
+ ROW 2 REAL : (z min, z max))
+END PROC window;
+
+PROC oblique (PICFILE VAR p, REAL CONST a, b) :
+ p.obliques := ROW 2 REAL : (a, b);
+ p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0)
+END PROC oblique;
+
+PROC orthographic (PICFILE VAR p) :
+ p.obliques := ROW 2 REAL : (0.0, 0.0);
+ p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0)
+END PROC orthographic;
+
+PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) :
+ p.obliques := ROW 2 REAL : (0.0, 0.0);
+ p.perspectives := ROW 3 REAL : (cx, cy, cz)
+END PROC perspective;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) :
+ REAL VAR dummy;
+ extrema (p, x min, x max, y min, y max, dummy, dummy)
+END PROC extrema;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max) :
+ REAL VAR new x min, new x max, new y min, new y max, new z min, new z max;
+ x min := max real; x max := - max real;
+ y min := max real; y max := - max real;
+ z min := max real; z max := - max real;
+ FOR i FROM 1 UPTO p.size
+ REP IF dim (p.pic [i]) = 2
+ THEN extrema (p.pic [i], new x min, new x max, new y min, new y max)
+ ELSE extrema (p.pic [i], new x min, new x max, new y min, new y max,
+ new z min, new z max)
+ FI;
+ x min := min (x min, new x min); x max := max (x max, new x max);
+ y min := min (y min, new y min); y max := max (y max, new y max);
+ z min := min (z min, new z min); z max := max (z max, new z max);
+ PER
+END PROC extrema;
+
+PROC to pic (PICFILE VAR p, INT CONST n):
+ IF n < 1
+ THEN errorstop (pos under)
+ ELIF n <= p.size+1 AND n <= max pics
+ THEN p.pos := n
+ ELSE errorstop (pos over) FI
+END PROC to pic;
+
+PROC up (PICFILE VAR p):
+ to pic (p, p.pos-1)
+END PROC up;
+
+PROC up (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos-n)
+END PROC up;
+
+PROC down (PICFILE VAR p):
+ to pic (p, p.pos+1)
+END PROC down;
+
+PROC down (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos+n)
+END PROC down;
+
+BOOL PROC eof (PICFILE CONST p):
+ p.pos >= p.size
+END PROC eof;
+
+INT PROC picture no (PICFILE CONST p):
+ p.pos
+END PROC picture no;
+
+INT PROC pictures (PICFILE CONST p):
+ p.size
+END PROC pictures;
+
+PROC delete picture (PICFILE VAR p) :
+ INT VAR i;
+ FOR i FROM p.pos+1 UPTO p.size
+ REP p.pic [i-1] := p.pic [i] PER;
+
+ p.pic [p.size] := nilpicture;
+ IF p.size > 1
+ THEN p.size DECR 1 FI
+END PROC delete picture;
+
+PROC insert picture (PICFILE VAR p) :
+ INT VAR i;
+ IF p.size >= max pics
+ THEN errorstop (pic over)
+ ELSE p.size INCR 1;
+ FOR i FROM p.size DOWNTO p.pos+1
+ REP p.pic [i] := p.pic [i-1] PER;
+
+ p.pic [p.pos] := nilpicture;
+ FI
+END PROC insert picture;
+
+PROC read picture (PICFILE VAR p, PICTURE VAR pic) :
+ pic := p.pic (p.pos) .
+END PROC read picture;
+
+PROC write picture (PICFILE VAR p, PICTURE CONST pic) :
+ p.pic (p.pos) := pic .
+END PROC write picture;
+
+PROC get picture (PICFILE VAR p, PICTURE VAR pic) :
+ IF p.pos > p.size
+ THEN errorstop (pos over)
+ ELSE pic := p.pic [p.pos];
+ p.pos INCR 1;
+ FI
+END PROC get picture;
+
+PROC put picture (PICFILE VAR p, PICTURE CONST pic) :
+ IF p.pos > max pics
+ THEN errorstop (pic over)
+ ELSE p.pic [p.pos] := pic;
+
+ IF p.pos > p.size
+ THEN p.size INCR 1 FI;
+ p.pos INCR 1
+ FI
+END PROC put picture;
+
+END PACKET picfile
+
diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Plot b/system/std.graphik/1.8.7/src/GRAPHIK.Plot
new file mode 100644
index 0000000..5087abb
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/GRAPHIK.Plot
@@ -0,0 +1,285 @@
+PACKET basis plot DEFINES (* Autor: Heiko Indenbirken*)
+ (* Stand: 12.04.85 *)
+ (*Änderung: 06.08.86/10:03 *)
+(* ****************** Hardwareunabhängiger Teil ********************* *)
+(* *)
+(* *)
+(* Im Harwareunabhängigen Paket 'basis plot' werden folgende *)
+(* Prozeduren definiert: *)
+(* Procedure : Bedeutung *)
+(* ---------------------------------------------------------------- *)
+(* move : Positioniert auf (x, y,[z]) in Weltkoordinaten*)
+(* draw : Zeichnet eine Linie bis zum Punkt (x, y, [z]).*)
+(* move r : Positioniert (x, y, [z]) weiter *)
+(* draw r : Zeichnet (x, y, [z]) weiter *)
+(* *)
+(* draw : Zeichnet einen Text *)
+(* *)
+(* mark : Marker mit (no, size) *)
+(* bar : Balken mit (width, height, pattern) *)
+(* bar : Balken mit (from, to, width, pattern) *)
+(* circle : Kreis(segment) mit (radius, from, to, pattern)*)
+(* *)
+(* where : Gibt die aktuelle Stiftposition (x, y, [z]) *)
+(* *)
+(*************************************************************************)
+
+ move, draw,
+ move r, draw r,
+ mark, bar, circle,
+ where:
+
+LET POS = STRUCT (REAL x, y, z);
+
+POS VAR pos :: POS : (0.0, 0.0, 0.0);
+INT VAR h :: 0, v :: 0;
+
+PROC move (REAL CONST x, y) :
+ transform (x, y, 0.0, h, v);
+ move (h, v);
+ pos := POS : (x, y, 0.0)
+END PROC move;
+
+PROC move (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ move (h, v);
+ pos := POS : (x, y, z)
+END PROC move;
+
+PROC draw (REAL CONST x, y) :
+ transform (x, y, 0.0, h, v);
+ draw (h, v);
+ pos := POS : (x, y, 0.0)
+END PROC draw;
+
+PROC draw (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ draw (h, v);
+ pos := POS : (x, y, z)
+END PROC draw;
+
+PROC move r (REAL CONST x, y) :
+ transform (pos.x+x, pos.y+y, pos.z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC move r;
+
+PROC move r (REAL CONST x, y, z) :
+ transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC move r;
+
+PROC draw r (REAL CONST x, y) :
+ transform (pos.x+x, pos.y+y, pos.z, h, v);
+ draw (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC draw r;
+
+PROC draw r (REAL CONST x, y, z) :
+ transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ draw (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC draw r;
+
+PROC where (REAL VAR x, y) :
+ x := pos.x; y := pos.y
+END PROC where;
+
+PROC where (REAL VAR x, y, z) :
+ x := pos.x; y := pos.y; z := pos.z
+END PROC where;
+
+PROC draw (TEXT CONST msg, REAL CONST angle, height percent, width percent):
+ draw (msg, angle, height (height percent), width (width percent)) .
+END PROC draw;
+
+PROC mark (REAL CONST size, INT CONST no):
+ marker (h, v, no, diagonal (size))
+END PROC mark;
+
+PROC bar (REAL CONST width, height, INT CONST pattern):
+ INT VAR diff, up, zero x, zero y;
+ transform (0.0, 0.0, 0.0, zero x, zero y);
+ transform (width*0.5, height, 0.0, diff, up);
+ bar (h-(diff-zero x), v, h+(diff-zero x), v+(up-zero y), pattern);
+ move (h, v)
+
+END PROC bar;
+
+PROC bar (REAL CONST from, to, height, INT CONST pattern):
+ INT VAR from h, to h, up;
+ transform (from, height, 0.0, from h, up);
+ transform (to, height, 0.0, to h, up);
+ bar (from h, v, to h, up, pattern);
+ move (h, v)
+
+END PROC bar;
+
+PROC circle (REAL CONST rad, from, to, INT CONST pattern):
+ circle (h, v, diagonal (rad), from, to, pattern) .
+
+END PROC circle;
+
+ENDPACKET basis plot;
+
+PACKET plot DEFINES plot: (*Autor: Heiko Indenbirken *)
+ (*Stand: 13.10.89/22:31 *)
+
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ bar 2 key = 6,
+ bar 3 key = 7,
+ circle key = 8,
+ mark key = 9;
+
+LET dim error = "PICTURE not initialized",
+ key error = "wrong key code: ";
+
+TEXT VAR points;
+INT VAR pic length, pic pen, pic dim, read pos;
+PICTURE VAR pic;
+
+PROC plot (PICTURE CONST pic):
+ init plot;
+ IF pic dim = 2
+ THEN plot two dim pic
+ ELIF pic dim = 3
+ THEN plot three dim pic
+ ELIF NOT (pic dim = 0 AND pic length = 0)
+ THEN errorstop (dim error) FI;
+ points := "" .
+
+init plot:
+ picture (pic, points, pic dim, pic pen);
+ pic length := length (points);
+ read pos := 0 .
+
+plot two dim pic:
+ WHILE read pos < pic length
+ REP plot two dim position PER .
+
+plot two dim position :
+ read pos INCR 1;
+ SELECT key OF
+ CASE draw key: draw (next real, next real)
+ CASE move key: move (next real, next real)
+ CASE move r key: move r (next real, next real)
+ CASE draw r key: draw r (next real, next real)
+ CASE text key: draw (next text, next real, next real, next real)
+ CASE bar 2 key: bar (next real, next real, next int)
+ CASE bar 3 key: bar (next real, next real, next real, next int)
+ CASE circle key: circle (next real, next real, next real, next int)
+ CASE mark key: mark (next real, next int)
+ OTHERWISE errorstop (key error + text (key)) END SELECT .
+
+plot three dim pic:
+ WHILE read pos < pic length
+ REP plot three dim position PER .
+
+plot three dim position :
+ read pos INCR 1;
+ SELECT key OF
+ CASE draw key: draw (next real, next real, next real)
+ CASE move key: move (next real, next real, next real)
+ CASE move r key: move r (next real, next real, next real)
+ CASE draw r key: draw r (next real, next real, next real)
+ CASE text key: draw (next text, next real, next real, next real)
+ CASE bar 2 key: bar (next real, next real, next int)
+ CASE bar 3 key: bar (next real, next real, next real, next int)
+ CASE circle key: circle (next real, next real, next real, next int)
+ CASE mark key: mark (next real, next int)
+ OTHERWISE errorstop (key error + text (key)) END SELECT .
+
+key:
+ code (points SUB read pos) .
+
+END PROC plot;
+
+REAL PROC next real:
+ read pos INCR 8;
+ subtext (points, read pos-7, read pos) RSUB 1 .
+END PROC next real;
+
+INT PROC next int:
+ read pos INCR 2;
+ subtext (points, read pos-1, read pos) ISUB 1 .
+END PROC next int;
+
+TEXT PROC next text:
+ INT CONST text length :: next int;
+ read pos INCR text length;
+ subtext (points, read pos-text length+1, read pos) .
+END PROC next text;
+
+PROC plot (TEXT CONST name) :
+ PICFILE VAR p :: old (name);
+ plot (p);
+END PROC plot;
+
+PROC plot (PICFILE VAR p) :
+ set projektion;
+ disable stop;
+ begin plot;
+ clear screen;
+ plot pictures (p);
+ errorcheck;
+ end plot .
+
+set projektion:
+ ROW 3 ROW 2 REAL VAR size;
+ ROW 2 ROW 2 REAL VAR limit;
+ ROW 4 REAL VAR angles;
+ ROW 2 REAL VAR oblique;
+ ROW 3 REAL VAR perspective;
+
+ get values (p, size, limit, angles, oblique, perspective);
+ set values (size, limit, angles, oblique, perspective) .
+
+clear screen:
+ INT VAR x0, y0, x1, y1, h max, v max;
+ REAL VAR x cm, y cm;
+
+ IF background (p) > -1
+ THEN clear
+ ELSE drawing area (x cm, y cm, h max, v max);
+ new values (x cm, y cm, h max, v max, x0, x1 , y0, y1);
+ set range (max (0, x0), max (0, y0), min (h max, x1), min (v max, y1))
+ FI .
+
+errorcheck:
+ IF is error
+ THEN line;
+ put line ("Erorr at PICTURE No " + text (picture no (p)));
+ FI .
+
+END PROC plot;
+
+PROC plot pictures (PICFILE VAR p):
+ INT VAR back :: abs (background (p)), no;
+ enable stop;
+ FOR no FROM 1 UPTO pictures (p)
+ REP to pic (p, no);
+ read picture (p, pic);
+
+ IF this picture is ok
+ THEN set pen of pic;
+ plot (pic)
+ FI
+ PER .
+
+this picture is ok:
+ pen (pic) <> 0 AND length (pic) > 0 .
+
+set pen of pic:
+ INT VAR colour, thick, type;
+ selected pen (p, pen (pic), colour, thick, type);
+ set pen (back, colour, thick, type) .
+
+END PROC plot pictures;
+
+END PACKET plot
+
diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Plotter b/system/std.graphik/1.8.7/src/GRAPHIK.Plotter
new file mode 100644
index 0000000..a55e515
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/GRAPHIK.Plotter
@@ -0,0 +1,247 @@
+PACKET plotter DEFINES plotter: (*Autor: Heiko Indenbirken *)
+ (*Stand: 13.10.89/22:31 *)
+ (*Änderung: 08.09.86/15:47 *)
+
+LET POS = STRUCT (REAL x, y, z);
+
+POS VAR pos :: POS : (0.0, 0.0, 0.0);
+INT VAR h :: 0, v :: 0;
+
+PROC move (REAL CONST x, y) :
+ transform (x, y, 0.0, h, v);
+ move (h, v);
+ pos := POS : (x, y, 0.0)
+END PROC move;
+
+PROC move (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ move (h, v);
+ pos := POS : (x, y, z)
+END PROC move;
+
+PROC draw (REAL CONST x, y) :
+ transform (x, y, 0.0, h, v);
+ draw (h, v);
+ pos := POS : (x, y, 0.0)
+END PROC draw;
+
+PROC draw (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ draw (h, v);
+ pos := POS : (x, y, z)
+END PROC draw;
+
+PROC move r (REAL CONST x, y) :
+ transform (pos.x+x, pos.y+y, pos.z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC move r;
+
+PROC move r (REAL CONST x, y, z) :
+ transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC move r;
+
+PROC draw r (REAL CONST x, y) :
+ transform (pos.x+x, pos.y+y, pos.z, h, v);
+ draw (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC draw r;
+
+PROC draw r (REAL CONST x, y, z) :
+ transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ draw (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC draw r;
+
+PROC draw (TEXT CONST msg, REAL CONST angle, height percent, width percent):
+ draw (msg, angle, height (height percent), width (width percent)) .
+END PROC draw;
+
+PROC mark (REAL CONST size, INT CONST no):
+ marker (h, v, no, diagonal (size))
+END PROC mark;
+
+PROC bar (REAL CONST width, height, INT CONST pattern):
+ INT VAR diff, up, zero x, zero y;
+ transform (0.0, 0.0, 0.0, zero x, zero y);
+ transform (width*0.5, height, 0.0, diff, up);
+ bar (h-(diff-zero x), v, h+(diff-zero x), v+(up-zero y), pattern);
+ move (h, v)
+
+END PROC bar;
+
+PROC bar (REAL CONST from, to, height, INT CONST pattern):
+ INT VAR from h, to h, up;
+ transform (from, height, 0.0, from h, up);
+ transform (to, height, 0.0, to h, up);
+ bar (from h, v, to h, up, pattern);
+ move (h, v)
+
+END PROC bar;
+
+PROC circle (REAL CONST rad, from, to, INT CONST pattern):
+ circle (h, v, diagonal (rad), from, to, pattern) .
+
+END PROC circle;
+
+
+(* *)
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ bar 2 key = 6,
+ bar 3 key = 7,
+ circle key = 8,
+ mark key = 9;
+
+LET dim error = "PICTURE not initialized",
+ key error = "wrong key code: ";
+
+TEXT VAR points;
+INT VAR pic length, pic pen, pic dim, read pos;
+PICTURE VAR pic;
+
+PROC plot (PICTURE CONST pic):
+ init plot;
+ IF pic dim = 2
+ THEN plot two dim pic
+ ELIF pic dim = 3
+ THEN plot three dim pic
+ ELIF NOT (pic dim = 0 AND pic length = 0)
+ THEN errorstop (dim error) FI;
+ points := "" .
+
+init plot:
+ picture (pic, points, pic dim, pic pen);
+ pic length := length (points);
+ read pos := 0 .
+
+plot two dim pic:
+ WHILE read pos < pic length
+ REP plot two dim position PER .
+
+plot two dim position :
+ read pos INCR 1;
+ SELECT key OF
+ CASE draw key: draw (next real, next real)
+ CASE move key: move (next real, next real)
+ CASE move r key: move r (next real, next real)
+ CASE draw r key: draw r (next real, next real)
+ CASE text key: draw (next text, next real, next real, next real)
+ CASE bar 2 key: bar (next real, next real, next int)
+ CASE bar 3 key: bar (next real, next real, next real, next int)
+ CASE circle key: circle (next real, next real, next real, next int)
+ CASE mark key: mark (next real, next int)
+ OTHERWISE errorstop (key error + text (key)) END SELECT .
+
+plot three dim pic:
+ WHILE read pos < pic length
+ REP plot three dim position PER .
+
+plot three dim position :
+ read pos INCR 1;
+ SELECT key OF
+ CASE draw key: draw (next real, next real, next real)
+ CASE move key: move (next real, next real, next real)
+ CASE move r key: move r (next real, next real, next real)
+ CASE draw r key: draw r (next real, next real, next real)
+ CASE text key: draw (next text, next real, next real, next real)
+ CASE bar 2 key: bar (next real, next real, next int)
+ CASE bar 3 key: bar (next real, next real, next real, next int)
+ CASE circle key: circle (next real, next real, next real, next int)
+ CASE mark key: mark (next real, next int)
+ OTHERWISE errorstop (key error + text (key)) END SELECT .
+
+key:
+ code (points SUB read pos) .
+
+END PROC plot;
+
+REAL PROC next real:
+ read pos INCR 8;
+ subtext (points, read pos-7, read pos) RSUB 1 .
+END PROC next real;
+
+INT PROC next int:
+ read pos INCR 2;
+ subtext (points, read pos-1, read pos) ISUB 1 .
+END PROC next int;
+
+TEXT PROC next text:
+ INT CONST text length :: next int;
+ read pos INCR text length;
+ subtext (points, read pos-text length+1, read pos) .
+END PROC next text;
+
+PROC plotter (TEXT CONST name) :
+ PICFILE VAR p :: old (name);
+ plotter (p);
+END PROC plotter;
+
+PROC plotter (PICFILE VAR p) :
+ set projektion;
+ disable stop;
+ begin plot;
+ clear screen;
+ plot pictures (p);
+ errorcheck;
+ end plot .
+
+set projektion:
+ ROW 3 ROW 2 REAL VAR size;
+ ROW 2 ROW 2 REAL VAR limit;
+ ROW 4 REAL VAR angles;
+ ROW 2 REAL VAR oblique;
+ ROW 3 REAL VAR perspective;
+ get values (p, size, limit, angles, oblique, perspective);
+ set values (size, limit, angles, oblique, perspective) .
+
+clear screen:
+ INT VAR x0, y0, x1, y1, h max, v max;
+ REAL VAR x cm, y cm;
+
+ IF background (p) > -1
+ THEN clear
+ ELSE drawing area (x cm, y cm, h max, v max);
+ new values (x cm, y cm, h max, v max, x0, x1 , y0, y1);
+ set range (max (0, x0), max (0, y0), min (h max, x1), min (v max, y1))
+ FI .
+
+errorcheck:
+ IF is error
+ THEN line;
+ put line ("Erorr at PICTURE No " + text (picture no (p)));
+ FI .
+
+END PROC plotter;
+
+PROC plot pictures (PICFILE VAR p):
+ INT VAR back :: abs (background (p)), no;
+ enable stop;
+ FOR no FROM 1 UPTO pictures (p)
+ REP to pic (p, no);
+ read picture (p, pic);
+
+ IF this picture is ok
+ THEN set pen of pic;
+ plot (pic)
+ FI
+ PER .
+
+this picture is ok:
+ pen (pic) <> 0 AND length (pic) > 0 .
+
+set pen of pic:
+ INT VAR colour, thick, type;
+ selected pen (p, pen (pic), colour, thick, type);
+ set pen (back, colour, thick, type) .
+
+END PROC plot pictures;
+
+END PACKET plotter
+
+
diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Server b/system/std.graphik/1.8.7/src/GRAPHIK.Server
new file mode 100644
index 0000000..dfe5f62
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/GRAPHIK.Server
@@ -0,0 +1,97 @@
+PACKET multi user plotter: (* Autor : Rudolf Ruland *)
+ (* Stand : 24.03.86 *)
+ (*Änderung: 09.09.86/15:32 *)
+
+INT VAR c;
+put ("gib Plotterkanal : "); get (c);
+
+ server channel (c);
+ station only (FALSE) ;
+ spool duty ("Ausgabe mit dem Plotter");
+ spool control task (myself);
+
+LET ack = 0 ,
+
+ fetch code = 11 ,
+ param fetch code = 21 ,
+ picfile type = 1103 ;
+
+INT VAR reply, old heap size, sender station;
+TEXT VAR picfile name, userid, password, sendername;
+PICFILE VAR picfile ;
+
+DATASPACE VAR ds, picfile ds;
+
+BOUND STRUCT (TEXT picfile name, userid, password, sendername, INT station) VAR msg;
+BOUND TEXT VAR error msg ;
+
+spool manager (PROC plotter);
+
+PROC plotter :
+
+ disable stop ;
+ command dialogue (FALSE);
+ ds := nilspace; picfile ds := nilspace;
+ continue (server channel) ;
+ check error ("Kanal belegt");
+
+ old heap size := heap size ;
+ REP
+ execute plot ;
+
+ IF is error
+ THEN put error;
+ clear error;
+ FI ;
+
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI
+ PER
+
+ENDPROC plotter ;
+
+
+PROC execute plot :
+
+ enable stop ;
+ forget (picfile ds) ; picfile ds := nilspace ;
+ call (father, fetch code, picfile ds, reply) ;
+ IF reply = ack CAND type (picfile ds) = picfile type
+ THEN get picfile params;
+ plot picfile
+ FI ;
+
+. get picfile params :
+ forget (ds); ds := nilspace;
+ call (father, param fetch code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE msg := ds;
+ picfile name := msg. picfile name;
+ userid := msg. userid;
+ password := msg. password;
+ sendername := msg. sender name;
+ sender station := msg. station;
+ FI;
+
+. plot picfile :
+ picfile := picfile ds;
+ plotter (picfile) .
+
+ENDPROC execute plot ;
+
+
+PROC check error (TEXT CONST message) :
+ IF is error
+ THEN clear error;
+ rename myself (message);
+ IF is error THEN clear error; end (myself) FI;
+ pause (18000);
+ end (myself);
+ FI;
+END PROC check error;
+
+ENDPACKET multi user plotter ;
+
diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.Transform b/system/std.graphik/1.8.7/src/GRAPHIK.Transform
new file mode 100644
index 0000000..54690cc
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/GRAPHIK.Transform
@@ -0,0 +1,366 @@
+PACKET transformation DEFINES transform, (* Autor: Heiko Indenbirken*)
+ diagonal, (* Stand: 12.04.85 *)
+ height, width, (*Änderung: 05.08.86/13:14 *)
+ set values, (*Änderung: 17.09.86/19:57 *)
+ get values,
+ new values,
+ projektion,
+ window,
+ viewport,
+ view,
+ oblique,
+ orthographic,
+ perspective:
+(* ******************* Hardwareunabhängiger Teil ********************* *)
+(* transform: Die Prozedur projeziert einen 3-dimensionalen Vektor *)
+(* ---------- (x, y, z) auf einen 2-dimensionalen (h, v) *)
+(* diagonal Die Prozedur berechnet die Pixel als Prozent der *)
+(* ---------- Diagonalen der Zeichenfläche *)
+(* height Die Prozedur berechnet die Pixel als Prozent der *)
+(* ---------- Höhe der Zeichenfläche *)
+(* width Die Prozedur berechnet die Pixel als Prozent der *)
+(* ---------- Breite der Zeichenfläche *)
+(* *)
+(* set values: Mit dieser Prozedur werden die Projektionsparameter *)
+(* ----------- gesetzt. *)
+(* size: Weltkoordinatenbereich *)
+(* ((xmin,xmax),(ymin,ymax),(zmin,zmax)) *)
+(* limits: Zeichenfläche *)
+(* ((h min, h max), (v min, v max)) *)
+(* Bei Werten < 2.0 werden die Werte als *)
+(* Prozente interpretiert, ansonsten als *)
+(* cm-Grössen. *)
+(* get values: Übergibt die aktuellen Werte *)
+(* ----------- *)
+(* new values: Berechnet die neue Projektionsmatrix *)
+(* ----------- *)
+(*=======================================================================*)
+
+BOOL VAR perspective projektion :: FALSE;
+INT VAR hor pixel, vert pixel, i;
+REAL VAR hor cm, vert cm,
+ h min limit, h max limit, v min limit, v max limit;
+ROW 5 ROW 5 REAL VAR p;
+ROW 3 ROW 2 REAL VAR size;
+ROW 2 ROW 2 REAL VAR limits;
+ROW 4 REAL VAR angles;
+ROW 2 REAL VAR obliques;
+ROW 3 REAL VAR perspectives;
+
+(* Initialisieren der Projektionsmatrizen *)
+INT VAR d;
+window (0.0, 1.0, 0.0, 1.0, 0.0, 1.0);
+viewport (0.0, 0.0, 0.0, 0.0);
+view (0.0, 0.0, 1.0);
+view (0.0);
+orthographic;
+new values (27.46, 19.21, 274, 192, d, d, d, d);
+
+PROC projektion (ROW 5 ROW 5 REAL VAR matrix):
+ matrix := p
+END PROC projektion;
+
+PROC oblique (REAL CONST a, b) :
+ set values (size, limits, angles, ROW 2 REAL : (a, b), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC oblique;
+
+PROC orthographic :
+ set values (size, limits, angles, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC orthographic;
+
+PROC perspective (REAL CONST cx, cy, cz) :
+ set values (size, limits, angles, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (cx, cy, cz))
+END PROC perspective;
+
+PROC window (REAL CONST x min, x max, y min, y max) :
+ window (x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (REAL CONST x min, x max, y min, y max, z min, z max) :
+ set values (ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max),
+ ROW 2 REAL : (y min, y max),
+ ROW 2 REAL : (z min, z max)),
+ limits, angles, obliques, perspectives)
+END PROC window;
+
+PROC viewport (REAL CONST h min, h max, v min, v max) :
+ set values (size, ROW 2 ROW 2 REAL : (ROW 2 REAL : (h min, h max),
+ ROW 2 REAL : (v min, v max)),
+ angles, obliques, perspectives)
+END PROC view port;
+
+PROC view (REAL CONST alpha) :
+ set values (size, limits, ROW 4 REAL : (alpha, angles(2), angles (3), angles (4)),
+ obliques, perspectives)
+END PROC view;
+
+PROC view (REAL CONST phi, theta):
+ set values (size, limits, ROW 4 REAL : (angles (1), sind (theta) * cosd (phi),
+ sind (theta) * sind (phi), cosd (theta)),
+ obliques, perspectives)
+END PROC view;
+
+PROC view (REAL CONST x, y, z) :
+ set values (size, limits, ROW 4 REAL : (angles (1), x, y, z), obliques, perspectives)
+END PROC view;
+
+PROC get values (ROW 3 ROW 2 REAL VAR act size,
+ ROW 2 ROW 2 REAL VAR act limits,
+ ROW 4 REAL VAR act angles,
+ ROW 2 REAL VAR act obliques,
+ ROW 3 REAL VAR act perspectives) :
+ act size := size;
+ act limits := limits;
+ act angles := angles;
+ act obliques := obliques;
+ act perspectives := perspectives;
+
+END PROC get values;
+
+PROC set values (ROW 3 ROW 2 REAL CONST new size,
+ ROW 2 ROW 2 REAL CONST new limits,
+ ROW 4 REAL CONST new angles,
+ ROW 2 REAL CONST new obliques,
+ ROW 3 REAL CONST new perspectives) :
+ size := new size;
+ limits := new limits;
+ angles := new angles;
+ obliques := new obliques;
+ perspectives := new perspectives
+
+END PROC set values;
+
+PROC new values (INT VAR h min range, h max range, v min range, v max range):
+ new values (hor cm, vert cm, hor pixel, vert pixel,
+ h min range, h max range, v min range, v max range)
+END PROC new values;
+
+PROC new values (REAL CONST size hor, size vert,
+ INT CONST pixel hor, pixel vert,
+ INT VAR h min range, h max range,
+ v min range, v max range):
+ remember screensize;
+ calc views;
+ calc projektion;
+ calc limits;
+ calc projection frame;
+ normalize projektion;
+ set picture range;
+ set perspective mark .
+
+remember screensize:
+ hor cm := size hor;
+ vert cm := size vert;
+ hor pixel := pixel hor;
+ vert pixel := pixel vert .
+
+calc views :
+ calc diagonale;
+ calc projektion;
+ calc angles;
+ calc normale;
+ calc matrix;
+ calc alpha angle .
+
+calc diagonale:
+ REAL VAR diagonale := sqrt (angles [2] * angles [2] +
+ angles [3] * angles [3] +
+ angles [4] * angles [4]) .
+
+calc projektion:
+ REAL VAR projektion := sqrt (angles [2] * angles [2] +
+ angles [4] * angles [4]) .
+
+calc angles:
+ REAL VAR sin p, cos p, sin t, cos t, sin a, cos a;
+
+ IF diagonale = 0.0
+ THEN sin p := 0.0; cos p := 1.0;
+ sin t := 0.0; cos t := 1.0
+ ELIF projektion = 0.0
+ THEN sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := 0.0; cos t := 1.0
+ ELSE sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := angles [2] / projektion;
+ cos t := angles [4] / projektion
+ FI .
+
+calc normale:
+ REAL VAR sin p sin t := sin p * sin t,
+ sin p cos t := sin p * cos t,
+ cos p sin t := cos p * sin t,
+ cos p cos t := cos p * cos t,
+
+ dx := size [1][2] - size [1][1],
+ dy := size [2][2] - size [2][1],
+ dz := size [3][2] - size [3][1],
+ norm az := obliques [1] ,
+ norm bz := obliques [2] ,
+ norm cx := perspectives [1] / dx,
+ norm cy := perspectives [2] / dy,
+ norm cz := perspectives [3] / dz .
+
+calc matrix:
+p := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( cos t / dx - cos p sin t / dx * norm az ,
+ - sin p sin t / dx - cos p sin t / dx * norm bz,
+ 0.0,
+ - cos p sin t / dx * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( - sin p / dy * norm az,
+ cos p / dy - sin p / dy * norm bz,
+ 0.0,
+ - sin p / dy * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( sin t / dz + cos p cos t / dz * norm az,
+ + sin p cos t / dz + cos p cos t / dz * norm bz,
+ 0.0,
+ cos p cos t / dz * norm cz,
+ 0.0 ),
+ ROW 5 REAL : (- norm cx, - norm cy, 0.0, 1.0, 0.0 ),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0)) .
+
+calc alpha angle:
+ IF angles (1) = 0.0
+ THEN set alpha as y vertical
+ ELSE sin a := sind (angles (1));
+ cos a := cosd (angles (1))
+ FI .
+
+set alpha as y vertical :
+ REAL VAR r := sqrt (p(2)(1)**2 + p(2)(2)**2);
+ IF r = 0.0
+ THEN sin a := 0.0;
+ cos a := 1.0
+ ELSE sin a :=-p(2)(1)/r;
+ cos a := p(2)(2)/r
+ FI .
+
+calc limits :
+ IF limits as percent
+ THEN calc percent limits
+ ELSE calc centimeter limits FI .
+
+limits as percent:
+ limits [1][2] < 2.0 AND limits [2][2] < 2.0 .
+
+max limits:
+ h min limit := 0.0;
+
+ v min limit := 0.0;
+ v max limit := real (pixel vert) .
+
+calc percent limits:
+ h min limit := real (pixel hor) * limits (1)(1)*size vert / size hor;
+ v min limit := limits (2)(1) * real (pixel vert);
+
+ IF limits [1][2] = 0.0
+ THEN h max limit := real (pixel hor)
+ ELSE h max limit := real (pixel hor) * limits [1][2]*size vert / size hor FI;
+
+ IF limits [2][2] = 0.0
+ THEN v max limit := real (pixel vert)
+ ELSE v max limit := limits (2)(2) * real (pixel vert) FI .
+
+calc centimeter limits:
+ h min limit := real (pixel hor) * (limits (1)(1)/size hor);
+ v min limit := real (pixel vert) * (limits (2)(1)/size vert);
+
+ IF limits [1][2] = 0.0
+ THEN h max limit := real (pixel hor)
+ ELSE h max limit := real (pixel hor) * (limits (1)(2)/size hor) FI;
+
+ IF limits [2][2] = 0.0
+ THEN v max limit := real (pixel vert)
+ ELSE v max limit := real (pixel vert) * (limits (2)(2)/size vert) FI .
+
+calc projection frame:
+ REAL VAR h min := max real, h max :=-max real,
+ v min := max real, v max :=-max real;
+
+ extrema (size [1][1], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][2], h min, h max, v min, v max) .
+
+normalize projektion :
+ REAL VAR sh := (h max limit - h min limit) / (h max - h min),
+ sv := (v max limit - v min limit) / (v max - v min),
+ dh := h min limit - h min*sh,
+ dv := v min limit - v min*sv;
+
+ FOR i FROM 1 UPTO 5
+ REP REAL CONST p i 1 := p (i)(1);
+ p (i)(1) := (p i 1 * cos a - p (i)(2) * sin a) * sh;
+ p (i)(2) := (p i 1 * sin a + p (i)(2) * cos a) * sv
+ PER;
+ p (5)(1) := dh;
+ p (5)(2) := dv .
+
+set picture range:
+ h min range := int (h min limit-0.5);
+ h max range := int (h max limit+0.5);
+ v min range := int (v min limit-0.5);
+ v max range := int (v max limit+0.5) .
+
+set perspective mark:
+ perspective projektion := perspectives [3] <> 0.0 .
+
+END PROC new values;
+
+PROC transform (REAL CONST x, y, z, INT VAR h, v) :
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := int ((x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (4)(1))*w + p (5)(1));
+ v := int ((x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (4)(2))*w + p (5)(2))
+ ELSE h := int (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (5)(1));
+ v := int (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (5)(2));
+ FI;
+END PROC transform;
+
+PROC extrema (REAL CONST x, y, z, REAL VAR h min, h max, v min, v max):
+ REAL VAR h, v;
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) +p (4)(1))*w;
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) +p (4)(2))*w
+ ELSE h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1));
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2))
+ FI;
+
+ IF h < h min
+ THEN h min := h
+ ELIF h > h max
+ THEN h max := h FI;
+
+ IF v < v min
+ THEN v min := v
+ ELIF v > v max
+ THEN v max := v FI
+
+END PROC extrema;
+
+INT PROC diagonal (REAL CONST percent):
+ int (percent * 0.01 * diagonale + 0.5) .
+
+diagonale:
+ sqrt ((h max limit-h min limit) ** 2 + (v max limit-v min limit) ** 2) .
+
+END PROC diagonal;
+
+INT PROC height (REAL CONST percent):
+ int (percent * 0.01 * (v max limit-v min limit) + 0.5)
+END PROC height;
+
+INT PROC width (REAL CONST percent):
+ int (percent * 0.01 * (h max limit-h min limit) + 0.5)
+END PROC width;
+
+END PACKET transformation
+
diff --git a/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot b/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot
new file mode 100644
index 0000000..8bef1e4
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/GRAPHIK.vektor plot
@@ -0,0 +1,506 @@
+PACKET clipping DEFINES set range, (*Autor: Heiko Indenbirken *)
+ get range, (*Stand: 27.06.85/12:39 *)
+ clip: (*Änderung: 11.08.86/15:02 *)
+
+INT VAR x min :: 0, x max :: 1024, y min :: 0, y max :: 1024;
+
+PROC set range (INT CONST h min, v min, h max, v max):
+ IF h min >= h max OR v min >= v max
+ THEN errorstop ("Incorrect Range") FI;
+ x min := h min; x max := h max;
+ y min := v min; y max := v max
+END PROC set range;
+
+PROC get range (INT VAR h min, v min, h max, v max):
+ h min := x min; h max := x max;
+ v min := y min; v max := y max
+END PROC get range;
+
+PROC clip (INT CONST from x, from y, to x, to y,
+ PROC (INT CONST, INT CONST) move,
+ PROC (INT CONST, INT CONST) draw):
+ INT VAR x, y;
+ calculate parts of line;
+ IF both points inside
+ THEN draw (to x, to y)
+ ELIF both points outside
+ THEN
+ ELIF first point outside
+ THEN intersection (to x, to y, from x, from y, from part, x, y);
+ move (x, y);
+ draw (x, y); (* Macke im SHARD *)
+ draw (to x, to y)
+ ELIF second point outside
+ THEN intersection (from x, from y, to x, to y, to part, x, y);
+ draw (x, y)
+ ELSE intersection (to x, to y, from x, from y, from part, x, y);
+ move (x, y);
+ draw (x, y); (* Macke im SHARD *)
+ clip (x, y, to x, to y, PROC (INT CONST, INT CONST) move,
+ PROC (INT CONST, INT CONST) draw)
+ FI .
+
+calculate parts of line:
+ INT CONST from part :: part (from x, from y),
+ to part :: part (to x, to y) .
+
+both points inside:
+ from part = 0 AND to part = 0 .
+
+both points outside:
+ (from part AND to part) <> 0 .
+
+first point outside:
+ from part <> 0 AND to part = 0 .
+
+second point outside:
+ to part <> 0 AND from part = 0 .
+
+END PROC clip;
+
+INT PROC part (INT CONST x, y):
+ INT VAR index :: 0;
+ IF x > x max
+ THEN set bit (index, 0)
+ ELIF x < x min
+ THEN set bit (index, 1) FI;
+
+ IF y > y max
+ THEN set bit (index, 2)
+ ELIF y < y min
+ THEN set bit (index, 3) FI;
+
+ index
+
+END PROC part;
+
+PROC intersection (INT CONST from x, from y, to x, to y, to part, INT VAR x, y):
+ SELECT to part OF
+ CASE 1: right side
+ CASE 2: left side
+ CASE 4: up side
+ CASE 5: upright side
+ CASE 6: upleft side
+ CASE 8: down side
+ CASE 9: downright side
+ CASE 10: downleft side
+ OTHERWISE errorstop ("wrong partno.:" + text (to part)) ENDSELECT .
+
+right side:
+ y := from y + int (real (x max-from x)*(dy/dx));
+ x := x max .
+
+left side:
+ y := from y + int (real (x min-from x)*(dy/dx));
+ x := x min .
+
+up side:
+ x := from x + int (real (y max-from y)*(dx/dy));
+ y := y max .
+
+down side:
+ x := from x + int (real (y min-from y)*(dx/dy));
+ y := y min .
+
+upright side:
+ right side;
+ IF y > y max
+ THEN up side FI .
+
+downright side:
+ right side;
+ IF y < y min
+ THEN down side FI .
+
+upleft side:
+ left side;
+ IF y > y max
+ THEN up side FI .
+
+downleft side:
+ left side;
+ IF y < y min
+ THEN down side FI .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC intersection;
+
+END PACKET clipping;
+
+PACKET thick line DEFINES thick: (*Autor: Heiko Indenbirken *)
+ (*Stand: 02.07.85/15:07 *)
+ (*Änderung: 05.08.86/15:52 *)
+PROC thick (INT CONST x0, y0, x1, y1, thick,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ IF is point
+ THEN draw point
+ ELIF is horizontal line
+ THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ x0, y0, x1, y1, thick)
+ ELSE vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ x0, y0, x1, y1, thick)
+ FI .
+
+is point:
+ x0 = x1 AND y0 = y1 .
+
+is horizontal line:
+ abs (x0-x1) >= abs (y0-y1) .
+
+draw point:
+ INT VAR i;
+ FOR i FROM -thick UPTO thick
+ REP line (x0-thick, y0+i, x0+thick, y0+i) PER .
+
+END PROC thick;
+
+PROC horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ INT CONST from x, from y, to x, to y, thick):
+ IF from x > to x
+ THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ to x, to y, from x, from y, thick)
+ ELSE draw line FI .
+
+draw line:
+ INT VAR i;
+ calculate increase;
+ calculate limit points;
+ FOR i FROM -thick UPTO thick
+ REP calculate delta x;
+ line (x start+delta x, y start+i, x end+delta x, y end+i)
+ PER .
+
+calculate increase:
+ REAL VAR increase :: -dy / dx .
+
+calculate limit points:
+ INT CONST x start :: from x - thick,
+ x end :: to x + thick,
+ y start :: from y + int (increase * real (thick)),
+ y end :: to y - int (increase * real (thick)) .
+
+calculate delta x:
+ INT CONST delta x :: int (increase*real (i)) .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC horizontal line;
+
+PROC vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ INT CONST from x, from y, to x, to y, thick):
+ IF from y > to y
+ THEN vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ to x, to y, from x, from y, thick)
+ ELSE draw line FI .
+
+draw line:
+ INT VAR i;
+ calculate increase;
+ calculate limit points;
+ FOR i FROM -thick UPTO thick
+ REP calculate delta y;
+ line (x start+i, y start+delta y, x end+i, y end+delta y)
+ PER .
+
+calculate increase:
+ REAL VAR increase :: -dx / dy .
+
+calculate limit points:
+ INT CONST x start :: from x + int (increase * real (thick)),
+ x end :: to x - int (increase * real (thick)),
+ y start :: from y - thick,
+ y end :: to y + thick .
+
+calculate delta y:
+ INT CONST delta y :: int (increase*real (i)) .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC vertical line;
+
+END PACKET thick line;
+
+PACKET graphik text DEFINES draw char, (*Autor: Heiko Indenbirken *)
+ zeichensatz: (*Stand: 27.06.85/16:03 *)
+ (*Änderung: 28.06.85/19:06 *)
+ (*Änderung: 05.08.86/16:00 *)
+LET ZEICHENSATZ = ROW 255 TEXT;
+ZEICHENSATZ VAR zeichen;
+INT CONST char x :: 6, char y :: 10;
+
+zeichensatz ("ZEICHENSATZ");
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
+ zeichen := new zeichen;
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC draw char (INT CONST char no, INT CONST x, y, x size, y size, direction,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ TEXT CONST character :: zeichen [char no];
+ INT VAR n :: 1, x0, y0, x1, y1;
+ INT CONST len :: length (character);
+ WHILE n < len
+ REP value (character, n, x0, y0, x1, y1);
+ transform (x0, y0, x, y, x size, y size, direction);
+ transform (x1, y1, x, y, x size, y size, direction);
+ line (x0, y0, x1, y1);
+ n INCR 4
+ PER .
+
+END PROC draw char;
+
+PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1):
+ x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1));
+ x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3));
+END PROC value;
+
+INT PROC val (INT CONST n):
+ IF n > 127
+ THEN -256 OR n
+ ELSE n FI
+END PROC val;
+
+PROC transform (INT VAR x, y, INT CONST x0, y0, x size, y size, direction):
+ INT CONST old x :: x, old y :: y;
+ SELECT direction OF
+ CASE 0: x := x0 + x vektor; y := y0 + y vektor
+ CASE 1: x := x0 - y vektor; y := y0 + x vektor
+ CASE 2: x := x0 - x vektor; y := y0 - y vektor
+ CASE 3: x := x0 + y vektor; y := y0 - x vektor
+ ENDSELECT .
+
+x vektor:
+ IF x size = 0
+ THEN old x
+ ELSE (old x*x size) DIV char x FI .
+
+y vektor:
+ IF y size = 0
+ THEN old y
+ ELSE (old y*y size) DIV char y FI .
+
+END PROC transform;
+
+END PACKET graphik text;
+
+PACKET graphik text DEFINES draw text: (*Autor: Heiko Indenbirken *)
+ (*Stand: 03.07.85/11:55 *)
+ (*Änderung: 05.08.86/16:04 *)
+PROC draw text (INT CONST x pos, y pos,
+ TEXT CONST msg, REAL CONST angle, INT CONST height, width,
+ PROC (INT CONST, INT CONST,
+ INT CONST, INT CONST, INT CONST, INT CONST) draw char):
+ INT CONST dir :: int (((angle MOD 360.0)+45.0) / 90.0);
+ INT VAR i;
+ REAL VAR x :: real (x pos), y :: real (y pos),
+ x step :: cosd (angle)*real (width),
+ y step :: sind (angle)*real (width);
+ FOR i FROM 1 UPTO length (msg)
+ REP IF control char
+ THEN execute control char
+ ELSE execute normal char FI
+ PER .
+
+control char:
+ akt char < ""32"" .
+
+execute control char:
+ SELECT code (akt char) OF
+ CASE 1: home
+ CASE 2: right
+ CASE 3: up
+ CASE 7: out (""7"")
+ CASE 8: left
+ CASE 10: down
+ CASE 13: return
+ ENDSELECT .
+
+home:
+ x := real (x pos);
+ y := real (y pos) .
+
+right:
+ x INCR x step; y INCR y step .
+
+up:
+ x INCR y step; y INCR x step .
+
+left:
+ x DECR x step; y DECR y step .
+
+down:
+ x DECR y step; y DECR x step .
+
+return:
+ x := real (x pos) .
+
+execute normal char:
+ draw char (code (akt char), dir, int (x+0.5), int (y+0.5), height, width);
+ x INCR x step;
+ y INCR y step .
+
+akt char:
+ msg SUB i .
+
+END PROC draw text;
+
+END PACKET graphik text;
+
+PACKET comercial plot DEFINES bar, (*Autor: Heiko Indenbirken *)
+ circle: (*Stand: 03.04.1985 *)
+ (*Änderung: 03.07.85/15:37 *)
+PROC bar (INT CONST from x, from y, to x, to y, pattern,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ IF from x > to x
+ THEN bar (to x, from y, from x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ ELIF from y > to y
+ THEN bar (from x, to y, to x, from y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ ELSE draw frame;
+ fill frame with pattern
+ FI .
+
+draw frame:
+ line (from x, from y, from x, to y);
+ line (from x, to y, to x, to y);
+ line (to x, to y, to x, from y);
+ line (to x, from y, from x, from y) .
+
+fill frame with pattern:
+ SELECT pattern OF
+ CASE 1: fill right (from x, to x, from y, to y, 2, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 2: fill hor (from x, to x, from y, to y, 1, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 3: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 4: fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 5: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line);
+ fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 6: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 7: fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 8: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line);
+ fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ ENDSELECT .
+
+END PROC bar;
+
+PROC fill hor (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT VAR y :: from y;
+ REP line (from x, y, to x, y);
+ y INCR step
+ UNTIL y > to y PER .
+
+END PROC fill hor;
+
+PROC fill vert (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT VAR x :: from x;
+ REP line (x, from y, x, to y);
+ x INCR step
+ UNTIL x > to x PER .
+
+END PROC fill vert;
+
+PROC fill right (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT CONST width :: to x - from x,
+ height :: to y - from y,
+ length :: width + height,
+ height step :: height + step,
+ width step :: width + step;
+
+ INT VAR t :: step, left :: from x, right :: from x,
+ lower :: from y, upper :: from y;
+(* Ausfüllen von links unten nach rechts oben *)
+ WHILE t < length
+ REP calc start point;
+ calc end point;
+ line (left, upper, right, lower);
+ t INCR step
+ PER .
+
+calc start point:
+ IF t < height
+ THEN upper INCR step
+ ELIF t < height step
+ THEN left := from x + t - height;
+ upper := to y
+ ELSE left INCR step FI .
+
+calc end point:
+ IF t < width
+ THEN right INCR step
+ ELIF t < width step
+ THEN lower := from y + t - width;
+ right := to x
+ ELSE lower INCR step FI .
+
+END PROC fill right;
+
+PROC fill left (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT CONST width :: to x - from x,
+ height :: to y - from y,
+ length :: width + height,
+ height step :: height + step,
+ width step :: width + step;
+
+ INT VAR t :: step, left :: to x, right :: to x,
+ lower :: from y, upper :: from y;
+(* Ausfüllen von rechts unten nach links oben *)
+ WHILE t < length
+ REP calc start point;
+ calc end point;
+ line (right, upper, left, lower);
+ t INCR step
+ PER .
+
+calc start point:
+ IF t < height
+ THEN upper INCR step
+ ELIF t < height step
+ THEN right := to x - t + height;
+ upper := to y
+ ELSE right DECR step FI .
+
+calc end point:
+ IF t < width
+ THEN left DECR step
+ ELIF t < width step
+ THEN lower := from y + t - width;
+ left := from x
+ ELSE lower INCR step FI .
+
+END PROC fill left;
+
+PROC circle (INT CONST x, y, REAL CONST rad, from, to, INT CONST pattern,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ REAL VAR t :: from;
+ INT VAR last x :: x, last y :: y;
+ WHILE t <= to
+ REP calc circle;
+ draw step;
+ t INCR 1.0
+ PER;
+ line (x rad, y rad, x, y) .
+
+draw step:
+ IF pattern = 0
+ THEN line (last x, last y, x rad, y rad);
+ last x := x rad;
+ last y := y rad
+ ELSE line (x, y, x rad, y rad) FI .
+
+calc circle:
+ INT CONST x rad :: int (cosd (t)*rad+0.5)+x,
+ y rad :: int (sind (t)*rad+0.5)+y .
+
+END PROC circle;
+
+END PACKET comercial plot;
+
diff --git a/system/std.graphik/1.8.7/src/HP7475.plot b/system/std.graphik/1.8.7/src/HP7475.plot
new file mode 100644
index 0000000..860dd03
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/HP7475.plot
@@ -0,0 +1,254 @@
+PACKET hp7475 plot DEFINES set range, (*Autor: Heiko Indenbirken *)
+ get range, (*Stand: 03.09.86/15:09 *)
+ drawing area,
+ begin plot,
+ end plot,
+ clear,
+
+ set pen, get pen,
+ move,
+ draw,
+ marker,
+ bar, circle,
+ where:
+
+(* *)
+(* Hardware Anschluß des HP7475A: *)
+(* 9600 Baud, 8 Bit, no parity, RTS/CTS *)
+(* Leitungen 1 ----- 1 *)
+(* gekreuzt: 2 --x-- 3 *)
+(* 3 --x-- 2 *)
+(* *)
+
+
+LET POS = STRUCT (INT x, y);
+LET RANGE = STRUCT (POS min, max);
+LET PEN = STRUCT (INT back, fore, thick, line);
+
+LET width scale = 0.002690217391304,
+ height scale = 0.002728921124206;
+
+LET term = ";",
+ comma = ",",
+ point = ".",
+ zero = "0",
+ nil = "",
+ etx = ""3"";
+
+
+POS VAR old :: POS:(0, 0);
+RANGE VAR area :: RANGE:(POS:(0,0), POS:(11040, 7721));
+PEN VAR pen :: PEN : (0, 1, 0, 1);
+TEXT VAR result;
+
+ROW 16 TEXT VAR mark := ROW 16 TEXT:
+("99,0,2,-2,0,0,-4,4,0,0,4,-2,0;",
+"99,0,2,-1,0,-1,-1,0,-2,1,-1,2,0,1,1,0,2,-1,1,-1,0;",
+"99,0,2,-2,-3,4,0,-2,3;",
+"-99,-2,0,99,4,0,-99,-2,2,99,0,-4;",
+"-99,-2,-2,99,4,4,-99,-4,0,99,4,-4;",
+"99,0,2,-2,-2,2,-2,2,2,-2,2;",
+"-99,0,-2,99,0,4,-2,-2,4,0,-2,2;",
+"-99,-2,0,99,4,0,-99,-2,2,99,0,-4,2,2,-2,2,-2,-2,2,-2;",
+"-99,-2,-2,99,4,4,-4,0,4,-4;",
+"-99,-2,2,99,4,0,-4,-4,4,0;",
+"99,0,-2,-99,-2,4,99,2,-2,2,2;",
+"99,1,1,-2,0,0,-2,2,0,0,2,1,1,-99,-4,0,99,1,-1,-99,0,-2,99,-1,-1,-99,4,0,99,-1,1;",
+"-99,-2,0,99,4,0,-99,-1,1,99,-2,-2,-99,1,-1,99,0,4,-99,-1,-1,99,2,-2;",
+"-99,-2,2,99,4,0,-4,-4,4,0,-4,4;",
+"-99,-2,0,99,4,0;",
+"-99,0,299,0,-4;");
+
+ROW 5 TEXT CONST line pattern := ROW 5 TEXT:("LT;", "LT1;", "LT2;", "LT3;", "LT4;");
+ROW 8 TEXT CONST fill pattern := ROW 8 TEXT:("FT4,25,45;", "FT1,0,0;", "FT3,50,0;",
+ "FT3,50,90;", "FT4,50,0;", "FT3,50,-45;",
+ "FT3,50,45;", "FT4,50,45;");
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 29.7; y cm := 21.07;
+ x pixel := 11040; y pixel := 7721;
+END PROC drawing area;
+
+
+PROC set range (INT CONST h min, v min, h max, v max):
+ IF h min >= h max OR v min >= v max
+ THEN errorstop ("Incorrect Range") FI;
+ area := RANGE:(POS:(h min, v min), POS:(h max, v max))
+END PROC set range;
+
+PROC get range (INT VAR h min, v min, h max, v max):
+ h min := area.min.x; v min := area.min.y;
+ h max := area.max.x; v max := area.max.y
+END PROC get range;
+
+PROC begin plot:
+ out ("IN;")
+ENDPROC begin plot;
+
+PROC end plot:
+ TEXT VAR rec;
+ out ("IN;SP;PA22040,7721;DP;");
+ REP pause (10);
+ out ("OS;");
+ input (rec, ""13"", 600)
+ UNTIL enter pressed PER;
+ out ("IN;") .
+
+enter pressed:
+ (int (rec) AND 4) > 0 .
+
+ENDPROC end plot;
+
+PROC clear:
+ new values (29.7, 21.07, 11040, 7721, area.min.x, area.max.x, area.min.y, area.max.y);
+ pen := PEN : (0, 1, 0, 1);
+ old := area.min;
+ out ("DF;IP;"); (* Default *)
+ out ("IW" + text (area.min.x, area.min.y) + ", " + (* Clipping *)
+ text (area.max.x, area.max.y) + term);
+ out ("SP1;"); (* Pen 1 *)
+ out ("LT;"); (* durchgehend *)
+ out ("PU;PA" + text (old.x, old.y)); (* Startpunkt *)
+
+END PROC clear;
+
+PROC set pen (INT CONST back, fore, thick, type):
+ set colour;
+ set linetype .
+
+set colour:
+ IF abs (fore) >= 1 AND abs (fore) <= 6
+ THEN out ("SP" + text (abs (fore)) + term);
+ pen.fore := abs (fore);
+ FI .
+
+set linetype:
+ IF type >= 1 AND type <= 5
+ THEN out (line pattern [type]);
+ pen.line := type
+ ELSE out ("SP;");
+ pen.line := 0
+ FI .
+
+END PROC set pen;
+
+PROC get pen (INT VAR back, fore, thick, line):
+ back := pen.back;
+ fore := pen.fore;
+ thick := pen.thick;
+ line := pen.line
+END PROC get pen;
+
+PROC move (INT CONST x, y) :
+ out ("PU;PA" + text (x, y) + term);
+ old := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y):
+ out ("PD;PA" + text (x, y) + term);
+ old := POS : (x, y)
+END PROC draw;
+
+PROC draw (TEXT CONST msg, REAL CONST angle, INT CONST height, width):
+ set angle;
+ set height and width;
+ plot msg .
+
+set angle:
+ out ("DI " + text (cosd (angle), sind (angle)) + term) .
+
+set height and width:
+ IF width = 0 AND height = 0
+ THEN out ("SR;")
+ ELSE out ("SI" + text (real (width) * width scale,
+ real (height) * height scale) + term)
+ FI .
+
+plot msg:
+ out ("LB" + msg + etx) .
+
+END PROC draw;
+
+PROC bar (INT CONST from x, from y, to x, to y, pattern):
+ out ("PU;PA" + text (from x, from y) + term);
+ out ("LT;EA" + text (to x, to y) + term);
+ IF pattern > 0 AND pattern <= 8
+ THEN out (fill pattern [pattern]);
+ out ("RA" + text (to x, to y) + term);
+ FI;
+ out ("PU;PA" + text (old.x, old.y) + term);
+ out (line pattern [pen.line]) .
+
+END PROC bar;
+
+PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern):
+ out ("LT;PU;PA" + text (x, y) + term);
+ IF (from MOD 360.0) = 0.0 AND (to MOD 360.0) = 0.0
+ THEN out ("CI" + text (rad) + term)
+ ELSE out ("EW" + text (rad) + comma + text (from, to-from) + term) FI;
+
+ IF pattern > 0 AND pattern <= 6
+ THEN out (fill pattern [pattern]);
+ out ("WG" + text (rad) + comma + text (from, to-from) + term)
+ FI;
+ out ("PU;PA" + text (old.x, old.y) + term);
+ out (line pattern [pen.line]) .
+
+END PROC circle;
+
+PROC marker (INT CONST x, y, no, size):
+ out ("LT;PU;PA" + text (x, y) + term);
+ out ("DI1,0;");
+ IF size = 0
+ THEN out ("SI0.25,0.5;")
+ ELSE out ("SI" + text (real (size)*0.001, real (size)*0.002) + term) FI;
+ out ("UC" + mark [mark no]);
+ out ("PU;PA" + text (old.x, old.y) + term);
+ out (line pattern [pen.line]) .
+
+mark no:
+ IF no >= 1 AND no <= 16
+ THEN no
+ ELSE 1 FI .
+
+END PROC marker;
+
+PROC where (INT VAR x, y):
+ x := old.x; y := old.y
+END PROC where;
+
+TEXT PROC text (INT CONST x, y):
+ text (x) + comma + text (y)
+END PROC text;
+
+TEXT PROC text (REAL CONST x, y):
+ text (x) + comma + text (y)
+END PROC text;
+
+TEXT PROC text (REAL CONST x):
+ result := compress (text (x, 9, 4));
+
+ IF (result SUB 1) = point
+ THEN insert char (result, zero, 1)
+ ELIF (result SUB LENGTH result) = point
+ THEN result CAT zero FI;
+ result
+END PROC text;
+
+PROC input (TEXT VAR rec, TEXT CONST del, INT CONST time):
+ enable stop;
+ rec := nil;
+ REP TEXT CONST char := incharety (time);
+
+ IF char = nil
+ THEN errorstop ("Timeout after " + text (time))
+ ELIF pos (del, char) > 0
+ THEN LEAVE input
+ ELSE rec CAT char FI
+
+ PER .
+
+END PROC input;
+
+END PACKET hp7475 plot
+
diff --git a/system/std.graphik/1.8.7/src/PC.plot b/system/std.graphik/1.8.7/src/PC.plot
new file mode 100644
index 0000000..712f5ea
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/PC.plot
@@ -0,0 +1,758 @@
+PACKET clipping DEFINES set range, (*Autor: Heiko Indenbirken *)
+ get range, (*Stand: 27.06.85/12:39 *)
+ clip: (*Änderung: 11.08.86/15:02 *)
+
+INT VAR x min :: 0, x max :: 1024, y min :: 0, y max :: 1024;
+
+PROC set range (INT CONST h min, v min, h max, v max):
+ IF h min >= h max OR v min >= v max
+ THEN errorstop ("Incorrect Range") FI;
+ x min := h min; x max := h max;
+ y min := v min; y max := v max
+END PROC set range;
+
+PROC get range (INT VAR h min, v min, h max, v max):
+ h min := x min; h max := x max;
+ v min := y min; v max := y max
+END PROC get range;
+
+PROC clip (INT CONST from x, from y, to x, to y,
+ PROC (INT CONST, INT CONST) move,
+ PROC (INT CONST, INT CONST) draw):
+ INT VAR x, y;
+ calculate parts of line;
+ IF both points inside
+ THEN draw (from x, from y); (* Macke im SHARD *)
+ draw (to x, to y)
+ ELIF both points outside
+ THEN
+ ELIF first point outside
+ THEN intersection (to x, to y, from x, from y, from part, x, y);
+ move (x, y);
+ draw (x, y); (* Macke im SHARD *)
+ draw (to x, to y)
+ ELIF second point outside
+ THEN intersection (from x, from y, to x, to y, to part, x, y);
+ draw (x, y)
+ ELSE intersection (to x, to y, from x, from y, from part, x, y);
+ move (x, y);
+ draw (x, y); (* Macke im SHARD *)
+ clip (x, y, to x, to y, PROC (INT CONST, INT CONST) move,
+ PROC (INT CONST, INT CONST) draw)
+ FI .
+
+calculate parts of line:
+ INT CONST from part :: part (from x, from y),
+ to part :: part (to x, to y) .
+
+both points inside:
+ from part = 0 AND to part = 0 .
+
+both points outside:
+ (from part AND to part) <> 0 .
+
+first point outside:
+ from part <> 0 AND to part = 0 .
+
+second point outside:
+ to part <> 0 AND from part = 0 .
+
+END PROC clip;
+
+INT PROC part (INT CONST x, y):
+ INT VAR index :: 0;
+ IF x > x max
+ THEN set bit (index, 0)
+ ELIF x < x min
+ THEN set bit (index, 1) FI;
+
+ IF y > y max
+ THEN set bit (index, 2)
+ ELIF y < y min
+ THEN set bit (index, 3) FI;
+
+ index
+
+END PROC part;
+
+PROC intersection (INT CONST from x, from y, to x, to y, to part, INT VAR x, y):
+ SELECT to part OF
+ CASE 1: right side
+ CASE 2: left side
+ CASE 4: up side
+ CASE 5: upright side
+ CASE 6: upleft side
+ CASE 8: down side
+ CASE 9: downright side
+ CASE 10: downleft side
+ OTHERWISE errorstop ("wrong partno.:" + text (to part)) ENDSELECT .
+
+right side:
+ y := from y + int (real (x max-from x)*(dy/dx));
+ x := x max .
+
+left side:
+ y := from y + int (real (x min-from x)*(dy/dx));
+ x := x min .
+
+up side:
+ x := from x + int (real (y max-from y)*(dx/dy));
+ y := y max .
+
+down side:
+ x := from x + int (real (y min-from y)*(dx/dy));
+ y := y min .
+
+upright side:
+ right side;
+ IF y > y max
+ THEN up side FI .
+
+downright side:
+ right side;
+ IF y < y min
+ THEN down side FI .
+
+upleft side:
+ left side;
+ IF y > y max
+ THEN up side FI .
+
+downleft side:
+ left side;
+ IF y < y min
+ THEN down side FI .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC intersection;
+
+END PACKET clipping;
+
+PACKET thick line DEFINES thick: (*Autor: Heiko Indenbirken *)
+ (*Stand: 02.07.85/15:07 *)
+ (*Änderung: 05.08.86/15:52 *)
+PROC thick (INT CONST x0, y0, x1, y1, thick,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ IF is point
+ THEN draw point
+ ELIF is horizontal line
+ THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ x0, y0, x1, y1, thick)
+ ELSE vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ x0, y0, x1, y1, thick)
+ FI .
+
+is point:
+ x0 = x1 AND y0 = y1 .
+
+is horizontal line:
+ abs (x0-x1) >= abs (y0-y1) .
+
+draw point:
+ INT VAR i;
+ FOR i FROM -thick UPTO thick
+ REP line (x0-thick, y0+i, x0+thick, y0+i) PER .
+
+END PROC thick;
+
+PROC horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ INT CONST from x, from y, to x, to y, thick):
+ IF from x > to x
+ THEN horizontal line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ to x, to y, from x, from y, thick)
+ ELSE draw line FI .
+
+draw line:
+ INT VAR i;
+ calculate increase;
+ calculate limit points;
+ FOR i FROM -thick UPTO thick
+ REP calculate delta x;
+ line (x start+delta x, y start+i, x end+delta x, y end+i)
+ PER .
+
+calculate increase:
+ REAL VAR increase :: -dy / dx .
+
+calculate limit points:
+ INT CONST x start :: from x - thick,
+ x end :: to x + thick,
+ y start :: from y + int (increase * real (thick)),
+ y end :: to y - int (increase * real (thick)) .
+
+calculate delta x:
+ INT CONST delta x :: int (increase*real (i)) .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC horizontal line;
+
+PROC vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ INT CONST from x, from y, to x, to y, thick):
+ IF from y > to y
+ THEN vertical line (PROC (INT CONST, INT CONST, INT CONST, INT CONST) line,
+ to x, to y, from x, from y, thick)
+ ELSE draw line FI .
+
+draw line:
+ INT VAR i;
+ calculate increase;
+ calculate limit points;
+ FOR i FROM -thick UPTO thick
+ REP calculate delta y;
+ line (x start+i, y start+delta y, x end+i, y end+delta y)
+ PER .
+
+calculate increase:
+ REAL VAR increase :: -dx / dy .
+
+calculate limit points:
+ INT CONST x start :: from x + int (increase * real (thick)),
+ x end :: to x - int (increase * real (thick)),
+ y start :: from y - thick,
+ y end :: to y + thick .
+
+calculate delta y:
+ INT CONST delta y :: int (increase*real (i)) .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC vertical line;
+
+END PACKET thick line;
+
+PACKET graphik text DEFINES draw char, (*Autor: Heiko Indenbirken *)
+ zeichensatz: (*Stand: 27.06.85/16:03 *)
+ (*Änderung: 28.06.85/19:06 *)
+ (*Änderung: 05.08.86/16:00 *)
+LET ZEICHENSATZ = ROW 255 TEXT;
+ZEICHENSATZ VAR zeichen;
+INT CONST char x :: 6, char y :: 10;
+
+zeichensatz ("ZEICHENSATZ");
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
+ zeichen := new zeichen;
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC draw char (INT CONST char no, INT CONST x, y, x size, y size, direction,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ TEXT CONST character :: zeichen [char no];
+ INT VAR n :: 1, x0, y0, x1, y1;
+ INT CONST len :: length (character);
+ WHILE n < len
+ REP value (character, n, x0, y0, x1, y1);
+ transform (x0, y0, x, y, x size, y size, direction);
+ transform (x1, y1, x, y, x size, y size, direction);
+ line (x0, y0, x1, y1);
+ n INCR 4
+ PER .
+
+END PROC draw char;
+
+PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1):
+ x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1));
+ x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3));
+END PROC value;
+
+INT PROC val (INT CONST n):
+ IF n > 127
+ THEN -256 OR n
+ ELSE n FI
+END PROC val;
+
+PROC transform (INT VAR x, y, INT CONST x0, y0, x size, y size, direction):
+ INT CONST old x :: x, old y :: y;
+ SELECT direction OF
+ CASE 0: x := x0 + x vektor; y := y0 + y vektor
+ CASE 1: x := x0 - y vektor; y := y0 + x vektor
+ CASE 2: x := x0 - x vektor; y := y0 - y vektor
+ CASE 3: x := x0 + y vektor; y := y0 - x vektor
+ ENDSELECT .
+
+x vektor:
+ IF x size = 0
+ THEN old x
+ ELSE (old x*x size) DIV char x FI .
+
+y vektor:
+ IF y size = 0
+ THEN old y
+ ELSE (old y*y size) DIV char y FI .
+
+END PROC transform;
+
+END PACKET graphik text;
+
+PACKET graphik text DEFINES draw text: (*Autor: Heiko Indenbirken *)
+ (*Stand: 03.07.85/11:55 *)
+ (*Änderung: 05.08.86/16:04 *)
+PROC draw text (INT CONST x pos, y pos,
+ TEXT CONST msg, REAL CONST angle, INT CONST height, width,
+ PROC (INT CONST, INT CONST,
+ INT CONST, INT CONST, INT CONST, INT CONST) draw char):
+ INT CONST dir :: int (((angle MOD 360.0)+45.0) / 90.0);
+ INT VAR i;
+ REAL VAR x :: real (x pos), y :: real (y pos),
+ x step :: cosd (angle)*real (width),
+ y step :: sind (angle)*real (width);
+ FOR i FROM 1 UPTO length (msg)
+ REP IF control char
+ THEN execute control char
+ ELSE execute normal char FI
+ PER .
+
+control char:
+ akt char < ""32"" .
+
+execute control char:
+ SELECT code (akt char) OF
+ CASE 1: home
+ CASE 2: right
+ CASE 3: up
+ CASE 7: out (""7"")
+ CASE 8: left
+ CASE 10: down
+ CASE 13: return
+ ENDSELECT .
+
+home:
+ x := real (x pos);
+ y := real (y pos) .
+
+right:
+ x INCR x step; y INCR y step .
+
+up:
+ x INCR y step; y INCR x step .
+
+left:
+ x DECR x step; y DECR y step .
+
+down:
+ x DECR y step; y DECR x step .
+
+return:
+ x := real (x pos) .
+
+execute normal char:
+ draw char (code (akt char), dir, int (x+0.5), int (y+0.5), height, width);
+ x INCR x step;
+ y INCR y step .
+
+akt char:
+ msg SUB i .
+
+END PROC draw text;
+
+END PACKET graphik text;
+
+PACKET comercial plot DEFINES bar, (*Autor: Heiko Indenbirken *)
+ circle: (*Stand: 03.04.1985 *)
+ (*Änderung: 03.07.85/15:37 *)
+PROC bar (INT CONST from x, from y, to x, to y, pattern,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ IF from x > to x
+ THEN bar (to x, from y, from x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ ELIF from y > to y
+ THEN bar (from x, to y, to x, from y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ ELSE draw frame;
+ fill frame with pattern
+ FI .
+
+draw frame:
+ line (from x, from y, from x, to y);
+ line (from x, to y, to x, to y);
+ line (to x, to y, to x, from y);
+ line (to x, from y, from x, from y) .
+
+fill frame with pattern:
+ SELECT pattern OF
+ CASE 1: fill right (from x, to x, from y, to y, 2, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 2: fill hor (from x, to x, from y, to y, 1, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 3: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 4: fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 5: fill hor (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line);
+ fill vert (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 6: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 7: fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ CASE 8: fill right (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line);
+ fill left (from x, to x, from y, to y, 5, PROC (INT CONST, INT CONST, INT CONST, INT CONST) line)
+ ENDSELECT .
+
+END PROC bar;
+
+PROC fill hor (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT VAR y :: from y;
+ REP line (from x, y, to x, y);
+ y INCR step
+ UNTIL y > to y PER .
+
+END PROC fill hor;
+
+PROC fill vert (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT VAR x :: from x;
+ REP line (x, from y, x, to y);
+ x INCR step
+ UNTIL x > to x PER .
+
+END PROC fill vert;
+
+PROC fill right (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT CONST width :: to x - from x,
+ height :: to y - from y,
+ length :: width + height,
+ height step :: height + step,
+ width step :: width + step;
+
+ INT VAR t :: step, left :: from x, right :: from x,
+ lower :: from y, upper :: from y;
+(* Ausfüllen von links unten nach rechts oben *)
+ WHILE t < length
+ REP calc start point;
+ calc end point;
+ line (left, upper, right, lower);
+ t INCR step
+ PER .
+
+calc start point:
+ IF t < height
+ THEN upper INCR step
+ ELIF t < height step
+ THEN left := from x + t - height;
+ upper := to y
+ ELSE left INCR step FI .
+
+calc end point:
+ IF t < width
+ THEN right INCR step
+ ELIF t < width step
+ THEN lower := from y + t - width;
+ right := to x
+ ELSE lower INCR step FI .
+
+END PROC fill right;
+
+PROC fill left (INT CONST from x, to x, from y, to y, step,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ INT CONST width :: to x - from x,
+ height :: to y - from y,
+ length :: width + height,
+ height step :: height + step,
+ width step :: width + step;
+
+ INT VAR t :: step, left :: to x, right :: to x,
+ lower :: from y, upper :: from y;
+(* Ausfüllen von rechts unten nach links oben *)
+ WHILE t < length
+ REP calc start point;
+ calc end point;
+ line (right, upper, left, lower);
+ t INCR step
+ PER .
+
+calc start point:
+ IF t < height
+ THEN upper INCR step
+ ELIF t < height step
+ THEN right := to x - t + height;
+ upper := to y
+ ELSE right DECR step FI .
+
+calc end point:
+ IF t < width
+ THEN left DECR step
+ ELIF t < width step
+ THEN lower := from y + t - width;
+ left := from x
+ ELSE lower INCR step FI .
+
+END PROC fill left;
+
+PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) line):
+ REAL VAR t :: from;
+ INT VAR last x :: x, last y :: y;
+ WHILE t <= to
+ REP calc circle;
+ draw step;
+ t INCR 5.0
+ PER;
+ line (x rad, y rad, x, y) .
+
+draw step:
+ IF pattern = 0
+ THEN line (last x, last y, x rad, y rad);
+ last x := x rad;
+ last y := y rad
+ ELSE line (x, y, x rad, y rad) FI .
+
+calc circle:
+ INT CONST x rad :: int (cosd (t)*real (rad)+0.5)+x,
+ y rad :: int (sind (t)*real (rad)+0.5)+y .
+
+END PROC circle;
+
+END PACKET comercial plot;
+
+PACKET pc plot DEFINES drawing area, (*Autor: Heiko Indenbirken *)
+ begin plot, (*Stand: 20.05.85 *)
+ end plot, (*Änderung: 27.06.85/16:17 *)
+ clear, (*Änderung: 03.07.85/15:59 *)
+ (*Änderung: 06.08.86/10:03 *)
+ graphik,
+ set pen, get pen,
+
+ move,
+ draw,
+ draw line,
+ marker,
+ bar, circle,
+ where:
+
+
+LET POS = STRUCT (INT x, y);
+LET PEN = STRUCT (INT back, fore, thick, line);
+INT CONST back code :: -4,
+ modus code :: -5,
+ draw code :: -6,
+ move code :: -7,
+ pen code :: -8,
+ full line :: -1;
+
+INT VAR d, y, pause time :: 10,
+ resolution :: 4, max x :: 319, max y :: 199;
+BOOL VAR is clear := FALSE;
+POS VAR old :: POS : (0, 0);
+PEN VAR pen :: PEN : (0, 1, 0, full line);
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 22.0; y cm := 13.7;
+ x pixel := max x; y pixel := max y;
+END PROC drawing area;
+
+PROC graphik (INT CONST modus, pause):
+ pause time := pause;
+ SELECT modus OF
+ CASE 0: resolution := 3;
+ CASE 1: resolution := 72;
+ max x := 639;
+ max y := 399
+ CASE 2: resolution := 64;
+ max x := 639;
+ max y := 399
+ CASE 3: resolution := 6;
+ max x := 639;
+ max y := 199
+ CASE 4: resolution := 4;
+ max x := 319;
+ max y := 199
+ OTHERWISE errorstop ("Nur Modi 0-4") ENDSELECT;
+
+ set range (0, 0, max x, max y);
+END PROC graphik;
+
+PROC begin plot :
+ control (modus code, resolution, 0, d);
+ is clear := TRUE;
+ENDPROC begin plot ;
+
+PROC end plot :
+ IF pause time > 0
+ THEN indicate end plot FI;
+ control (modus code, 3, 0, d) .
+
+indicate end plot:
+ control (pen code, full line, full line, d);
+ REP set indicator;
+ UNTIL incharety (pause time) <> "" PER .
+
+set indicator:
+ control (move code, 0, max y, d);
+ control (draw code, max x, max y, d) .
+
+ENDPROC end plot ;
+
+PROC clear:
+ INT VAR x0, x1, y0, y1;
+ new values (22.0, 13.7, max x, max y, x0, x1, y0, y1);
+ set range (x0, y0, x1, y1);
+ clear screen;
+ clear pen;
+ clear pos;
+ is clear := FALSE .
+
+clear screen:
+ IF is clear OR full screen
+ THEN control (modus code, resolution, 0, d)
+ ELSE draw frame;
+ clear frame
+ FI .
+
+full screen:
+ x0 < 10 AND x1 > (max x-10) AND
+ y0 < 10 AND y1 > (max y-10) .
+
+draw frame:
+ control (move code, x0, y0, d);
+ control (draw code, x1, y0, d);
+ control (draw code, x1, y1, d);
+ control (draw code, x0, y1, d);
+ control (draw code, x0, y0, d) .
+
+clear frame:
+ control (pen code, full line, 0, d);
+ FOR y FROM max y-y1 UPTO max y-y0
+ REP control (move code, x0, y, d);
+ control (draw code, x1, y, d);
+ PER .
+
+clear pen:
+ pen := PEN : (0, 1, 0, full line);
+ control (pen code, full line, 1, d) .
+
+clear pos:
+ old := POS : (x0, y0);
+ control (move code, x0, max y-y0, d) .
+
+END PROC clear;
+
+PROC set pen (INT CONST back, fore, thick, type):
+ set background;
+ set foreground and linetype;
+ set thickness .
+
+set background:
+ pen.back := back; (*Hintergrund über niederwertiges *)
+ control (back code, 0, back no, d) .(*Byte von colour code *)
+ (*Höherwetiges Byte regelt die *)
+back no: (*Farbpalette *)
+ IF back = 0
+ THEN std background
+ ELSE back FI .
+
+std background:
+ IF resolution = 4
+ THEN 16
+ ELSE 15 FI .
+
+set foreground and linetype: (*0, 1, 2, 3 Farben: löschend,*)
+ pen.fore := possible colour; (*ändernd oder überschreibend *)
+ pen.line := type; (* in allen Linientypen. *)
+ control (pen code, line (type), pen.fore, d) .
+
+possible colour:
+ IF fore <= full line
+ THEN full line
+ ELIF fore > 3 OR (fore > 1 AND resolution <> 4)
+ THEN 1
+ ELSE fore FI .
+
+set thickness:
+ pen.thick := thick DIV 10 .
+
+END PROC set pen;
+
+PROC get pen (INT VAR back, fore, thick, line):
+ back := pen.back;
+ fore := pen.fore;
+ thick := pen.thick;
+ line := pen.line
+END PROC get pen;
+
+INT PROC line (INT CONST type):
+ SELECT type OF
+ CASE 0: 0
+ CASE 1: full line
+ CASE 2: 21845
+ CASE 3: 3855
+ CASE 4: 255
+ CASE 5: 4351
+ OTHERWISE type END SELECT
+END PROC line;
+
+PROC int move (INT CONST x, y):
+ control (move code, x, max y-y, d);
+END PROC int move;
+
+PROC int draw (INT CONST x, y):
+ control (draw code, x, max y-y, d);
+END PROC int draw;
+
+PROC draw line (INT CONST from x, from y, to x, to y):
+ control (move code, from x, max y-from y, d);
+ clip (from x, from y, to x, to y, PROC int move, PROC int draw)
+END PROC draw line;
+
+PROC move (INT CONST x, y) :
+ control (move code, x, max y-y, d);
+ old := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y):
+ IF std thickness
+ THEN clip (old.x, old.y, x, y, PROC int move, PROC int draw)
+ ELSE thick (old.x, old.y, x, y, pen.thick, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line) FI;
+ old := POS : (x, y) .
+
+std thickness: pen.thick = 0 .
+END PROC draw;
+
+PROC draw (TEXT CONST msg, REAL CONST angle, INT CONST height, width):
+ control (pen code, full line, pen.fore, d);
+ draw text (old.x, old.y, msg, angle, y size, x size,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST, INT CONST, INT CONST) draw char);
+ control (move code, old.x, max y-old.y, d);
+ control (pen code, line (pen.line), pen.fore, d) .
+
+x size: IF width = 0
+ THEN 6
+ ELSE width FI .
+y size: IF height = 0
+ THEN 10
+ ELSE height FI .
+
+END PROC draw;
+
+PROC draw char (INT CONST char, direction, x, y, INT CONST height, width):
+ draw char (char, x, y, width, height, direction,
+ PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line)
+END PROC draw char;
+
+PROC bar (INT CONST from x, from y, to x, to y, pattern):
+ control (pen code, full line, pen.fore, d);
+ bar (from x, from y, to x, to y, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line);
+ control (move code, old.x, max y-old.y, d);
+ control (pen code, line (pen.line), pen.fore, d) .
+END PROC bar;
+
+PROC circle (INT CONST x, y, rad, REAL CONST from, to, INT CONST pattern):
+ control (pen code, full line, pen.fore, d);
+ circle (x, y, rad, from, to, pattern, PROC (INT CONST, INT CONST, INT CONST, INT CONST) draw line);
+ control (move code, old.x, max y-old.y, d);
+ control (pen code, line (pen.line), pen.fore, d) .
+END PROC circle;
+
+PROC marker (INT CONST x, y, no, size):
+ control (pen code, full line, pen.fore, d);
+ draw char (no, 0, x, y, size, size);
+ control (move code, old.x, max y-old.y, d);
+ control (pen code, line (pen.line), pen.fore, d) .
+END PROC marker;
+
+PROC where (INT VAR x, y):
+ x := old.x; y := old.y
+END PROC where;
+
+END PACKET pc plot
+
diff --git a/system/std.graphik/1.8.7/src/ZEICHENSATZ b/system/std.graphik/1.8.7/src/ZEICHENSATZ
new file mode 100644
index 0000000..9866ec2
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/ZEICHENSATZ
Binary files differ
diff --git a/system/std.graphik/1.8.7/src/gen Graphik b/system/std.graphik/1.8.7/src/gen Graphik
new file mode 100644
index 0000000..f70cc66
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/gen Graphik
@@ -0,0 +1,16 @@
+TEXT VAR geraet;
+page;
+out ("Bitte den Namen der Hardwareanpassung (z.B. 'PC.plot') eingeben: ");
+get line (geraet);
+IF NOT exists (geraet)
+THEN errorstop ("Endgerät nicht vorhanden") FI;
+
+insert ("GRAPHIK.Picfile");
+insert ("GRAPHIK.Transform");
+insert (geraet);
+insert ("GRAPHIK.Plot");
+
+
+
+
+
diff --git a/system/std.graphik/1.8.7/src/gen Plotter b/system/std.graphik/1.8.7/src/gen Plotter
new file mode 100644
index 0000000..73d7b2f
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/gen Plotter
@@ -0,0 +1,16 @@
+TEXT VAR geraet;
+page;
+out ("Bitte den Namen der Hardwareanpassung (z.B. 'PC.plot') eingeben: ");
+get line (geraet);
+IF NOT exists (geraet)
+THEN errorstop ("Endgerät nicht vorhanden") FI;
+
+insert ("GRAPHIK.Picfile");
+insert ("GRAPHIK.Transform");
+insert (geraet);
+insert ("GRAPHIK.Plotter");
+insert ("GRAPHIK.Server")
+
+
+
+
diff --git a/system/std.graphik/1.8.7/src/graphik editor b/system/std.graphik/1.8.7/src/graphik editor
new file mode 100644
index 0000000..7aa6e33
--- /dev/null
+++ b/system/std.graphik/1.8.7/src/graphik editor
@@ -0,0 +1,324 @@
+PACKET graphic editor DEFINES graphic, (*Autor: H.Indenbirken *)
+ picfile, picture, (*Stand: 26.02.1985 *)
+
+ neu zeichnen,
+
+ UP, DOWN, T,
+
+ pen, select pen, selected pen, background,
+ extrema pic, extrema picfile:
+
+
+
+LET norm cmd = ""1""27""3""10""9"epb"16"",
+ hop cmd = ""2""10""12""1"",
+ bell = ""7"",
+ esc = ""27"";
+
+PICFILE VAR p;
+PICTURE VAR pic;
+TEXT VAR command :: "", old command :: "", char, headline :: "";
+BOOL VAR within edit :: FALSE, new plot :: FALSE;
+ROW 3 ROW 2 REAL VAR size;
+ROW 2 ROW 2 REAL VAR limits;
+ROW 4 REAL VAR angles;
+ROW 2 REAL VAR oblique;
+ROW 3 REAL VAR perspective;
+
+PROC open graphic (TEXT CONST name, DATASPACE CONST ds):
+ p := ds;
+ get values (p, size, limits, angles, oblique, perspective);
+ head line := ""1""15"LEN ................................ DIM PEN .."14" Picture "15""14"";
+ replace (head line, 32-LENGTH name DIV 2, name);
+ new plot := TRUE;
+ within edit := TRUE
+END PROC open graphic;
+
+PROC graphic:
+ graphic (last param)
+END PROC graphic;
+
+PROC graphic (TEXT CONST name) :
+ IF NOT exists (name)
+ THEN IF yes ("Soll ein neuer Picfile eingerichtet werden")
+ THEN graphic (new (name), name) FI
+ ELSE graphic (old (name), name) FI
+
+END PROC graphic;
+
+PROC graphic (DATASPACE CONST f, TEXT CONST name) :
+ open graphic (name, f);
+ reset;
+ kommandos bearbeiten;
+ within edit := FALSE .
+
+kommandos bearbeiten :
+ REP IF new plot
+ THEN plot (p);
+ new plot := FALSE
+ FI;
+ read picture (p, pic);
+ out head line;
+ inchar (command);
+ do command
+ PER .
+
+out head line:
+ replace (headline, 7, text (length (pic), 5));
+ replace (headline, 50, text (dim (pic), 1));
+ replace (headline, 57, text (pen (pic), 2));
+ replace (headline, 72, text (picture no (p), 4));
+ out (head line) .
+
+do command:
+ SELECT pos (norm cmd, command) OF
+ CASE 1: hop commands
+ CASE 2: escape commands
+ CASE 3: position up
+ CASE 4: position down
+ CASE 5: position direct
+ CASE 6: extrema pic
+ CASE 7: selected pen (pen (pic));
+ CASE 8: out (1, 2, ""15""5"Hintergrundfarbe: " +
+ colour of (background (p)) + " "14"")
+ CASE 9: identify (pic);
+ OTHERWISE out (bell) ENDSELECT .
+
+position up :
+ IF is first picture (p)
+ THEN out (bell);
+ ELSE up (p) FI .
+
+position down :
+ IF eof (p)
+ THEN out (bell)
+ ELSE down (p) FI .
+
+position direct:
+ out (1, 68, "");
+ edit get (command, 4, 4);
+ to pic (p, int (command)) .
+
+hop commands :
+ inchar (command);
+ SELECT pos (hop cmd, command) OF
+ CASE 1: to first pic (p)
+ CASE 2: to eof (p)
+ CASE 3: delete picture (p);
+ IF NOT new plot
+ THEN erase (pic) FI
+ CASE 4: new plot := TRUE
+ OTHERWISE out (bell) ENDSELECT .
+
+escape commands :
+ inchar (command);
+ IF command = "q"
+ THEN LEAVE kommandos bearbeiten
+ ELIF command = "f"
+ THEN do (old command)
+ ELIF command = esc
+ THEN kommandomodus
+ ELSE do (kommando auf taste (command)) FI .
+
+END PROC graphic;
+
+PROC kommandomodus:
+ command := "";
+ disable stop;
+ REP get command;
+ do (command)
+ UNTIL command executed PER;
+
+ IF new values
+ THEN get values (size, limits, angles, oblique, perspective);
+ set values (p, size, limits, angles, oblique, perspective);
+ new plot := new plot OR new values
+ FI .
+
+get command:
+ REP out (1, 2, ""15"Gib Graphikkommando: ");
+ edit get (command, 0, 54, "", "k", char);
+ out (""14"");
+ out (1, 2, ""5"");
+
+ IF char = ""13""
+ THEN LEAVE get command
+ ELIF char = ""27"k"
+ THEN command := old command FI
+ PER .
+
+command executed:
+ IF is error
+ THEN out (1, 1, error message);
+ clear error;
+ FALSE
+ ELSE old command := command;
+ TRUE
+ FI .
+
+END PROC kommandomodus;
+
+PROC out (INT CONST x, y, TEXT CONST t):
+ cursor (x, y);
+ out (t)
+END PROC out;
+
+TEXT PROC colour of (INT CONST colour):
+ SELECT colour OF
+ CASE 0: "löschen"
+ CASE 1: "std"
+ CASE 2: "rot"
+ CASE 3: "blau"
+ CASE 4: "grün"
+ CASE 5: "schwarz"
+ CASE 6: "weiß"
+ OTHERWISE text (colour) ENDSELECT .
+END PROC colour of;
+
+TEXT PROC linetype of (INT CONST linetype):
+ SELECT linetype OF
+ CASE 0: "unsichtbar"
+ CASE 1: "durchgehend"
+ CASE 2: "gepunktet"
+ CASE 3: "kurz gestrichelt"
+ CASE 4: "lang gestrichelt"
+ CASE 5: "strichpunkt"
+ OTHERWISE text (linetype) ENDSELECT .
+END PROC linetype of;
+
+PICFILE PROC picfile :
+ IF NOT within edit
+ THEN errorstop ("Not within editmode") FI;
+ p
+END PROC picfile;
+
+PICTURE PROC picture :
+ IF NOT within edit
+ THEN errorstop ("Not within editmode") FI;
+ pic
+END PROC picture;
+
+PROC neu zeichnen:
+ new plot := TRUE
+END PROC neu zeichnen;
+
+OP UP (INT CONST distance):
+ up (p, distance);
+ read picture (p, pic)
+END OP UP;
+
+OP DOWN (INT CONST distance):
+ down (p, distance);
+ read picture (p, pic)
+END OP DOWN;
+
+OP T (INT CONST n):
+ to pic (p, n);
+ read picture (p, pic)
+END OP T;
+
+PROC pen (INT CONST n):
+ IF NOT new plot
+ THEN erase (pic) FI;
+
+ pen (pic, n);
+ write picture (p, pic);
+
+ IF NOT new plot
+ THEN show (pic) FI
+END PROC pen;
+
+PROC select pen (INT CONST n, colour, thickness, linetype, BOOL CONST hidden):
+ select pen (p, n, colour, thickness, linetype, hidden);
+ new plot := TRUE
+END PROC select pen;
+
+PROC select pen (INT CONST n, colour, thickness, linetype):
+ select pen (p, n, colour, thickness, linetype, FALSE);
+ new plot := TRUE
+END PROC select pen;
+
+PROC selected pen (INT CONST n, INT VAR colour, thickness, linetype,
+ BOOL VAR hidden):
+ selected pen (p, n, colour, thickness, linetype, hidden);
+END PROC selected pen;
+
+PROC selected pen (INT CONST n):
+ INT VAR colour, thickness, linetype;
+ BOOL VAR hidden;
+ selected pen (p, n, colour, thickness, linetype, hidden);
+ out (1, 2, ""5""15"PEN #" + text (n) + ": Farbe: " + colour of (colour) +
+ ", Dicke " + text (thickness) + ", Linientyp " + linetype of (linetype) +
+ hidden text + " "14"") .
+
+hidden text:
+ IF hidden
+ THEN ". "
+ ELSE ", nicht sichtbare Linien werden unterdrückt." FI .
+
+END PROC selected pen;
+
+INT PROC background:
+ background (p)
+END PROC background;
+
+PROC background (INT CONST n):
+ new plot := n <> background (p);
+ background (p, n)
+END PROC background;
+
+PROC extrema pic:
+ REAL VAR x min, x max, y min, y max, z min, z max;
+ IF dim (pic) = 2
+ THEN extrema (pic, x min, x max, y min, y max);
+ out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) +
+ "] [" + text (y min) + "," + text (y max) + "] "14"")
+ ELSE extrema (pic, x min, x max, y min, y max, z min, z max);
+ out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) +
+ "] [" + text (y min) + "," + text (y max) +
+ "] [" + text (z min) + "," + text (z max) +"] "14"")
+ FI
+END PROC extrema pic;
+
+PROC extrema picfile:
+ REAL VAR x min, x max, y min, y max, z min, z max;
+ extrema (p, x min, x max, y min, y max, z min, z max);
+ out (1, 2, ""5""15"Extrema: [" + text (x min) + "," + text (x max) +
+ "] [" + text (y min) + "," + text (y max) +
+ "] [" + text (z min) + "," + text (z max) +"] "14"")
+END PROC extrema picfile;
+
+PROC identify (PICTURE CONST pic):
+ begin plot;
+ hidden lines (TRUE);
+ pen (background (p), 1, 1, 2);
+ plot (pic);
+ end plot
+END PROC identify;
+
+PROC erase (PICTURE CONST pic):
+ INT VAR colour, thickness, linetype;
+ BOOL VAR hidden;
+
+ selected pen (p, pen (pic), colour, thickness, linetype, hidden);
+ begin plot;
+ hidden lines (TRUE);
+ pen (background (p), 0, thickness, linetype);
+ plot (pic);
+ end plot
+END PROC erase;
+
+PROC show (PICTURE CONST pic):
+ INT VAR colour, thickness, linetype;
+ BOOL VAR hidden;
+
+ selected pen (p, pen (pic), colour, thickness, linetype, hidden);
+ begin plot;
+ hidden lines (TRUE);
+ pen (background (p), colour, thickness, linetype);
+ plot (pic);
+ end plot
+END PROC show;
+
+END PACKET graphic editor;
+
diff --git a/system/std.zusatz/1.8.7/source-disk b/system/std.zusatz/1.8.7/source-disk
new file mode 100644
index 0000000..085c0a7
--- /dev/null
+++ b/system/std.zusatz/1.8.7/source-disk
@@ -0,0 +1 @@
+grundpaket/04_std.zusatz.img
diff --git a/system/std.zusatz/1.8.7/src/AT Generator b/system/std.zusatz/1.8.7/src/AT Generator
new file mode 100644
index 0000000..d3bfd6d
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/AT Generator
@@ -0,0 +1,135 @@
+(*************************************************************************)
+(*** Generiert Für IBM-AT einen neuen SYSUR-Zweig. ***)
+(*** Danach wird die eingebaute Hardwareuhr für die Systemzeit benutzt ***)
+(*** und andere Partitionen können mit neuem 'shutup' gebootet werden. ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+LET ack = 0,
+ nak = 1;
+
+cl eop (1, 4);
+erzeuge collector;
+erzeuge archive manager;
+erzeuge operator;
+erzeuge configurator;
+loesche collector;
+forget ("AT Generator", quiet);
+break.
+
+loesche collector :
+ end (/"colly");
+ put ("Collector gelöscht.");
+ line (2).
+
+erzeuge collector :
+ put line ("Generating 'Collector'...");
+ begin ("colly", PROC generate collector, t);
+ warte auf meldung;
+ IF answer = nak THEN end (/"colly");
+ errorstop (meldung)
+ FI.
+ TASK VAR t.
+
+erzeuge archive manager :
+ put line ("Generating 'ARCHIVE'...");
+ end (/"ARCHIVE");
+ begin ("ARCHIVE", PROC archive manager, t).
+
+erzeuge operator :
+ put line ("Generating 'OPERATOR'...");
+ end (/"OPERATOR");
+ begin ("OPERATOR", PROC monitor, t).
+
+erzeuge configurator :
+ put line ("Generating 'configurator'...");
+ end (/"configurator");
+ begin ("configurator", PROC generate configurator, t);
+ warte auf meldung;
+ IF answer = nak THEN errorstop (meldung) FI.
+
+warte auf meldung :
+ DATASPACE VAR ds; INT VAR answer;
+ wait (ds, answer, t);
+ BOUND TEXT VAR m := ds;
+ TEXT VAR meldung := m;
+ forget (ds).
+
+PROC generate collector :
+
+ disable stop;
+ fetch all (/"configurator");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ free global manager.
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate collector;
+
+PROC generate configurator :
+
+ disable stop;
+ fetch all (/"colly");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ enable stop;
+ new configuration;
+ setup;
+ global manager (PROC ( DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time).
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate configurator;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
diff --git a/system/std.zusatz/1.8.7/src/AT Utilities b/system/std.zusatz/1.8.7/src/AT Utilities
new file mode 100644
index 0000000..760e728
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/AT Utilities
@@ -0,0 +1,1057 @@
+(*************************************************************************)
+(*** AT-spezifische Software, die zum Lesen der Hardwareuhr und ***)
+(*** Booten in anderen Partitionen benötigt wird. ***)
+(*** ***)
+(*** Zusammengestellt und geändert : Werner Sauerwein, GMD ***)
+(*** Stand : 31.10.86 ***)
+(*************************************************************************)
+
+PACKET splitting DEFINES low byte, (* Copyright (C) 1985 *)
+ high byte, (* Martin Schönbeck, Spenge *)
+ low word, (* Stand: 13.09.85 *)
+ high word:
+
+INT PROC high byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 2)
+
+END PROC high byte;
+
+INT PROC low byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 1)
+
+END PROC low byte;
+
+INT PROC high word (REAL CONST double precission int):
+
+ int (double precission int / 65536.0)
+
+END PROC high word;
+
+INT PROC low word (REAL CONST double precission int):
+
+ string of low bytes ISUB 1.
+
+string of low bytes:
+ code (int (double precission int MOD 256.0)) +
+ code (int ((double precission int MOD 65536.0) / 256.0)).
+
+END PROC low word;
+
+END PACKET splitting;
+
+
+PACKET basic block io DEFINES
+
+ read block,
+ write block:
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, 0, block no, return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, 0, block no, return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, high word (block no),
+ low word (block no), return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, high word (block no),
+ low word (block no), return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+END PACKET basic block io;
+
+
+PACKET utilities DEFINES getchoice, cleol, cleop, inverse, put center:
+
+INT PROC get choice (INT CONST von, bis, TEXT VAR retchar):
+ get choice (von, bis, von, retchar)
+END PROC get choice;
+
+INT PROC get choice (INT CONST von, bis, zusatz, TEXT VAR retchar):
+ LET return = ""13"",
+ escape = ""27"",
+ left = ""8"";
+ TEXT VAR buffer;
+ INT VAR cx, cy;
+ get cursor (cx, cy); out (" " + left);
+ REP
+ REP
+ cursor (cx, cy); buffer := incharety;
+ UNTIL input ok OR buffer = escape PER;
+ IF buffer = escape THEN retchar := escape;
+ LEAVE get choice WITH 0
+ FI;
+ out (buffer);
+ leseschleife bis left or ret;
+ IF retchar = left THEN out (left + " ") FI;
+ IF retchar = escape THEN LEAVE get choice WITH 0 FI
+ UNTIL retchar = return OR retchar = escape PER;
+ int (buffer).
+
+input ok : (buffer >= text (von) AND buffer <= text (bis)) OR buffer = text (zusatz).
+
+leseschleife bis left or ret:
+ REP
+ inchar (retchar)
+ UNTIL retchar = return OR retchar = left OR retchar = escape PER.
+
+END PROC get choice;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+END PACKET utilities
+
+
+PACKET part DEFINES activate, show actual partition table:
+ (* Copyright (C) 1985 *)
+ (* Martin Schönbeck, Spenge *)
+ (* Stand : 02.02.86 *)
+ (* Changed by : W.Sauerwein *)
+ (* I.Ley *)
+ (* Stand : 03.10.86 *)
+ LET fd channel = 28;
+
+ROW 256 INT VAR boot block;
+INT VAR boot block session := session - 1;
+
+PROC get boot block:
+ IF boot block session <> session
+ THEN hole aktuellen boot block
+ FI.
+
+hole aktuellen boot block:
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ get external block (dummy ds, 2, 0, fd channel);
+ IF NOT is error
+ THEN transfer data to boot block
+ FI;
+ forget (dummy ds).
+
+transfer data to boot block:
+ IF not valid boot block
+ THEN try to get valid boot block from file
+ FI;
+ boot block := partition table. block;
+ boot block session := session.
+
+not valid boot block:
+ partition table. block [256] <> boot indicator OR
+ it is an old boot block of eumel.
+
+boot indicator: -21931.
+
+it is an old boot block of eumel:
+ partition table. block [1] = 1514.
+
+try to get valid boot block from file:
+ forget (dummy ds);
+ partition table := old ("bootblock");
+ IF is error THEN LEAVE transfer data to boot block FI.
+
+END PROC get boot block;
+
+PROC put boot block:
+ IF boot block ist uptodate
+ THEN schreibe block auf platte
+ ELSE errorstop ("boot block nicht uptodate")
+ FI.
+
+boot block ist uptodate:
+ boot block session = session.
+
+schreibe block auf platte:
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ transfer data to dataspace;
+ put external block (dummy ds, 2, 0, fd channel);
+ forget (dummy ds).
+
+transfer data to dataspace:
+ partition table. block := boot block.
+
+END PROC put boot block;
+
+INT PROC partition type (INT CONST partition):
+ low byte (boot block [entry (partition) + 2])
+END PROC partition type;
+
+REAL PROC partition start (INT CONST partition):
+ unsigned low word + high word.
+
+unsigned low word:
+ real (low byte (boot block [entry (partition) + 4])) +
+ real (high byte (boot block [entry (partition) + 4])) * 256.0.
+
+high word:
+ real (boot block [entry (partition) + 5]).
+
+END PROC partition start;
+
+INT PROC partition word 0 (INT CONST partition):
+ boot block (entry (partition))
+END PROC partition word 0;
+
+INT PROC first track (INT CONST partition):
+ high byte (boot block [entry (partition) + 1])
+ + 4 * (low byte (boot block [entry (partition) + 1]) AND (128 + 64))
+END PROC first track;
+
+INT PROC last track (INT CONST partition):
+ high byte (boot block [entry (partition) + 3])
+ + 4 * (low byte (boot block [entry (partition) + 3]) AND (128 + 64))
+END PROC last track;
+
+BOOL PROC partition activ (INT CONST partition):
+ low byte (boot block [entry (partition)]) = 128
+END PROC partition activ;
+
+REAL PROC partition size (INT CONST partition):
+ unsigned low word + high word.
+
+unsigned low word:
+ real (low byte (boot block [entry (partition) + 6])) +
+ real (high byte (boot block [entry (partition) + 6])) * 256.0.
+
+high word:
+ real (boot block [entry (partition) + 7]).
+
+END PROC partition size;
+
+INT PROC tracks:
+ get value (-10, fd channel)
+END PROC tracks;
+
+PROC activate (INT CONST part type):
+ IF partition type exists AND is possible type
+ THEN deactivate all partitions and
+ activate desired partition
+ ELSE errorstop ("Gewünschte Partitionart gibt es nicht")
+ FI.
+
+is possible type:
+ part type > 0 AND
+ part type < 256.
+
+partition type exists:
+ INT VAR partition;
+ FOR partition FROM 1 UPTO 4 REP
+ IF partition type (partition) = part type
+ THEN LEAVE partition type exists WITH TRUE
+ FI;
+ PER;
+ FALSE.
+
+deactivate all partitions and activate desired partition:
+ FOR partition FROM 1 UPTO 4 REP
+ deactivate this partition;
+ IF partition type (partition) = part type
+ THEN activate partition
+ FI
+ PER;
+ put boot block.
+
+deactivate this partition:
+ set bit (boot block [entry (partition)], 7);
+ (* first setting needed, because reset bit does xor *)
+ reset bit (boot block [entry (partition)], 7).
+
+activate partition:
+ set bit (boot block [entry (partition)], 7)
+
+END PROC activate;
+
+INT PROC entry (INT CONST partition):
+ get boot block;
+ 256 - 5 * 8 + (partition * 8)
+END PROC entry;
+
+INT PROC get value (INT CONST control code, channel for value):
+ enable stop;
+ INT VAR old channel := channel;
+ continue (channel for value);
+ INT VAR value;
+ control (control code, 0, 0, value);
+ continue (old channel);
+ value
+END PROC get value;
+
+PROC get external block (DATASPACE VAR ds, INT CONST ds page,
+ archive block, get channel):
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+END PROC get external block;
+
+PROC put external block (DATASPACE CONST ds, INT CONST ds page,
+ archive block, get channel):
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+END PROC put external block;
+
+(**************************************************************************)
+
+ LET max partitions = 4;
+ ROW max partitions INT VAR part list;
+ ROW max partitions INT VAR part type, part active,
+ part first track, part last track;
+ ROW max partitions REAL VAR part start,
+ part size;
+ INT VAR zylinder,
+ startzeile tabelle :: 1,
+ active partition,
+ partitions,
+ partition, i, j, help;
+
+
+PROC get actual partition data :
+ get boot block;
+ zylinder := tracks;
+ FOR i FROM 1 UPTO max partitions REP
+ part type (i) := partition type (i);
+ part first track (i) := first track (i);
+ part last track (i) := last track (i);
+ part start (i) := partition start (i);
+ part size (i) := partition size (i);
+ part active (i) := partition word 0 (i);
+ IF partition activ (i) THEN active partition := i FI
+ PER;
+ get number of installed partitions;
+ generate part list.
+
+get number of installed partitions :
+ partitions := 0;
+ FOR i FROM 1 UPTO max partitions REP
+ IF part type (i) <> 0 THEN partitions INCR 1 FI
+ PER.
+
+generate part list :
+ FOR i FROM 1 UPTO max partitions REP
+ IF part type (i) <> 0 THEN part list (i) := i
+ ELSE part list (i) := 0
+ FI;
+ PER;
+ schiebe nullen nach hinten;
+ sort part list.
+
+schiebe nullen nach hinten :
+ i := 1; INT VAR k := 0;
+ REP k INCR 1;
+ IF part list (i) = 0 THEN circle
+ ELSE i INCR 1
+ FI
+ UNTIL k = max partitions - 1 PER.
+
+circle :
+ FOR j FROM i UPTO max partitions - 1 REP
+ part list (j) := part list (j + 1)
+ PER;
+ part list (max partitions) := 0.
+
+sort part list :
+ FOR i FROM 2 UPTO partitions REP
+ FOR j FROM 1 UPTO i - 1 REP
+ IF part first track (part list (i)) < part first track (part list (j))
+ THEN tausche FI
+ PER
+ PER.
+
+tausche :
+ help := part list (i);
+ part list (i) := part list (j);
+ part list (j) := help.
+
+END PROC get actual partition data;
+
+
+PROC show partition table :
+ headline;
+ devide table;
+ columns;
+ underlines;
+ rows;
+ footlines.
+
+head line :
+ cl eop (1, startzeile tabelle);
+ put center (inverse (" "
+ + "Aktuelle Partitions - Tabelle"
+ + " ")).
+
+devide table :
+ FOR i FROM 1 UPTO 8
+ REP
+ cursor (50, startzeile tabelle + i); out (inverse (""))
+ PER.
+
+columns :
+ cursor ( 1, startzeile tabelle + 2);
+ out (" Nr. System Typ-Nr. Zustand Größe Start Ende");
+ cursor (54, startzeile tabelle + 2);
+ out ("Plattengröße / Zylinder ").
+
+underlines :
+ cursor ( 1, startzeile tabelle + 3);
+ out ("-------------------------------------------------");
+ cursor (52, startzeile tabelle + 3);
+ out ("--------------------------").
+
+rows :
+ FOR i FROM 1 UPTO max partitions
+ REP cursor (2, startzeile tabelle + 3 + i);
+ put (text (i) + " :")
+ PER.
+
+footlines:
+ cursor (1, startzeile tabelle + 9);
+ put center (inverse (75 * " ")).
+
+END PROC show partition table;
+
+PROC update table :
+ get actual partition data;
+ FOR i FROM 1 UPTO partitions REP update partition PER;
+ FOR i FROM partitions + 1 UPTO max partitions REP rubout partition PER;
+ zeige plattengroesse.
+
+update partition :
+ partition := part list (i);
+ show partition.
+
+rubout partition :
+ cursor (6, startzeile tabelle + 3 + i);
+ out (" ").
+
+show partition :
+ cursor (6, startzeile tabelle + 3 + i);
+ put (name + type + zustand + groesse + startspur + endspur).
+
+name : subtext (subtext (part name, 1, 9)
+ + " ", 1, 10).
+
+type : text (part type (partition), 5) + " ".
+
+zustand : IF active partition = partition THEN (" aktiv ")
+ ELSE (" ")
+ FI.
+
+startspur : " " + text (part first track (partition), 5).
+endspur : text (part last track (partition), 6).
+groesse : text (part groesse, 5).
+
+zeige plattengroesse :
+ put gesamt;
+ put noch freie;
+ put maximaler zwischenraum.
+
+put maximaler zwischenraum :
+ cursor (54, startzeile tabelle + 6);
+ put ("max. zusammenh. : " + text (maximaler zwischenraum, 4)).
+
+put gesamt :
+ cursor (54, startzeile tabelle + 4);
+ put ("insgesamt : " + text (zylinder, 4)).
+
+put noch freie :
+ cursor (54, startzeile tabelle + 5);
+ put ("davon noch frei : " + text (freie zylinder, 4)).
+
+part groesse :
+ partition groesse (partition).
+
+part name :
+ SELECT part type (partition) OF
+ CASE 1 : "DOS"
+ CASE 69, 70, 71, 72 : "EUMEL"
+ OTHERWISE text (part type (partition))
+ END SELECT.
+
+freie zylinder :
+ zylinder - belegte zylinder.
+
+belegte zylinder :
+ help := 0;
+ FOR i FROM 1 UPTO partitions REP
+ help INCR partition groesse (part list (i))
+ PER;
+ help.
+
+END PROC update table;
+
+INT PROC maximaler zwischenraum :
+ IF partitions = 0 THEN zylinder
+ ELSE max (maximaler platz vor und zwischen den partitionen,
+ platz hinter letzter partition)
+ FI.
+
+maximaler platz vor und zwischen den partitionen :
+ help := platz vor erster partition;
+ FOR i FROM 1 UPTO partitions - 1
+ REP
+ help := max (help, begin of part i plus 1 - end of part i - 1)
+ PER;
+ help.
+
+platz vor erster partition :
+ part first track (part list (1)).
+
+platz hinter letzter partition :
+ zylinder - part last track (part list (partitions)) - 1.
+
+begin of part i plus 1 :
+ part first track (part list (i + 1)).
+
+end of part i :
+ part last track (part list (i)).
+
+END PROC maximaler zwischenraum;
+
+INT PROC partition groesse (INT CONST part) :
+ part last track (part) - part first track (part) + 1
+END PROC partition groesse;
+
+PROC show actual partition table:
+ show partition table;
+ update table;
+ line (4)
+END PROC show actual partition table;
+
+PROC show actual partition table (ROW max partitions INT VAR typnr):
+ show actual partition table;
+ FOR i FROM 1 UPTO max partitions REP
+ typnr (i) := partition type (part list (i))
+ PER;
+END PROC show actual partition table;
+
+END PACKET part;
+
+
+PACKET hw clock DEFINES hw clock: (* Copyright (C) 1985 *)
+ (* Martin Schönbeck, Spenge *)
+LET clock length = 7, (* Stand: 06.11.85 *)
+ clock command = 4;
+
+BOUND STRUCT (ALIGN dummy,
+ ROW clock length INT clock field) VAR clock data;
+
+REAL PROC hw clock:
+
+ disable stop;
+ get clock;
+ hw date + hw time.
+
+get clock:
+ DATASPACE VAR ds := nilspace;
+ clock data := ds;
+ INT VAR return code, actual channel := channel;
+ go to shard channel;
+ blockin (ds, 2, -clock command, 0, return code);
+ IF actual channel = 0 THEN break (quiet)
+ ELSE continue (actual channel)
+ FI;
+ IF return code <> 0
+ THEN errorstop ("Keine Hardware Uhr vorhanden");
+ FI;
+ put clock into text;
+ forget (ds).
+
+put clock into text:
+ TEXT VAR clock text := clock length * " ";
+ INT VAR i;
+ FOR i FROM 1 UPTO clock length REP
+ replace (clock text, i, clock data. clock field [i]);
+ PER.
+
+go to shard channel:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 20 REP
+ continue (32);
+ IF is error
+ THEN clear error;
+ pause (30)
+ FI;
+ UNTIL channel = 32 PER.
+
+hw date:
+ date (day + "." + month + "." + year).
+
+day: subtext (clock text, 7, 8).
+
+month: subtext (clock text, 5, 6).
+
+year: subtext (clock text, 1, 4).
+
+hw time:
+ time (hour + ":" + minute + ":" + second).
+
+hour: subtext (clock text, 9, 10).
+
+minute: subtext (clock text, 11, 12).
+
+second: subtext (clock text, 13, 14).
+
+END PROC hw clock;
+
+END PACKET hw clock
+
+
+PACKET old shutup DEFINES old shutup, (* Copyright (C) 1985 *)
+ old save system: (* Martin Schönbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC old shutup : shutup END PROC old shutup;
+
+PROC old save system : save system END PROC old save system;
+
+END PACKET old shutup;
+
+
+PACKET new shutup DEFINES shutup,
+ shutup dialog,
+ save system,
+ generate shutup manager,
+ generate shutup dialog manager:
+
+LET ack = 0;
+
+PROC shutup:
+
+ system down (PROC old shutup)
+
+END PROC shutup;
+
+PROC shutup (INT CONST new system):
+
+ IF new system <> 0
+ THEN prepare for new system
+ FI;
+ system down (PROC old shutup).
+
+prepare for new system:
+ activate (new system);
+ prepare for rebooting.
+
+prepare for rebooting:
+ INT VAR old channel := channel;
+ continue (32);
+ INT VAR dummy;
+ control (-5, 0, 0, dummy);
+ break (quiet);
+ continue (old channel).
+
+END PROC shutup;
+
+PROC save system:
+
+ IF yes ("Leere Floppy eingelegt")
+ THEN system down (PROC old save system)
+ FI
+
+END PROC save system;
+
+PROC system down (PROC operation):
+
+ BOOL VAR dialogue :: command dialogue;
+ command dialogue (FALSE);
+ operation;
+ command dialogue (dialogue);
+ IF command dialogue
+ THEN wait for configurator;
+ show date;
+ FI.
+
+show date:
+ page;
+ line (2);
+ put (" Heute ist der"); putline (date);
+ put (" Es ist"); put (time of day); putline ("Uhr");
+ line (2).
+
+END PROC system down;
+
+DATASPACE VAR ds := nilspace;
+
+PROC wait for configurator:
+
+ INT VAR i, receipt;
+ FOR i FROM 1 UPTO 20 WHILE configurator exists REP
+ pause (30);
+ forget (ds);
+ ds := nilspace;
+ ping pong (configurator, ack, ds, receipt)
+ UNTIL receipt >= 0 PER.
+
+configurator exists:
+ disable stop;
+ TASK VAR configurator := task ("configurator");
+ clear error;
+ NOT is niltask (configurator).
+
+END PROC wait for configurator;
+
+PROC generate shutup manager:
+
+ generate shutup manager ("shutup", 0);
+
+END PROC generate shutup manager;
+
+PROC generate shutup manager (TEXT CONST name, INT CONST new system):
+
+ TASK VAR son;
+ shutup question := name;
+ new system for manager := new system;
+ begin (name, PROC shutup manager, son)
+
+END PROC generate shutup manager;
+
+INT VAR new system for manager;
+TEXT VAR shutup question;
+
+PROC shutup manager:
+
+ disable stop;
+ command dialogue (TRUE);
+ REP
+ break;
+ line ;
+ IF yes (shutup question)
+ THEN clear error;
+ shutup (new system for manager);
+ pause (300);
+ FI;
+ PER
+
+END PROC shutup manager;
+
+PROC shutup dialog:
+ init;
+ show actual partition table (typnr);
+ REP
+ enter part number;
+ get cursor (cx, cy);
+ IF NOT escaped CAND yes (shutup question)
+ THEN message;
+ shutup (partition type);
+ LEAVE shutup dialog
+ FI;
+ PER.
+
+shutup question:
+ IF partition null
+ THEN "Shutup ausführen"
+ ELSE "Shutup nach Partition mit Typnummer " + text (typnr (partition)) + " ausführen"
+ FI.
+
+message:
+ cl eol (1, cy);
+ put line ("Bitte auf ENDE - Meldung warten !").
+
+partition type:
+ IF partition = 0
+ THEN 0
+ ELSE typnr (partition)
+ FI.
+
+init:
+ LET startzeile menu = 12,
+ escape = ""27"",
+ max partitions = 4;
+
+ ROW max partitions INT VAR typnr;
+ INT VAR partition, cx, cy;
+ TEXT VAR retchar.
+
+partition null:
+ partition = 0 COR typnr (partition) = 0.
+
+enter part number :
+ cl eop (1, startzeile menu);
+ cursor (54, startzeile menu ); put ("Abbruch mit <ESC>");
+ cursor (54, startzeile menu + 1); put ("Shutup ohne Wechsel mit <0>");
+ cursor ( 1, startzeile menu);
+ put ("Zu welcher Partition wollen Sie wechseln :");
+ get cursor (cx, cy);
+ REP
+ REP cursor (cx, cy);
+ partition := get choice (0, 4, retchar);
+ IF sure escaped THEN LEAVE shutup dialog FI;
+ UNTIL NOT escaped PER;
+ IF partition <> 0 CAND NOT partition exists
+ THEN fehler;
+ put ("Diese Partition gibt es nicht")
+ FI;
+ UNTIL partition = 0 OR partition exists PER;
+ cl eol (54, startzeile menu);
+ cl eol (54, startzeile menu + 1);
+ cl eop (1, cy + 2).
+
+partition exists:
+ typnr (partition) <> 0.
+
+escaped :
+ retchar = escape.
+
+sure escaped :
+ IF escaped THEN cl eop (1, 20); cursor (1, 22);
+ IF yes ("Shutup-Dialog abbrechen") THEN TRUE
+ ELSE cl eop (1, 20);
+ FALSE
+ FI
+ ELSE FALSE
+ FI.
+
+fehler :
+ cl eop (1, 20);
+ put (""7"" + inverse ("FEHLER :")); line (2).
+
+END PROC shutup dialog;
+
+PROC generate shutup dialog manager:
+ TASK VAR son;
+ begin ("shutup dialog", PROC shutup dialog manager, son)
+END PROC generate shutup dialog manager;
+
+PROC shutup dialog manager:
+ disable stop;
+ command dialogue (TRUE);
+ REP
+ break; line;
+ clear error;
+ INT VAR sess := session;
+ shutup dialog;
+ IF sess <> session THEN pause (300) FI;
+ PER;
+END PROC shutup dialog manager;
+
+END PACKET new shutup
+
+
+PACKET config manager with time DEFINES configuration manager ,
+ configuration manager with time :
+ (* Copyright (C) 1985 *)
+INT VAR old session := 0; (* Martin Schönbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC configuration manager:
+
+ configurate;
+ break;
+ global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time)
+
+END PROC configuration manager;
+
+PROC configuration manager with time (DATASPACE VAR ds, INT CONST order,
+ phase, TASK CONST order task):
+
+ IF old session <> session
+ THEN
+ disable stop;
+ set clock (hw clock);
+ set clock (hw clock); (* twice, to avoid all paging delay *)
+ IF is error THEN IF online THEN put error; clear error; pause (100)
+ ELSE clear error
+ FI FI;
+ old session := session;
+ set autonom;
+ FI;
+ configuration manager (ds, order, phase, order task);
+
+END PROC configuration manager with time;
+
+END PACKET config manager with time;
+
diff --git a/system/std.zusatz/1.8.7/src/AT install b/system/std.zusatz/1.8.7/src/AT install
new file mode 100644
index 0000000..11f9b55
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/AT install
@@ -0,0 +1,93 @@
+(*************************************************************************)
+(*** Insertiert alle notwendigen Pakete, damit ein AT-System generiert ***)
+(*** werden kann, das die Hardwareuhr lesen und Partitionen bedienen ***)
+(*** kann. Startet den "AT Generator". ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+erste bildschirmmeldung;
+IF ich bin single THEN putline ("Die AT-spezifische Software ist nur auf Multi-User-Systemen benutzbar !")
+ ELSE hole dateien vom archiv;
+ insertiere alle pakete;
+ put line ("Running ""AT Generator""...");
+ run ("AT Generator")
+FI;
+forget ("AT install", quiet).
+
+ich bin single : (pcb (9) AND 255) <= 1.
+
+insertiere alle pakete :
+ insert and say ("AT Utilities").
+
+erste bildschirmmeldung :
+ page;
+ put center (" Generator für AT-spezifische Software gestartet."); line;
+ put center ("--------------------------------------------------");
+ line (2).
+
+hole dateien vom archiv :
+ TEXT VAR datei;
+ datei := "AT Utilities"; hole wenn noetig;
+ datei := "AT Generator"; hole wenn noetig;
+ release (archive);
+ line.
+
+hole wenn noetig :
+ IF NOT exists (datei) THEN
+ put line ("Loading """ + datei + """...");
+ fetch (datei, archive)
+ FI.
+
+PROC insert and say (TEXT CONST datei) :
+
+ INT VAR cx, cy;
+ put line ("Inserting """ + datei + """...");
+ get cursor (cx, cy);
+ insert (datei);
+ cl eop (cx, cy); line;
+ forget (datei, quiet).
+
+END PROC insert and say;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
diff --git a/system/std.zusatz/1.8.7/src/complex b/system/std.zusatz/1.8.7/src/complex
new file mode 100644
index 0000000..e2139d0
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/complex
@@ -0,0 +1,115 @@
+
+PACKET complex DEFINES COMPLEX,:=,complex zero,complex one,complex i,
+ complex,realpart,imagpart,CONJ,+,-,*,/,=,<>,
+ put,get, ABS, sqrt, phi, dphi :
+
+TYPE COMPLEX = STRUCT(REAL re,im);
+COMPLEX PROC complex zero: COMPLEX :(0.0,0.0). END PROC complex zero;
+COMPLEX PROC complex one : COMPLEX :(1.0,0.0). END PROC complex one;
+COMPLEX PROC complex i : COMPLEX :(0.0,1.0). END PROC complex i;
+
+OP := (COMPLEX VAR dest, COMPLEX CONST source) :
+
+ CONCR (dest) := CONCR (source)
+
+ENDOP := ;
+
+COMPLEX PROC complex(REAL CONST re,im):
+ COMPLEX :(re,im).
+END PROC complex;
+
+REAL PROC realpart(COMPLEX CONST number):
+ number.re.
+END PROC realpart;
+
+REAL PROC imagpart(COMPLEX CONST number):
+ number.im.
+END PROC imagpart ;
+
+COMPLEX OP CONJ(COMPLEX CONST number):
+ COMPLEX :( number.re,- number.im).
+END OP CONJ;
+
+BOOL OP =(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im=b.im
+ ELSE FALSE
+ FI.
+END OP =;
+
+BOOL OP <>(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im<>b.im
+ ELSE TRUE
+ FI.
+END OP <>;
+
+COMPLEX OP +(COMPLEX CONST a,b):
+ COMPLEX :(a.re+b.re,a.im+b.im).
+END OP +;
+
+COMPLEX OP -(COMPLEX CONST a,b):
+ COMPLEX :(a.re-b.re,a.im-b.im).
+END OP -;
+
+COMPLEX OP *(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a ::a.im,
+ re of b::b.re,im of b ::b.im;
+ COMPLEX :(re of a*re of b- im of a *im of b,
+ re of a*im of b+ im of a*re of b).
+END OP *;
+
+COMPLEX OP /(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a::a.im,
+ re of b::b.re,im of b::b.im;
+ REAL VAR sqare sum of re and im ::b.re*b.re+b.im*b.im;
+ COMPLEX :( (re of a * re of b + im of a * im of b)/sqare sum of re and im,
+ (im of a *re of b - re of a*im of b)/sqare sum of re and im).
+END OP /;
+
+PROC get(COMPLEX VAR a):
+ REAL VAR realpart,imagpart;
+ get(realpart);get(imagpart);
+ a:= COMPLEX :(realpart,imagpart);
+END PROC get;
+
+PROC put(COMPLEX CONST a):
+ put(a.re);put(" ");put(a.im);
+END PROC put;
+
+REAL PROC dphi(COMPLEX CONST x):
+ IF imagpart(x)=0.0 THEN reell
+ ELIF realpart(x)=0.0 THEN imag
+ ELIF realpart(x)>0.0 THEN realpositiv
+ ELSE realnegativ
+ FI.
+reell: IF sign(realpart(x)) < 0 THEN 180.0 ELSE 0.0 FI.
+imag: IF imagpart(x)>0.0 THEN 90.0 ELSE 270.0 FI.
+realpositiv:IF imagpart(x)>0.0 THEN arctand(realpart(x)/imagpart(x))
+ ELSE
+arctand(realpart(x)/imagpart(x))+360.0 FI.
+realnegativ: arctand(realpart(x)/imagpart(x))+180.0.
+END PROC dphi;
+
+REAL PROC phi(COMPLEX CONST x):
+dphi(x)*3.141592653689793/180.0.
+END PROC phi;
+
+COMPLEX PROC sqrt(COMPLEX CONST x):
+IF x=complex zero THEN x
+ELIF realpart(x)<0.0 THEN
+complex(imagpart(x)/(2.0*real(sign(imagpart(x)))
+ *sqrt((ABSx-realpart(x))/2.0)),
+ real(sign(imagpart(x)))*sqrt((ABS x-realpart(x))/2.0))
+ELSE complex(sqrt((ABS x+realpart(x))/2.0),
+ imagpart(x)/(2.0*sqrt((ABS x+realpart(x))/2.0)))
+FI.
+
+END PROC sqrt;
+
+REAL OP ABS(COMPLEX CONST x):
+ sqrt(realpart(x)*realpart(x)+imagpart(x)*imagpart(x)).
+END OP ABS;
+
+END PACKET complex;
+
diff --git a/system/std.zusatz/1.8.7/src/crypt b/system/std.zusatz/1.8.7/src/crypt
new file mode 100644
index 0000000..b04728a
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/crypt
@@ -0,0 +1,138 @@
+(* ------------------- VERSION 2 vom 21.04.86 ------------------- *)
+PACKET cryptograf DEFINES (* Autor: J.Liedtke *)
+
+ crypt ,
+ decrypt :
+
+TEXT VAR char , in buffer, out buffer ;
+INT VAR in pos , key index ;
+DATASPACE VAR scratch space ;
+FILE VAR in, out;
+
+PROC crypt (TEXT CONST file, key) :
+
+ open (file) ;
+ initialize crypt (key) ;
+ WHILE NOT eof REP
+ read char ;
+ crypt char ;
+ write char
+ PER ;
+ close (file) .
+
+crypt char :
+ char := code (( character + random char + key char ) MOD 250) ;
+ IF key index = LENGTH key
+ THEN key index := 1
+ ELSE key index INCR 1
+ FI .
+
+character : code (char) .
+
+random char : random (0,250).
+
+key char : code (key SUB key index) .
+
+ENDPROC crypt ;
+
+PROC decrypt (TEXT CONST file, key) :
+
+ open (file) ;
+ initialize crypt (key) ;
+ WHILE NOT eof REP
+ read char ;
+ decrypt char ;
+ write char
+ PER ;
+ close (file) .
+
+decrypt char :
+ char := code (( character - random char - key char ) MOD 250) ;
+ IF key index = LENGTH key
+ THEN key index := 1
+ ELSE key index INCR 1
+ FI .
+
+character : code (char) .
+
+random char : random (0,250) .
+
+key char : code (key SUB key index) .
+
+ENDPROC decrypt ;
+
+PROC initialize crypt (TEXT CONST key) :
+
+ INT VAR random key := 0 ;
+ FOR key index FROM 1 UPTO LENGTH key REP
+ random key := (random key + code (key SUB key index)) MOD 32000
+ PER ;
+ initialize random (random key) ;
+ key index := 1
+
+ENDPROC initialize crypt ;
+
+PROC open (TEXT CONST source file) :
+
+ in := sequential file (input, source file) ;
+ getline (in, in buffer) ;
+ in pos := 1 ;
+ forget (scratch space) ;
+ scratch space := nilspace ;
+ out := sequential file (output, scratch space) ;
+ out buffer := "" .
+
+ENDPROC open ;
+
+PROC close (TEXT CONST source file) :
+
+ IF out buffer <> ""
+ THEN putline (out, out buffer)
+ FI ;
+ forget (source file, quiet) ;
+ copy (scratch space, source file) ;
+ forget (scratch space) .
+
+ENDPROC close ;
+
+BOOL PROC eof :
+
+ IF in pos > LENGTH in buffer
+ THEN eof (in)
+ ELSE FALSE
+ FI
+
+ENDPROC eof ;
+
+PROC read char :
+
+ IF in pos > 250
+ THEN getline (in, in buffer) ;
+ in pos := 1 ;
+ read char
+ ELIF in pos > LENGTH in buffer
+ THEN in pos := 1 ;
+ getline (in, in buffer) ;
+ char := ""13""
+ ELSE char := in buffer SUB in pos ;
+ in pos INCR 1
+ FI .
+
+ENDPROC read char ;
+
+PROC write char :
+
+ IF char = ""13""
+ THEN putline (out, out buffer) ;
+ out buffer := ""
+ ELSE out buffer CAT char
+ FI ;
+ IF LENGTH out buffer = 250
+ THEN putline (out, out buffer) ;
+ out buffer := ""
+ FI .
+
+ENDPROC write char ;
+
+ENDPACKET cryptograf ;
+
diff --git a/system/std.zusatz/1.8.7/src/eumel printer.5 b/system/std.zusatz/1.8.7/src/eumel printer.5
new file mode 100644
index 0000000..e61a073
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/eumel printer.5
@@ -0,0 +1,3473 @@
+PACKET eumel printer (* Autor : Rudolf Ruland *)
+ (* Version : 5 *)
+ (* Stand : 25.04.88 *)
+ DEFINES print,
+ with elan listings,
+ is elan source,
+ bottom label for elan listings,
+ x pos,
+ y pos,
+ y offset index,
+ line type,
+ material,
+ pages printed,
+
+(* >>> ***************************************************************** <<< *)
+(* >>> Aus Kompatibilitätsgründen zur Textverarbeitung der Version 1.8.0 <<< *)
+(* >>> siehe bei 'Berechnung des Zeilenvorschubs' <<< *)
+
+ old linefeed :
+
+BOOL VAR old linefeed calculation := TRUE;
+
+PROC old linefeed (BOOL CONST value) : old linefeed calculation := value END PROC old linefeed;
+
+BOOL PROC old linefeed : old linefeed calculation END PROC old linefeed;
+
+(* >>> ***************************************************************** <<< *)
+
+INT CONST int length := length of one int;
+
+. length of one int :
+ INT VAR int counter := 0, int value := max int;
+ REP int counter INCR 1;
+ int value := int value DIV 256;
+ UNTIL int value = 0 PER;
+ int counter
+.;
+
+(* >>> ***************************************************************** <<< *)
+
+LET std x wanted = 2.54,
+ std y wanted = 2.35,
+ std limit = 16.0,
+ std pagelength = 25.0,
+ std linefeed faktor = 1.0,
+ std material = "";
+
+LET blank = " ",
+ blank code 1 = 33,
+ geschuetztes blank = ""223"",
+ keine blankanalyse = 0,
+ einfach blank = 1,
+ doppel blank = 2,
+
+ anweisungszeichen = "#",
+ anweisungszeichen code 1 = 36,
+ geschuetztes anweisungszeichen = ""222"",
+ druckerkommando zeichen = "/",
+ quote = """",
+ kommentar zeichen = "-",
+
+ punkt = ".",
+
+ leer = 0,
+
+ kommando token = 0,
+ text token = 1,
+
+ underline linetype = 1,
+(* fraction linetype = 2,
+ root linetype = 3,
+*)
+ underline bit = 0,
+ bold bit = 1,
+ italics bit = 2,
+ modifikations liste = "ubir",
+ anzahl modifikationen = 4,
+
+ document = 1,
+ page = 2,
+
+ write text = 1,
+ write cmd = 2,
+ carriage return = 3,
+ move = 4,
+ draw = 5,
+ on = 6,
+ off = 7,
+ type = 8,
+
+ text code = 1,
+(* error code = 2, *)
+ token code = 3,
+
+ tag type = 1,
+ bold type = 2,
+ number type = 3,
+ text type = 4,
+ delimiter type = 6,
+ eof type = 7;
+
+
+INT CONST null ausgang := minint,
+ erweiterungs ausgang := maxint,
+ blank ausgang := maxint - 1,
+ anweisungs ausgang := maxint - 2,
+ d code ausgang := maxint - 3,
+ max breite := maxint - 4,
+
+ linien token := -1;
+
+ROW anzahl modifikationen INT CONST modifikations werte :=
+ ROW anzahl modifikationen INT : (1, 2, 4, 8);
+
+TEXT CONST anweisungsliste :=
+ "type:1.1on:2.1off:3.1center:4.0right:5.0u:6.0d:7.0e:8.0b:9.0" +
+ "fillchar:10.1mark:11.2markend:12.0" +
+ "ub:13.0ue:14.0fb:15.0fe:16.0" +
+ "block:20.0columns:21.2columnsend:22.0free:23.1limit:24.1linefeed:25.1" +
+ "material:26.1page:27.01pagelength:29.1start:30.2" +
+ "table:31.0tableend:32.0clearpos:33.01" +
+ "lpos:35.1rpos:36.1cpos:37.1dpos:38.2bpos:39.2" +
+ "textbegin:40.02textend:42.0" +
+ "indentation:43.1ytab:44.1";
+
+LET a type = 1, a block = 20,
+ a on = 2, a columns = 21,
+ a off = 3, a columnsend = 22,
+ a center = 4, a free = 23,
+ a right = 5, a limit = 24,
+ a up = 6, a linefeed = 25,
+ a down = 7, a material = 26,
+ a end up or down = 8, a page0 = 27,
+ a bsp = 9, a page1 = 28,
+ a fill char = 10, a pagelength = 29,
+ a mark = 11, a start = 30,
+ a markend = 12, a table = 31,
+ a ub = 13, a tableend = 32,
+ a ue = 14, a clearpos0 = 33,
+ a fb = 15, a clearpos1 = 34,
+ a fe = 16, a lpos = 35,
+ a rpos = 36,
+ a cpos = 37,
+ a dpos = 38,
+ a bpos = 39,
+ a textbegin0 = 40,
+ a textbegin2 = 41,
+ a textend = 42,
+ a indentation = 43,
+ a y tab = 44;
+
+INT VAR a xpos, a breite, a font, a modifikationen,
+ a modifikationen fuer x move, a ypos, aktuelle ypos,
+ letzter font, letzte modifikationen,
+ d ypos, d xpos, d font, d modifikationen,
+
+ zeilenpos, alte zeilenpos, zeilen laenge, anzahl zeichen, ausgang,
+ anzahl einrueck blanks, blankbreite, fuehrende anweisungen,
+ einrueckbreite, aktuelle einrueckbreite, alte einrueckbreite,
+ aktuelle zeilentiefe der letzten zeile,
+ blankmodus, alter blankmodus,
+ token zeiger, erstes token der zeile,
+
+ erstes tab token, tab anfang, anzahl blanks,
+ d code 1, d pitch, fuell zeichen breite, erstes fuell token,
+ letztes fuell token,
+
+ x size, y size, x wanted, y wanted, x start, y start,
+ pagelength, limit, indentation,
+ left margin, top margin, seitenlaenge,
+ papierlaenge, papierbreite,
+ luecke, anzahl spalten, aktuelle spalte,
+
+ verschiebung, linien verschiebung,
+ rest, neue modifikationen, modifikations modus, pass,
+
+ int param, anweisungs index, anzahl params,
+
+ gedruckte seiten;
+
+BOOL VAR zeile ist absatzzeile, letzte zeile war absatzzeile,
+ zeile muss geblockt werden, rechts, a block token, offsets,
+ tabellen modus, block modus, center modus, right modus,
+ seite ist offen, vor erster seite;
+
+REAL VAR linefeed faktor, real param;
+
+TEXT VAR zeile, anweisung, par1, par2, material wert, replacements,
+ fuell zeichen, d string, font offsets;
+
+ROW 256 INT VAR zeichenbreiten, replacement tabelle, zeichen zaehler;
+
+INITFLAG VAR in dieser task := FALSE;
+
+. zeile ist zu ende : zeilenpos > zeilen laenge
+
+. zeilen breite : a xpos - left margin
+
+. naechstes zeichen ist blank : pos (zeile, blank, zeilenpos + 1, zeilenpos + 1) <> 0
+
+. naechstes nicht blankes zeichen : pos (zeile, ""33"", ""255"", zeilenpos)
+
+. in letzter spalte : aktuelle spalte >= anzahl spalten
+
+. anfangs blankmodus :
+ INT VAR dummy;
+ IF center modus OR right modus
+ THEN dummy
+ ELIF index zaehler = 0
+ THEN blankmodus
+ ELSE alter blankmodus
+ FI
+
+. initialisiere tab variablen :
+ erstes tab token := token index f + 1;
+ tab anfang := zeilen breite;
+ anzahl blanks := 0;
+ a block token := FALSE;
+.;
+
+(******************************************************************)
+
+LET zeilen nr laenge = 4,
+ teil einrueckung = 5,
+
+ headline pre = "Zeile **** E L A N EUMEL 1.8.2 **** ",
+ headline post = " **** ";
+
+INT VAR zeilen nr, rest auf seite,
+ max zeichen zeile, max zeichen fuss, layout laenge, layout laenge name,
+ symbol type, naechster symbol type, select counter;
+
+BOOL VAR vor erstem packet, innerhalb einer liste;
+
+TEXT VAR bottom label, dateiname, layout blanks, refinement layout zeile;
+
+
+. symbol : fuell zeichen
+. naechstes symbol : d string
+. elan text : d token. text
+.;
+
+(******************************************************************)
+(*** Berechnung des Zeilenvorschubs ***)
+
+INT VAR fonthoehe, fonttiefe, fontdurchschuss,
+ groesste fonthoehe, groesste fonttiefe,
+ groesste analysatorhoehe, groesste analysatortiefe,
+ letzte zeilenhoehe, letzte zeilentiefe,
+ aktuelle zeilenhoehe, aktuelle zeilentiefe;
+REAL VAR real fontgroesse;
+
+. fontgroesse : fonthoehe + fonttiefe
+. groesste fontgroesse : groesste fonthoehe + groesste fonttiefe
+. letzte zeilengroesse : letzte zeilenhoehe + letzte zeilentiefe
+. aktuelle zeilengroesse : aktuelle zeilenhoehe + aktuelle zeilentiefe
+
+.
+ initialisiere zeilenvorschub :
+ aktuelle zeilenhoehe := letzte zeilenhoehe;
+ aktuelle zeilentiefe := letzte zeilentiefe;
+ groesste fonthoehe := fonthoehe;
+ groesste fonttiefe := fonttiefe;
+ groesste analysatorhoehe := 0;
+ groesste analysatortiefe := 0;
+
+.
+ ueberpruefe groesste fontgroesse :
+ IF old linefeed calculation
+ THEN
+(* >>> Maximumsbestimmung über Fontgröße ******************************* <<< *)
+ IF fontgroesse >= groesste fontgroesse
+ THEN groesste fonthoehe := fonthoehe;
+ groesste fonttiefe := fonttiefe;
+ FI;
+ ELSE
+(* >>> Maximumsbestimmung über Fonthöhe und Fonttiefe ****************** <<< *)
+ groesste fonthoehe := max (fonthoehe, groesste fonthoehe);
+ groesste fonttiefe := max (fonttiefe, groesste fonttiefe);
+ FI;
+
+.
+ berechne fontgroesse :
+ fonthoehe INCR (fontdurchschuss DIV 2 + fontdurchschuss MOD 2);
+ fonttiefe INCR fontdurchschuss DIV 2;
+ real fontgroesse := real (fontgroesse);
+
+.
+ berechne letzte zeilengroesse :
+ REAL CONST zeilengroesse := real fontgroesse * linefeed faktor;
+ letzte zeilenhoehe := int (real (fonthoehe) * zeilengroesse / real fontgroesse + 0.5);
+ letzte zeilentiefe := int (zeilengroesse + 0.5) - letzte zeilenhoehe;
+.;
+
+PROC berechne aktuelle zeilengroesse :
+
+ IF linefeed faktor >= 1.0
+ THEN aktuelle zeilenhoehe := max (groesste fonthoehe, letzte zeilenhoehe);
+ aktuelle zeilentiefe := max (groesste fonttiefe, letzte zeilentiefe);
+ ELSE
+ IF old linefeed calculation
+ THEN
+(* >>> Maximumsbestimmung über Fontgröße ******************************* <<< *)
+ IF letzte zeilengroesse >= aktuelle zeilengroesse
+ THEN aktuelle zeilenhoehe := letzte zeilenhoehe;
+ aktuelle zeilentiefe := letzte zeilentiefe;
+ FI;
+ ELSE
+(* >>> Maximumsbestimmung über Fonthöhe und Fonttiefe ****************** <<< *)
+ aktuelle zeilenhoehe := max (letzte zeilenhoehe, aktuelle zeilenhoehe);
+ aktuelle zeilentiefe := max (letzte zeilentiefe, aktuelle zeilentiefe);
+ FI;
+ FI;
+ aktuelle zeilenhoehe := max (groesste analysatorhoehe, aktuelle zeilenhoehe);
+ aktuelle zeilentiefe := max (groesste analysatortiefe, aktuelle zeilentiefe);
+
+END PROC berechne aktuelle zeilengroesse;
+
+(******************************************************************)
+(*** tokenspeicher ***)
+
+LET max number token = 3000,
+ max number ypos = 1000,
+
+ TOKEN = STRUCT (TEXT text,
+ INT xpos, breite, font, modifikationen,
+ modifikationen fuer x move,
+ offset index, naechster token index,
+ BOOL block token ),
+
+ YPOS = STRUCT (INT ypos, vorheriger ypos index, naechster ypos index,
+ erster token index, letzter token index ),
+
+ TOKENLISTE = STRUCT (ROW max number token TOKEN token liste,
+ ROW max number ypos YPOS ypos liste );
+
+DATASPACE VAR ds;
+
+BOUND TOKENLISTE VAR tokenspeicher;
+
+TOKEN VAR d token, offset token;
+
+INT VAR erster ypos index a, letzter ypos index a,
+ erster ypos index d, letzter ypos index d,
+ ypos index, ypos index f, ypos index a, ypos index d,
+ token index, token index f;
+
+. t : tokenspeicher. token liste (token index)
+. tf : tokenspeicher. token liste (token index f)
+
+. y : tokenspeicher. ypos liste (ypos index)
+. yf : tokenspeicher. ypos liste (ypos index f)
+. ya : tokenspeicher. ypos liste (ypos index a)
+. yd : tokenspeicher. ypos liste (ypos index d)
+
+. loesche druckspeicher :
+ erster ypos index d := 0;
+ ypos index f := 0;
+ token index f := 0;
+
+. druckspeicher ist nicht leer :
+ erster ypos index d <> 0
+
+. loesche analysespeicher :
+ erster ypos index a := 0;
+
+. analysespeicher ist nicht leer :
+ erster ypos index a <> 0
+.;
+
+(******************************************************************)
+(*** anweisungsspeicher ***)
+
+INT VAR anweisungszaehler;
+TEXT VAR anweisungs indizes, params1 zeiger, params2 zeiger;
+THESAURUS VAR params1, params2;
+
+PROC loesche anweisungsspeicher :
+
+ anweisungs zaehler := 0;
+ anweisungs indizes := "";
+ params1 zeiger := "";
+ params2 zeiger := "";
+ params1 := empty thesaurus;
+ params2 := empty thesaurus;
+
+END PROC loesche anweisungsspeicher;
+
+(******************************************************************)
+(*** indexspeicher ***)
+
+INT VAR index zaehler, hoechster index zaehler;
+TEXT VAR letzte index breite, xpos vor index, zeilenpos nach index, grosse fonts,
+ index verschiebung;
+
+PROC loesche indexspeicher :
+
+ index zaehler := 0;
+ hoechster index zaehler := 0;
+ letzte index breite := "";
+ xpos vor index := "";
+ zeilenpos nach index := "";
+ index verschiebung := "";
+ grosse fonts := "";
+
+END PROC loesche indexspeicher;
+
+
+PROC loesche hoehere index level :
+
+ IF hoechster index zaehler > index zaehler
+ THEN letzte index breite := subtext (letzte index breite, 1, int length * index zaehler);
+ xpos vor index := subtext (xpos vor index, 1, int length * index zaehler);
+ zeilenpos nach index := subtext (zeilenpos nach index, 1, int length * index zaehler);
+ index verschiebung := subtext (index verschiebung, int length * index zaehler);
+ grosse fonts := subtext (grosse fonts, 1, int length * index zaehler);
+ hoechster index zaehler := index zaehler;
+ FI;
+
+END PROC loesche hoehere index level;
+
+(******************************************************************)
+(*** tabellenspeicher ***)
+
+LET max tabs = 30,
+ TABELLENEINTRAG = STRUCT (INT tab typ, tab position, tab param);
+
+TEXT VAR tab liste, fill char;
+THESAURUS VAR d strings;
+ROW max tabs TABELLENEINTRAG VAR tabspeicher;
+
+INT VAR tab index;
+
+. tab typ : tab speicher (tab liste ISUB tab index). tab typ
+. tab position : tab speicher (tab liste ISUB tab index). tab position
+. tab param : tab speicher (tab liste ISUB tab index). tab param
+. anzahl tabs : LENGTH tab liste DIV int length
+.;
+
+PROC loesche tabellenspeicher :
+
+ fill char := " ";
+ tabliste := "";
+ d strings := empty thesaurus;
+ FOR tab index FROM 1 UPTO max tabs
+ REP tab speicher (tab index). tab typ := leer PER;
+
+END PROC loesche tabellenspeicher;
+
+(******************************************************************)
+(*** markierungsspeicher ***)
+
+INT VAR mark index l, mark index r, alter mark index l, alter mark index r;
+
+ROW 4 TOKEN VAR mark token;
+
+. markierung links : mark index l > 0
+. markierung rechts : mark index r > 0
+.;
+
+PROC loesche markierung :
+
+ mark index l := 0;
+ mark index r := 0;
+
+END PROC loesche markierung;
+
+
+PROC loesche alte markierung :
+
+ alter mark index l := 0;
+ alter mark index r := 0;
+
+END PROC loesche alte markierung;
+
+
+PROC initialisiere markierung :
+
+ FOR mark index l FROM 1 UPTO 4
+ REP mark token (mark index l). modifikationen fuer x move := 0;
+ mark token (mark index l). offset index := text token;
+ mark token (mark index l). block token := FALSE;
+ mark token (mark index l). naechster token index := 0;
+ PER;
+
+END PROC initialisiere markierung;
+
+(******************************************************************)
+(*** durchschuss ***)
+
+INT VAR durchschuss 1, durchschuss 2, anzahl durchschuss 1,
+ anzahl durchschuss, zeilen zaehler;
+
+BOOL VAR wechsel := TRUE;
+
+INT PROC durchschuss :
+
+ zeilen zaehler INCR 1;
+ IF zeilen zaehler <= anzahl durchschuss 1
+ THEN durchschuss 1
+ ELIF zeilen zaehler <= anzahl durchschuss
+ THEN durchschuss 2
+ ELSE 0
+ FI
+
+END PROC durchschuss;
+
+
+PROC neuer durchschuss (INT CONST anzahl, rest l) :
+
+ zeilen zaehler := 0;
+ anzahl durchschuss := anzahl;
+ IF anzahl > 0
+ THEN IF wechsel
+ THEN durchschuss 1 := rest l DIV anzahl durchschuss;
+ durchschuss 2 := durchschuss 1 + sign (rest l);
+ anzahl durchschuss 1 := anzahl durchschuss -
+ abs (rest l) MOD anzahl durchschuss;
+ wechsel := FALSE;
+ ELSE durchschuss 2 := rest l DIV anzahl durchschuss;
+ durchschuss 1 := durchschuss 2 + sign (rest l);
+ anzahl durchschuss 1 := abs (rest l) MOD anzahl durchschuss;
+ wechsel := TRUE;
+ FI;
+ ELSE loesche durchschuss
+ FI;
+
+END PROC neuer durchschuss;
+
+
+PROC loesche durchschuss :
+
+ durchschuss 1 := 0;
+ durchschuss 2 := 0;
+ anzahl durchschuss 1 := 0;
+ anzahl durchschuss := 0;
+ zeilen zaehler := 0;
+
+END PROC loesche durchschuss;
+
+(****************************************************************)
+
+PROC initialisierung :
+
+ INT VAR index;
+ forget (ds);
+ ds := nilspace; tokenspeicher := ds;
+ loesche druckspeicher;
+ loesche anweisungsspeicher;
+ loesche indexspeicher;
+ initialisiere markierung;
+ right modus := FALSE;
+ center modus := FALSE;
+ seite ist offen := FALSE;
+ pass := 0;
+ a breite := 0;
+ a modifikationen fuer x move := 0;
+ aktuelle zeilentiefe der letzten zeile := 0;
+ d code 1 := leer;
+ erstes fuell token := leer;
+ IF two bytes
+ THEN FOR index FROM 1 UPTO 129 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 130 UPTO 160 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 161 UPTO 224 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 225 UPTO 240 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 241 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ ELSE FOR index FROM 1 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ FI;
+
+END PROC initialisierung;
+
+(****************************************************************)
+(*** print - Kommando ***)
+
+BOOL VAR elan listings erlaubt;
+FILE VAR eingabe;
+THESAURUS VAR elan bolds := empty thesaurus;
+
+insert (elan bolds, "PACKET"); insert (elan bolds, "PROC");
+insert (elan bolds, "PROCEDURE"); insert (elan bolds, "OP");
+insert (elan bolds, "OPERATOR"); insert (elan bolds, "LET");
+insert (elan bolds, "ROW"); insert (elan bolds, "STRUCT");
+insert (elan bolds, "TYPE"); insert (elan bolds, "BOUND");
+insert (elan bolds, "IF"); insert (elan bolds, "REP");
+insert (elan bolds, "REPEAT"); insert (elan bolds, "FOR");
+insert (elan bolds, "WHILE"); insert (elan bolds, "SELECT");
+
+with elan listings (TRUE);
+
+PROC with elan listings (BOOL CONST flag) :
+ elan listings erlaubt := flag;
+END PROC with elan listings;
+
+BOOL PROC with elan listings : elan listings erlaubt END PROC with elan listings;
+
+
+PROC print (FILE VAR file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ eingabe := file;
+ input (eingabe);
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC is eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) std analysator,
+ elan listings erlaubt CAND is elan source (eingabe),
+ headline (eingabe) );
+
+END PROC print;
+
+
+PROC print (FILE VAR file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator ) :
+
+ eingabe := file;
+ input (eingabe);
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC is eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ elan listings erlaubt CAND is elan source (eingabe),
+ headline (eingabe) );
+
+END PROC print;
+
+PROC lese zeile (TEXT VAR zeile l) : getline (eingabe, zeile l) END PROC lese zeile;
+
+BOOL PROC is eof : eof (eingabe) END PROC is eof;
+
+
+BOOL PROC is elan source (FILE VAR eingabe l) :
+
+hole erstes symbol;
+elan programm tag COR elan programm bold COR kommentar COR elanlist anweisung
+
+. elan programm tag :
+ symbol type = tag type CAND pos (zeile, ";") > 0
+
+. elan programm bold :
+ symbol type = bold type CAND is elan bold
+
+ . is elan bold :
+ (elan bolds CONTAINS symbol) COR deklaration COR proc oder op (naechstes symbol)
+
+ . deklaration :
+ next symbol (naechstes symbol);
+ naechstes symbol = "VAR" OR naechstes symbol = "CONST"
+
+. kommentar :
+ pos (zeile, "(*") > 0 OR pos (zeile, "{") > 0
+
+. elanlist anweisung :
+ symbol = "#" AND elanlist folgt
+
+ . elanlist folgt :
+ next symbol (naechstes symbol);
+ naechstes symbol = "elanlist"
+
+.
+ hole erstes symbol :
+ hole erstes nicht blankes symbol;
+ scan (zeile);
+ next symbol (symbol, symbol type);
+
+ . hole erstes nicht blankes symbol :
+ IF eof (eingabe l) THEN LEAVE is elan source WITH FALSE FI;
+ REP getline (eingabe l, zeile);
+ UNTIL pos (zeile, ""33"",""254"", 1) > 0 OR eof (eingabe l) PER;
+ reset (eingabe l);
+
+END PROC is elan source;
+
+(****************************************************************)
+
+bottom label for elan listings ("");
+
+PROC bottom label for elan listings (TEXT CONST label) :
+ bottom label := label;
+END PROC bottom label for elan listings;
+
+TEXT PROC bottom label for elan listings : bottom label END PROC bottom label for elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ BOOL CONST elan listing, TEXT CONST file name) :
+
+disable stop;
+gedruckte seiten := 0;
+drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ elan listing, file name );
+IF is error THEN behandle fehlermeldung FI;
+
+. behandle fehlermeldung :
+ TEXT CONST fehler meldung := error message;
+ INT CONST fehler zeile := error line,
+ fehler code := error code;
+ clear error;
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ clear error;
+ close (document, 0);
+ clear error;
+ FI;
+ initialisierung;
+ errorstop (fehler code, fehler meldung (* + " -> " + text (fehler zeile) *) );
+
+END PROC print;
+
+d xpos := 0;
+d ypos := 0;
+d token. offset index := 1;
+material wert := "";
+gedruckte seiten := 0;
+
+INT PROC x pos : d xpos END PROC x pos;
+INT PROC y pos : d ypos END PROC y pos;
+INT PROC y offset index : d token. offset index END PROC y offset index;
+INT PROC linetype : - d token. offset index END PROC linetype;
+TEXT PROC material : material wert END PROC material;
+INT PROC pages printed : gedruckte seiten END PROC pages printed;
+
+(****************************************************************)
+
+PROC drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator,
+ BOOL CONST elan listing, TEXT CONST file name ) :
+
+
+enable stop;
+IF elan listing
+ THEN dateiname := file name;
+ drucke elan listing;
+ ELSE drucke text datei;
+FI;
+
+.
+ drucke text datei :
+ initialisiere druck;
+ WHILE NOT eof
+ REP next line (zeile);
+ analysiere zeile (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ drucke token soweit wie moeglich;
+ werte anweisungsspeicher aus;
+ PER;
+ schliesse druck ab;
+
+.
+ initialisiere druck :
+ IF NOT initialized (in dieser task)
+ THEN ds := nilspace;
+ initialisierung
+ FI;
+ vor erster seite := TRUE;
+ tabellen modus := FALSE;
+ block modus := FALSE;
+ zeile ist absatzzeile := TRUE;
+ x wanted := x step conversion (std x wanted);
+ y wanted := y step conversion (std y wanted);
+ limit := x step conversion (std limit);
+ pagelength := y step conversion (std pagelength);
+ linefeed faktor := std linefeed faktor;
+ material wert := std material;
+ indentation := 0;
+ modifikations modus := maxint;
+ seitenlaenge := maxint;
+ papierlaenge := maxint;
+ left margin := 0;
+ top margin := 0;
+ a ypos := top margin;
+ a font := -1;
+ a modifikationen := 0;
+ aktuelle spalte := 1;
+ anzahl spalten := 1;
+ stelle neuen font ein (1);
+ loesche tabellenspeicher;
+ loesche markierung;
+ loesche alte markierung;
+ loesche durchschuss;
+
+.
+ schliesse druck ab :
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ close (document, 0);
+ FI;
+
+.
+ drucke token soweit wie moeglich :
+ IF analysespeicher ist nicht leer
+ THEN letztes token bei gleicher ypos;
+ IF NOT seite ist offen
+ THEN eroeffne seite (x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ FI;
+ IF seitenlaenge ueberschritten OR papierlaenge ueberschritten
+ THEN neue seite oder spalte;
+ analysiere zeile nochmal;
+ ELSE sortiere neue token ein;
+ IF in letzter spalte
+ THEN drucke tokenspeicher (a ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ FI;
+ FI;
+
+ . seitenlaenge ueberschritten :
+ a ypos + aktuelle zeilentiefe > seitenlaenge
+
+ . papierlaenge ueberschritten :
+ a ypos + aktuelle zeilentiefe > papierlaenge
+
+ . neue seite oder spalte :
+ IF in letzter spalte
+ THEN INT CONST aktuelles y wanted := y wanted bei seitenwechel ohne page;
+ schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ eroeffne seite (x wanted, aktuelles y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ ELSE neue spalte;
+ FI;
+
+ . y wanted bei seitenwechel ohne page :
+ IF seitenlaenge ueberschritten
+ THEN y wanted
+ ELSE 0
+ FI
+
+ . analysiere zeile nochmal :
+ setze auf alte werte zurueck;
+ loesche anweisungsspeicher;
+ analysiere zeile (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ letztes token bei gleicher ypos;
+ sortiere neue token ein;
+
+ . setze auf alte werte zurueck :
+ zeile ist absatzzeile := letzte zeile war absatzzeile;
+ a modifikationen := letzte modifikationen;
+ stelle neuen font ein (letzter font);
+
+.
+ werte anweisungsspeicher aus :
+ INT VAR index;
+ FOR index FROM 1 UPTO anweisungszaehler
+ REP
+ SELECT anweisungs indizes ISUB index OF
+ CASE a block : block anweisung
+ CASE a columns : columns anweisung
+ CASE a columnsend : columnsend anweisung
+ CASE a free : free anweisung
+ CASE a limit : limit anweisung
+ CASE a linefeed : linefeed anweisung
+ CASE a material : material anweisung
+ CASE a page0, a page1 : page anweisung
+ CASE a pagelength : pagelength anweisung
+ CASE a start : start anweisung
+ CASE a table : table anweisung
+ CASE a tableend : tableend anweisung
+ CASE a clearpos0 : clearpos0 anweisung
+ CASE a clearpos1 : clearpos1 anweisung
+ CASE a lpos, a rpos, a cpos, a dpos
+ : lpos rpos cpos dpos anweisung
+ CASE a bpos : bpos anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a textbegin0 : textbegin0 anweisung
+ CASE a textbegin2 : textbegin2 anweisung
+ CASE a textend : textend anweisung
+ CASE a indentation : indentation anweisung
+ CASE a y tab : y tab anweisung
+ END SELECT
+ PER;
+ loesche anweisungsspeicher;
+
+ . block anweisung :
+ blockmodus := TRUE;
+
+ . columns anweisung :
+ IF anzahl spalten = 1 AND int conversion ok (param1)
+ AND real conversion ok (param2)
+ THEN anzahl spalten := max (1, int param);
+ luecke := x step conversion (real param);
+ FI;
+
+ . columnsend anweisung :
+ anzahl spalten := 1;
+ aktuelle spalte := 1;
+ left margin := x wanted - x start + indentation;
+
+ . free anweisung :
+ IF real conversion ok (param1) THEN a ypos INCR y step conversion (real param) FI;
+
+ . limit anweisung :
+ IF real conversion ok (param1) THEN limit := x step conversion (real param) FI;
+
+ . linefeed anweisung :
+ IF real conversion ok (param1)
+ THEN linefeed faktor := real param;
+ berechne letzte zeilengroesse;
+ FI;
+
+ . material anweisung :
+ material wert := param1;
+
+ . page anweisung :
+ IF seite ist offen
+ THEN IF NOT in letzter spalte
+ THEN neue spalte
+ ELSE schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ papier laenge := maxint;
+ FI;
+ ELSE a ypos := top margin;
+ papier laenge := maxint;
+ FI;
+
+ . pagelength anweisung :
+ IF real conversion ok (param1)
+ THEN pagelength := y step conversion (real param);
+ FI;
+
+ . start anweisung :
+ IF real conversion ok (param1) THEN x wanted := x step conversion (real param) FI;
+ IF real conversion ok (param2) THEN y wanted := y step conversion (real param) FI;
+
+ . table anweisung :
+ tabellenmodus := TRUE;
+
+ . tableend anweisung :
+ tabellenmodus := FALSE;
+
+ . clearpos0 anweisung :
+ loesche tabellenspeicher;
+
+ . clearpos1 anweisung :
+ IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = int param
+ THEN tab typ := leer;
+ delete int (tab liste, tab index);
+ LEAVE clearpos1 anweisung;
+ FI;
+ PER;
+ FI;
+
+ . lpos rpos cpos dpos anweisung :
+ IF real conversion ok (param1)
+ THEN neuer tab eintrag (anweisungs indizes ISUB index, param2) FI;
+
+ . bpos anweisung :
+ IF real conversion ok (param2) CAND real conversion ok (param1)
+ CAND real (param2) > real param
+ THEN neuer tab eintrag (a bpos, param2) FI;
+
+ . fillchar anweisung :
+ fill char := param1;
+
+ . textbegin0 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+
+ . textbegin2 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+ neuer durchschuss (int (param1), y step conversion (real (param 2)));
+
+ . textend anweisung :
+ alte einrueckbreite := aktuelle einrueckbreite;
+ alter mark index l := mark index l;
+ alter mark index r := mark index r;
+ loesche markierung;
+ loesche durchschuss;
+
+ . indentation anweisung :
+(**) IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ left margin INCR (int param - indentation);
+ indentation := int param;
+ FI;
+(**)
+ . y tab anweisung :
+(**) IF real conversion ok (param1)
+ THEN int param := y step conversion (real param);
+ IF int param <= seitenlaenge THEN a ypos := int param FI;
+ FI;
+(**)
+ . param1 :
+ IF (params1 zeiger ISUB index) <> 0
+ THEN name (params1, params1 zeiger ISUB index)
+ ELSE ""
+ FI
+
+ . param2 :
+ IF (params2 zeiger ISUB index) <> 0
+ THEN name (params2, params2 zeiger ISUB index)
+ ELSE ""
+ FI
+
+
+.
+ drucke elan listing :
+ initialisiere elan listing;
+ WHILE NOT eof
+ REP next line (zeile);
+ zeilen nr INCR 1;
+ drucke elan zeile;
+ PER;
+ schliesse elan listing ab;
+
+.
+ initialisiere elan listing :
+ open document cmd;
+ hole elan list font;
+ initialisiere variablen;
+ elan fuss und kopf (1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . open document cmd :
+ material wert := "";
+ d token. offset index := 1;
+ erster ypos index d := 0;
+ vor erster seite := FALSE;
+ seite ist offen := TRUE;
+ open (document, x size, y size);
+ vor erster seite := FALSE;
+
+ . hole elan list font :
+ d font := max (1, font ("elanlist"));
+ get replacements (d font, replacements, replacement tabelle);
+ einrueckbreite := indentation pitch (d font) ;
+ font hoehe := font lead (d font) + font height (d font) + font depth (d font);
+
+ . initialisiere variablen :
+ innerhalb einer liste := FALSE;
+ vor erstem packet := TRUE;
+ zeilen nr := 0;
+ select counter := 0;
+ y wanted := y size DIV 23;
+ pagelength := y size - y wanted - y wanted;
+ x wanted := (min (x size DIV 10, x step conversion (2.54))
+ DIV einrueckbreite) * einrueckbreite;
+ max zeichen zeile := (x size - x wanted - (x wanted DIV 3)) DIV einrueckbreite;
+ max zeichen fuss := fusszeilenbreite;
+ layout laenge := min (38, max zeichen zeile DIV 3);
+ layout laenge name := layout laenge - zeilen nr laenge - 8;
+ layout blanks := (layout laenge - zeilen nr laenge - 1) * " ";
+ refinement layout zeile := (layout laenge - 1) * " " ;
+ refinement layout zeile CAT "|" ;
+ IF pagelength DIV fonthoehe - 6 < 35 OR max zeichen zeile < 65
+ THEN errorstop ("Schreibfeld fuer 'elan listing' zu klein") FI;
+
+ . fusszeilenbreite :
+ INT CONST dina 4 breite := x step conversion (21.0);
+ IF x size <= dina 4 breite
+ THEN (x size - 2 * x wanted) DIV einrueckbreite
+ ELIF 120 * einrueckbreite <= dina 4 breite - 2 * x wanted
+ THEN (dina 4 breite - 2 * x wanted) DIV einrueckbreite
+ ELSE min (120, (x size - 2 * x wanted) DIV einrueckbreite)
+ FI
+
+.
+ schliesse elan listing ab :
+ elan fuss und kopf (-1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ close (document, 0);
+
+.
+ drucke elan zeile :
+ IF pos (zeile, "#page#") = 1
+ THEN IF nicht am seiten anfang THEN seiten wechsel FI;
+ ELIF pos (zeile, "#elanlist#") <> 1
+ THEN bestimme elan layout;
+ bestimme elan zeile;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ seitenwechsel wenn noetig;
+ FI;
+
+ . nicht am seitenanfang :
+ rest auf seite < pagelength - 3 * font hoehe
+
+ . seiten wechsel :
+ elan fuss und kopf (0,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+.
+ bestimme elan layout :
+ IF innerhalb einer liste
+ THEN leeres layout;
+ pruefe ende der liste
+ ELIF pos (zeile, "P") <> 0 COR pos (zeile, ":") <> 0
+ THEN analysiere elan zeile
+ ELIF innerhalb einer select kette
+ THEN leeres layout;
+ pruefe ende der select kette
+ ELIF pos (zeile, "SELECT") <> 0
+ THEN analysiere select kette
+ ELSE leeres layout
+ FI;
+ elan text CAT "|";
+
+ . leeres layout :
+ elan text := text (zeilen nr, zeilen nr laenge);
+ elan text CAT layout blanks;
+
+ . analysiere elan zeile :
+ scan (zeile);
+ next symbol (symbol, symbol type);
+ next symbol (naechstes symbol, naechster symbol type);
+ IF packet anfang
+ THEN packet layout
+ ELIF type anfang
+ THEN type layout
+ ELIF proc op anfang
+ THEN proc op layout
+ ELSE IF innerhalb einer select kette
+ THEN pruefe ende der select kette;
+ leeres layout
+ ELIF refinement anfang
+ THEN refinement layout
+ ELSE leeres layout
+ FI;
+ FI;
+
+
+ . packet anfang :
+ symbol = "PACKET"
+
+ . type anfang :
+ symbol = "TYPE"
+
+ . proc op anfang :
+ IF proc oder op (symbol)
+ THEN naechster symbol type <> delimiter type
+ ELIF (symbol <> "END") AND proc oder op (naechstes symbol)
+ THEN symbol := naechstes symbol;
+ next symbol (naechstes symbol, naechster symbol type);
+ naechster symbol type <> delimiter type
+ ELSE FALSE
+ FI
+
+ . refinement anfang :
+ symbol type = tag type AND naechstes symbol = ":"
+
+ . packet layout :
+ IF nicht am seiten anfang AND
+ (NOT vor erstem packet OR gedruckte seiten > 1)
+ THEN seiten wechsel
+ FI;
+ layout (" ", naechstes symbol, "*") ;
+ vor erstem packet := FALSE;
+ select counter := 0;
+ innerhalb einer liste := TRUE;
+ pruefe ende der liste;
+
+ . type layout :
+ layout (" ", naechstes symbol, ".");
+ select counter := 0;
+
+ . proc op layout :
+ IF keine vier zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", naechstes symbol, ".");
+ select counter := 0;
+ innerhalb einer liste := TRUE;
+ pruefe ende der liste;
+
+ . keine vier zeilen mehr :
+ rest auf seite <= 8 * font hoehe
+
+ . refinement layout :
+ IF keine drei zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN elan text := refinement layout zeile;
+ gib elan text aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", symbol, " ");
+
+ . keine drei zeilen mehr :
+ rest auf seite <= 7 * font hoehe
+
+ . pruefe ende der liste :
+ IF pos (zeile, ":") <> 0
+ THEN scan (zeile);
+ WHILE innerhalb einer liste
+ REP next symbol (symbol);
+ IF symbol = ":" THEN innerhalb einer liste := FALSE FI;
+ UNTIL symbol = "" PER;
+ FI;
+
+ . innerhalb einer select kette :
+ select counter > 0
+
+ . analysiere select kette :
+ scan (zeile);
+ naechstes symbol := "";
+ REP symbol := naechstes symbol;
+ next symbol (naechstes symbol);
+ IF naechstes symbol = "SELECT" CAND symbol <> "END"
+ THEN select counter := 1;
+ untersuche select kette;
+ FI;
+ UNTIL naechstes symbol = "" PER;
+ leeres layout;
+
+ . pruefe ende der select kette :
+ IF pos (zeile, "SELECT") <> 0
+ THEN scan (zeile);
+ naechstes symbol := "";
+ untersuche select kette;
+ FI;
+
+ . untersuche select kette :
+ REP symbol := naechstes symbol;
+ next symbol (naechstes symbol);
+ IF naechstes symbol = "SELECT"
+ THEN select counter INCR select step
+ ELIF naechstes symbol = "ENDSELECT"
+ THEN select counter DECR 1
+ FI;
+ UNTIL naechstes symbol = "" PER;
+
+ . select step :
+ IF symbol = "END" THEN -1 ELSE 1 FI
+
+.
+ bestimme elan zeile :
+ IF zeile ist nicht zu lang
+ THEN elan text CAT zeile;
+ ELSE drucke zeile in teilen
+ FI;
+
+ . zeile ist nicht zu lang :
+ zeilen laenge := LENGTH zeile;
+ zeilen laenge <= rest auf zeile
+
+ . rest auf zeile :
+ max zeichen zeile - LENGTH elan text
+
+ . drucke zeile in teilen :
+ zeilen pos := 1;
+ bestimme einrueckung;
+ WHILE zeile noch nicht ganz gedruckt REP teil layout PER;
+
+ . bestimme einrueckung :
+ anzahl einrueck blanks := naechstes nicht blankes zeichen - 1;
+ IF anzahl einrueck blanks > rest auf zeile - 20
+ THEN anzahl einrueck blanks := 0 FI;
+
+ . zeile noch nicht ganz gedruckt :
+ bestimme zeilenteil;
+ NOT zeile ist zu ende
+
+ . bestimme zeilenteil :
+ bestimme laenge;
+ zeilen teil := subtext (zeile, zeilen pos, zeilen pos + laenge - 1);
+ elan text CAT zeilen teil;
+ zeilen pos INCR laenge;
+
+ . zeilen teil : par1
+
+ . bestimme laenge :
+ INT VAR laenge := zeilen laenge - zeilen pos + 1;
+ IF laenge > rest auf zeile
+ THEN laenge := rest auf zeile;
+ WHILE (zeile SUB (zeilen pos + laenge - 1)) <> " "
+ REP laenge DECR 1 UNTIL laenge = 0 PER;
+ IF laenge = 0 THEN laenge := rest auf zeile FI;
+ FI;
+
+ . teil layout :
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ elan text := (zeilen nr laenge - 1) * " ";
+ elan text CAT "+";
+ elan text CAT layout blanks;
+ elan text CAT "|";
+ elan text cat blanks (anzahl einrueck blanks + teil einrueckung);
+
+.
+ seiten wechsel wenn noetig :
+ IF keine zeilen mehr AND NOT eof THEN seiten wechsel FI;
+
+ . keine zeilen mehr :
+ rest auf seite <= 4 * font hoehe
+
+END PROC drucke datei;
+
+
+BOOL PROC real conversion ok (TEXT CONST param) :
+ real param := real (param);
+ last conversion ok AND real param >= 0.0
+END PROC real conversion ok;
+
+
+BOOL PROC int conversion ok (TEXT CONST param) :
+ int param := int (param);
+ last conversion ok AND int param >= 0
+END PROC int conversion ok;
+
+
+PROC neuer tab eintrag (INT CONST typ, TEXT CONST param) :
+
+ suche neuen eintrag;
+ sortiere neue tab position ein;
+ tab typ := typ;
+ tab position := neue tab position;
+ tab param := eventueller parameter;
+
+ . suche neuen eintrag :
+ INT VAR index := 0;
+ REP index INCR 1;
+ IF tab speicher (index). tab typ = leer
+ THEN LEAVE suche neuen eintrag FI;
+ UNTIL index = max tabs PER;
+ LEAVE neuer tab eintrag;
+
+ . sortiere neue tab position ein :
+ INT VAR neue tab position := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = neue tab position
+ THEN LEAVE neuer tab eintrag
+ ELIF tab position > neue tab position
+ THEN insert int (tab liste, tab index, index);
+ LEAVE sortiere neue tab position ein;
+ FI;
+ PER;
+ tab liste CAT index;
+ tab index := anzahl tabs;
+
+ . eventueller parameter :
+ INT VAR link;
+ SELECT typ OF
+ CASE a dpos : insert (d strings, param, link); link
+ CASE a bpos : x step conversion (real(param))
+ OTHERWISE : 0
+ END SELECT
+
+END PROC neuer tab eintrag;
+
+
+PROC neue spalte :
+ a ypos := top margin;
+ aktuelle zeilentiefe der letzten zeile := 0;
+ left margin INCR (limit + luecke);
+ aktuelle spalte INCR 1;
+END PROC neue spalte ;
+
+
+BOOL PROC proc oder op (TEXT CONST symbol) :
+
+ symbol = "PROC" OR symbol = "PROCEDURE"
+ OR symbol = "OP" OR symbol = "OPERATOR"
+
+ENDPROC proc oder op ;
+
+
+PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) :
+
+name := subtext (name, 1, layout laenge name) ;
+elan text := text (zeilen nr, zeilen nr laenge);
+elan text CAT pre;
+elan text CAT name;
+elan text CAT " ";
+generiere strukturiertes layout;
+
+. generiere strukturiertes layout :
+ INT VAR index;
+ FOR index FROM 1 UPTO layout laenge - LENGTH elan text - 1
+ REP elan text CAT post PER;
+
+END PROC layout ;
+
+
+PROC elan text cat blanks (INT CONST anzahl) :
+
+ par2 := anzahl * " ";
+ elan text CAT par2;
+
+END PROC elan text cat blanks;
+
+
+(***********************************************************************)
+
+PROC analysiere zeile (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator) :
+
+loesche analysespeicher;
+behandle fuehrende blanks;
+pruefe ob markierung links;
+
+IF tabellen modus
+ THEN analysiere tabellenzeile
+ELIF letzte zeile war absatzzeile
+ THEN analysiere zeile nach absatzzeile
+ ELSE analysiere zeile nach blockzeile
+FI;
+
+pruefe center und right modus;
+pruefe ob tabulation vorliegt;
+werte indexspeicher aus;
+IF zeile ist keine anweisungszeile
+ THEN berechne zeilenvorschub;
+ pruefe ob markierung rechts;
+ ELSE behandle anweisungszeile;
+FI;
+
+.
+ analysiere zeile nach absatzzeile :
+ test auf aufzaehlung;
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach absatzzeile
+ ELSE analysiere absatzzeile nach absatzzeile
+ FI;
+.
+ analysiere zeile nach blockzeile :
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach blockzeile
+ ELSE analysiere absatzzeile nach blockzeile
+ FI;
+
+
+.
+ behandle fuehrende blanks :
+ zeilenpos := 1;
+ zeilenpos := naechstes nicht blankes zeichen;
+ letzte zeile war absatzzeile := zeile ist absatzzeile;
+ IF letzte zeile war absatzzeile THEN neue einrueckung FI;
+ IF zeilenpos = 0
+ THEN behandle leerzeile;
+ LEAVE analysiere zeile;
+ ELSE initialisiere analyse;
+ FI;
+
+ . behandle leerzeile :
+ a ypos INCR (letzte zeilenhoehe +
+ aktuelle zeilentiefe der letzten zeile + durchschuss);
+ aktuelle zeilentiefe der letzten zeile := letzte zeilentiefe;
+ zeile ist absatzzeile := LENGTH zeile > 0;
+ pruefe ob markierung links;
+ pruefe ob markierung rechts;
+
+ . neue einrueckung :
+ aktuelle einrueckbreite := einrueckbreite;
+
+ . initialisiere analyse :
+ zeile ist absatzzeile := (zeile SUB LENGTH zeile) = blank;
+ zeile muss geblockt werden := block modus AND NOT zeile ist absatzzeile;
+ erstes token der zeile := token index f + 1;
+ zeilen laenge := laenge der zeile;
+ anzahl einrueck blanks := zeilen pos - 1;
+ anzahl zeichen := anzahl einrueck blanks;
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := 0;
+ letzter font := a font;
+ letzte modifikationen := a modifikationen;
+ fuehrende anweisungen := 0;
+ initialisiere zeilenvorschub;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+ IF hoechster index zaehler > 0 THEN loesche index speicher FI;
+
+ . laenge der zeile :
+ IF zeile ist absatzzeile
+ THEN LENGTH zeile - 1
+ ELSE LENGTH zeile
+ FI
+
+.
+ pruefe ob markierung links :
+ INT VAR linkes markierungs token;
+ IF markierung links
+ THEN mark token (mark index l). xpos :=
+ left margin - mark token (mark index l). breite;
+ linkes markierungs token := token index f + 1;
+ lege markierungs token an (mark index l);
+ erstes token der zeile := token index f + 1;
+ initialisiere tab variablen;
+ ELSE linkes markierungs token := 0;
+ FI;
+
+.
+ analysiere tabellenzeile :
+ anfangs blankmodus := doppel blank;
+ alte zeilenpos := zeilen pos;
+ a xpos := left margin;
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP lege fuell token an wenn noetig;
+ initialisiere tab variablen;
+ SELECT tab typ OF
+ CASE a lpos : linksbuendige spalte
+ CASE a rpos : rechtsbuendige spalte
+ CASE a cpos : zentrierte spalte
+ CASE a dpos : dezimale spalte
+ CASE a bpos : geblockte spalte
+ END SELECT;
+ berechne fuell token wenn noetig;
+ tabulation;
+ PER;
+ analysiere rest der zeile;
+
+ . lege fuell token an wenn noetig :
+ IF fill char <> blank
+ THEN fuellzeichen := fill char;
+ fuellzeichen breite := string breite (fuellzeichen);
+ token zeiger := zeilen pos;
+ erstes fuell token := token index f + 1;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ letztes fuell token := token index f;
+ a modifikationen fuer x move := a modifikationen
+ FI;
+
+ . berechne fuell token wenn noetig :
+ IF erstes fuell token <> leer
+ THEN IF letztes fuell token <> token index f
+ THEN berechne fuell token;
+ ELSE loesche letzte token;
+ FI;
+ erstes fuell token := leer
+ FI;
+
+ . berechne fuell token :
+ INT VAR anzahl fuellzeichen, fuell breite;
+ token index := erstes fuell token;
+ anzahl fuellzeichen := (tab anfang - t. xpos + left margin)
+ DIV fuellzeichen breite;
+ rest := (tab anfang - t. xpos + left margin)
+ MOD fuellzeichen breite;
+ IF anzahl fuell zeichen > 0
+ THEN fuell text := anzahl fuellzeichen * fuellzeichen;
+ fuell breite := anzahl fuellzeichen * fuellzeichen breite;
+ FOR token index FROM erstes fuell token UPTO letztes fuell token
+ REP t. text := fuell text;
+ t. breite := fuell breite;
+ IF erstes fuell token <> erstes token der zeile
+ THEN t. xpos INCR rest DIV 2;
+ t. modifikationen fuer x move := t. modifikationen;
+ FI;
+ PER;
+ FI;
+
+ . fuell text : par1
+
+ . loesche letzte token :
+ FOR token index FROM letztes fuell token DOWNTO erstes fuell token
+ REP loesche letztes token PER;
+
+ . tabulation :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilenlaenge + 1;
+ LEAVE analysiere tabellenzeile;
+ FI;
+ anzahl zeichen INCR zeilenpos - alte zeilenpos;
+
+ . linksbuendige spalte :
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+
+ . rechtsbuendige spalte :
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ schreibe zeile rechtsbuendig (tab position);
+
+ . zentrierte spalte :
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ zentriere zeile (tab position);
+
+ . dezimale spalte :
+ d string := name (d strings, tab param);
+ d code 1 := code (d string SUB 1) + 1;
+ d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ zeichenbreiten (d code 1) := d pitch;
+ d code 1 := leer;
+ schreibe zeile rechtsbuendig (tab position);
+ IF zeichen ist dezimal zeichen
+ THEN IF tab position <> zeilen breite
+ THEN a xpos := left margin + tab position;
+ tab anfang := tab position;
+ FI;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ FI;
+
+ . zeichen ist dezimal zeichen :
+ pos (zeile, d string, zeilen pos) = zeilen pos
+
+ . geblockte spalte :
+ blankmodus := einfach blank;
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende OR naechstes zeichen ist blank
+ THEN blocke spalte wenn noetig;
+ LEAVE geblockte spalte;
+ ELSE dehnbares blank gefunden;
+ FI;
+ PER;
+
+ . blocke spalte wenn noetig :
+ IF letztes zeichen ist kein geschuetztes blank
+ THEN blocke zeile (tab param) FI;
+ blank modus := doppel blank;
+
+ . letztes zeichen ist kein geschuetztes blank :
+ pos (zeile, geschuetztes blank, zeilen pos - 1, zeilen pos - 1) = 0
+ AND NOT within kanji (zeile, zeilen pos - 2)
+
+ . analysiere rest der zeile :
+ blankmodus := keine blankanalyse;
+ zeilen pos := alte zeilenpos;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+
+.
+ test auf aufzaehlung :
+ anfangs blankmodus := einfach blank;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN LEAVE analysiere zeile nach absatzzeile
+ ELSE aufzaehlung moeglich
+ FI;
+
+ . aufzaehlung moeglich :
+ bestimme letztes zeichen;
+ IF (anzahl zeichen bei aufzaehlung < 2 AND letztes zeichen = "-")
+ OR (anzahl zeichen bei aufzaehlung < 20 AND letztes zeichen = ":")
+ OR (anzahl zeichen bei aufzaehlung < 7
+ AND pos (".)", letztes zeichen) <> 0)
+ OR naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELIF zeile muss geblockt werden
+ THEN dehnbares blank gefunden;
+ FI;
+
+ . bestimme letztes zeichen :
+ token index := token index f;
+ WHILE token index >= erstes token der zeile
+ REP IF token ist text token
+ THEN letztes zeichen := t. text SUB LENGTH t. text;
+ LEAVE bestimme letztes zeichen;
+ FI;
+ token index DECR 1;
+ PER;
+ letztes zeichen := "";
+
+ . letztes zeichen : par1
+
+ . anzahl zeichen bei aufzaehlung :
+ anzahl zeichen - anzahl einrueck blanks
+
+ . token ist text token :
+ t. offset index >= text token
+.
+ analysiere blockzeile nach absatzzeile :
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach absatzzeile
+ ELSE analysiere blank in blockzeile nach absatzzeile
+ FI;
+ PER;
+
+ . analysiere blank in blockzeile nach absatzzeile :
+ IF naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELSE dehnbares blank gefunden;
+ FI;
+
+.
+ analysiere absatzzeile nach absatzzeile :
+ blankmodus := doppel blank;
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN LEAVE analysiere absatzzeile nach absatzzeile
+ ELSE tabulator position gefunden
+ FI;
+ PER;
+
+.
+ analysiere blockzeile nach blockzeile :
+ anfangs blankmodus := einfach blank;
+ REP bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach blockzeile
+ ELSE dehnbares blank gefunden
+ FI;
+ PER;
+
+.
+ analysiere absatzzeile nach blockzeile :
+ anfangs blankmodus := keine blankanalyse;
+ bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+
+
+.
+ dehnbares blank gefunden :
+ anzahl zeichen INCR 1;
+ zeilenpos INCR 1;
+ a xpos INCR blankbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF NOT a block token
+ THEN anzahl blanks INCR 1;
+ a block token := TRUE;
+ FI;
+.
+ tabulator position gefunden :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilen laenge + 1;
+ ELSE IF erstes token der zeile > token index f
+ THEN token zeiger := zeilen pos;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ FI;
+ anzahl zeichen INCR (zeilenpos - alte zeilenpos);
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+ FI;
+
+.
+ pruefe center und right modus :
+ IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ IF right modus THEN schreibe zeile rechtsbuendig (limit) FI;
+.
+ pruefe ob tabulation vorliegt:
+ IF analyse speicher ist nicht leer CAND a xpos > tf. xpos + tf. breite
+ THEN a modifikationen fuer x move := a modifikationen;
+ token zeiger := zeilen pos;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ FI;
+.
+ werte indexspeicher aus :
+ INT VAR index;
+ IF index zaehler > 0
+ THEN FOR index FROM index zaehler DOWNTO 1
+ REP a ypos DECR (index verschiebung ISUB index);
+ IF (letzte index breite ISUB index) <> 0
+ THEN a xpos := (xpos vor index ISUB index) +
+ min (a xpos - (xpos vor index ISUB index),
+ letzte index breite ISUB index);
+ FI;
+ PER;
+ stelle neuen font ein (grosse fonts ISUB 1);
+ FI;
+.
+ zeile ist keine anweisungszeile :
+ fuehrende anweisungen <> zeilen laenge
+.
+ berechne zeilenvorschub :
+ verschiebung := aktuelle zeilenhoehe +
+ aktuelle zeilentiefe der letzten zeile + durchschuss;
+ aktuelle zeilentiefe der letzten zeile := aktuelle zeilentiefe;
+ a ypos INCR verschiebung;
+ verschiebe token ypos (verschiebung);
+
+.
+ pruefe ob markierung rechts :
+ IF markierung rechts
+ THEN mark token (mark index r). xpos := left margin + limit;
+ lege markierungs token an (mark index r);
+ FI;
+.
+ behandle anweisungszeile :
+ IF linkes markierungs token > 0
+ THEN IF erstes token der zeile = token index f + 1
+ THEN loesche analysespeicher;
+ ELSE FOR token index FROM linkes markierungs token
+ UPTO erstes token der zeile - 1
+ REP t. text := "";
+ t. xpos := 0;
+ t. breite := 0;
+ PER;
+ FI;
+ FI;
+
+END PROC analysiere zeile;
+
+
+PROC blocke zeile (INT CONST rechter rand) :
+
+rest := rechter rand - zeilen breite;
+IF rest > 0 AND anzahl blanks > 0
+ THEN INT CONST schmaler schritt := rest DIV anzahl blanks,
+ breiter schritt := schmaler schritt + 1,
+ anzahl breite schritte := rest MOD anzahl blanks;
+ IF rechts
+ THEN blocke token xpos (breiter schritt, schmaler schritt,
+ anzahl breite schritte);
+ rechts := FALSE;
+ ELSE blocke token xpos (schmaler schritt, breiter schritt,
+ anzahl blanks - anzahl breite schritte);
+ rechts := TRUE;
+ FI;
+ a xpos INCR ( breiter schritt * anzahl breite schritte +
+ schmaler schritt * (anzahl blanks - anzahl breite schritte) );
+FI;
+
+END PROC blocke zeile;
+
+
+PROC zentriere zeile (INT CONST zentrier pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := zentrier pos - tab anfang -
+ (zeilen breite - tab anfang) DIV 2;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+center modus := FALSE;
+
+END PROC zentriere zeile;
+
+
+PROC schreibe zeile rechtsbuendig (INT CONST rechte pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := rechte pos - zeilen breite;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+right modus := FALSE;
+
+
+END PROC schreibe zeile rechtsbuendig;
+
+
+PROC bestimme token bis terminator oder zeilenende
+ (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator):
+
+token zeiger := zeilen pos;
+REP stranalyze (zeichenbreiten, a breite, max breite,
+ zeile, zeilen pos, zeilen laenge,
+ ausgang);
+ zeilen pos INCR 1;
+ IF ausgang = blank ausgang
+ THEN analysiere blank
+ ELIF ausgang = anweisungs ausgang
+ THEN anweisung gefunden
+ ELIF ausgang = d code ausgang
+ THEN analysiere d string
+ ELIF ausgang = erweiterungs ausgang
+ THEN erweiterung gefunden
+ ELSE terminator oder zeilenende gefunden
+ FI;
+PER;
+
+. analysiere blank :
+ IF blankmodus = einfach blank OR
+ (blankmodus = doppel blank AND naechstes zeichen ist blank)
+ THEN terminator oder zeilenende gefunden
+ ELSE a breite INCR blankbreite;
+ zeilenpos INCR 1;
+ FI;
+
+. analysiere d string :
+ IF pos (zeile, d string, zeilen pos) = zeilen pos
+ THEN terminator oder zeilenende gefunden
+ ELSE IF d pitch = maxint
+ THEN erweiterung gefunden
+ ELIF d pitch < 0
+ THEN a breite INCR (d pitch XOR - maxint - 1);
+ zeilen pos INCR 2;
+ ELSE a breite INCR d pitch;
+ zeilenpos INCR 1;
+ FI;
+ FI;
+
+. erweiterung gefunden :
+ a breite INCR extended char pitch (a font, zeile SUB zeilen pos,
+ zeile SUB zeilen pos + 1);
+ zeilen pos INCR 2;
+
+. anweisung gefunden :
+ gegebenfalls neues token gefunden;
+ analysiere anweisung (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator);
+ IF zeile ist zu ende
+ THEN LEAVE bestimme token bis terminator oder zeilenende FI;
+ token zeiger := zeilenpos;
+
+. terminator oder zeilenende gefunden :
+ IF ausgang = null ausgang THEN zeilen laenge DECR 1 FI;
+ gegebenfalls neues token gefunden;
+ LEAVE bestimme token bis terminator oder zeilenende;
+
+ . gegebenfalls neues token gefunden :
+ IF token zeiger < zeilenpos
+ THEN lege token an (zeile, token zeiger, zeilen pos - 1, text token) FI;
+
+END PROC bestimme token bis terminator oder zeilen ende;
+
+
+PROC analysiere anweisung (PROC (INT CONST, TEXT VAR,
+ INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR, INT VAR) analysator) :
+
+ bestimme anweisung;
+ IF anweisung ist kommando
+ THEN lege token an (anweisung, 1, maxint, kommando token);
+ ELIF anweisung ist kein kommentar
+ THEN werte anweisung aus;
+ FI;
+
+ . anweisungsende : zeilen pos - 2
+
+ . erstes zeichen : par1
+
+. bestimme anweisung :
+ INT CONST anweisungsanfang := zeilenpos + 1;
+ zeilen pos := pos (zeile, anweisungszeichen, anweisungsanfang, zeilenlaenge);
+ IF zeilenpos = 0
+ THEN zeilenpos := anweisungsanfang - 1;
+ replace (zeile, zeilenpos, geschuetztes anweisungszeichen);
+ LEAVE analysiere anweisung;
+ FI;
+ IF fuehrende anweisungen = anweisungsanfang - 2 THEN fuehrende anweisungen := zeilen pos FI;
+ zeilen pos INCR 1;
+ anweisung := subtext (zeile, anweisungsanfang, anweisungsende);
+ erstes zeichen := anweisung SUB 1;
+
+. anweisung ist kommando :
+ IF erstes zeichen = quote
+ THEN scan (anweisung);
+ next symbol (anweisung, symbol type);
+ next symbol (par2, naechster symbol type);
+ IF symbol type <> text type OR naechster symbol type <> eof type
+ THEN LEAVE analysiere anweisung FI;
+ TRUE
+ ELIF erstes zeichen = druckerkommando zeichen
+ THEN delete char (anweisung, 1);
+ TRUE
+ ELSE FALSE
+ FI
+
+. anweisung ist kein kommentar :
+ erstes zeichen <> kommentar zeichen
+
+.
+ werte anweisung aus :
+ analyze command (anweisungs liste, anweisung, number type,
+ anweisungs index, anzahl params, par1, par2);
+ SELECT anweisungs index OF
+ CASE a type : type anweisung
+ CASE a on : on anweisung
+ CASE a off : off anweisung
+ CASE a ub, a fb : ub fb anweisung
+ CASE a ue, a fe : ue fe anweisung
+ CASE a center : center anweisung
+ CASE a right : right anweisung
+ CASE a up, a down : index anweisung
+ CASE a end up or down : end index anweisung
+ CASE a bsp : bsp anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a mark : mark anweisung
+ CASE a markend : markend anweisung
+ OTHERWISE : IF anweisungs index > 0
+ THEN speichere anweisung
+ ELSE rufe analysator
+ FI;
+ END SELECT;
+
+ . type anweisung :
+ change all (par1, " ", "");
+ stelle neuen font ein (font (par1));
+ a modifikationen := 0;
+ ueberpruefe groesste fontgroesse;
+ IF nicht innerhalb eines indexes
+ THEN berechne aktuelle zeilengroesse FI;
+
+ . nicht innerhalb eines indexes :
+ index zaehler = 0
+
+ . on anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN set bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . off anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN reset bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . ub fb anweisung :
+ IF anweisungs index = a ub
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ on anweisung;
+
+ . ue fe anweisung :
+ IF anweisungs index = a ue
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ off anweisung;
+
+ . center anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ AND NOT right modus
+ THEN center modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . right anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ THEN IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ right modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . index anweisung :
+ INT CONST grosser font := a font,
+ grosse fonthoehe := fonthoehe, grosse fonttiefe := fonttiefe;
+ INT VAR kleiner font;
+ IF next smaller font exists (grosser font, kleiner font)
+ THEN stelle neuen font ein (kleiner font) FI;
+ IF font hoehe < grosse fonthoehe
+ THEN verschiebung := verschiebung fuer kleinen font
+ ELSE verschiebung := verschiebung fuer grossen font
+ FI;
+ a ypos INCR verschiebung;
+ merke index werte;
+
+ . verschiebung fuer kleinen font :
+ IF anweisungs index = a down
+ THEN 15 PROZENT (grosse fonthoehe + grosse fonttiefe)
+ ELSE - ( 4 PROZENT (grosse fonthoehe + grosse fonttiefe) )
+ - (grosse fonthoehe + grosse fonttiefe - fonthoehe - fonttiefe)
+ FI
+
+ . verschiebung fuer grossen font :
+ IF anweisungs index = a down
+ THEN 25 PROZENT (fonthoehe + fonttiefe)
+ ELSE - (50 PROZENT (fonthoehe + fonttiefe) )
+ FI
+
+ . merke index werte :
+ index zaehler INCR 1;
+ IF hoechster index zaehler < index zaehler
+ THEN neues index level
+ ELSE altes index level
+ FI;
+ IF index zaehler = 1
+ THEN alter blankmodus := blankmodus;
+ blankmodus := keine blankanalyse;
+ FI;
+
+ . neues index level :
+ hoechster index zaehler := index zaehler;
+ letzte index breite CAT 0;
+ xpos vor index CAT a xpos;
+ zeilenpos nach index CAT -1;
+ index verschiebung CAT verschiebung;
+ grosse fonts CAT grosser font;
+
+ . altes index level :
+ IF (zeilenpos nach index ISUB index zaehler) = anweisungsanfang - 1
+ AND sign (index verschiebung ISUB index zaehler) <> sign (verschiebung)
+ THEN doppelindex gefunden;
+ ELSE replace (xpos vor index, index zaehler, a xpos);
+ FI;
+ replace (index verschiebung, index zaehler, verschiebung);
+ replace (grosse fonts, index zaehler, grosser font);
+
+ . doppelindex gefunden :
+ replace (letzte index breite, index zaehler,
+ a xpos - (xpos vor index ISUB index zaehler));
+ a xpos := xpos vor index ISUB index zaehler;
+
+ . end index anweisung :
+ IF index zaehler > 0
+ THEN schalte auf alte index werte zurueck;
+ FI;
+
+ . schalte auf alte index werte zurueck :
+ IF index zaehler = 1 THEN blankmodus := alter blankmodus FI;
+ a ypos DECR (index verschiebung ISUB index zaehler);
+ stelle neuen font ein (grosse fonts ISUB index zaehler);
+ IF (letzte index breite ISUB index zaehler) <> 0
+ THEN berechne doppelindex
+ ELSE replace (zeilenpos nach index, index zaehler, zeilenpos);
+ FI;
+ index zaehler DECR 1;
+
+ . berechne doppelindex :
+ a xpos := (xpos vor index ISUB index zaehler) +
+ max (a xpos - (xpos vor index ISUB index zaehler),
+ letzte index breite ISUB index zaehler);
+ replace (zeilenpos nach index, index zaehler, -1);
+ replace (letzte index breite, index zaehler, 0);
+
+ . bsp anweisung :
+ INT VAR breite davor, breite dahinter;
+ IF anweisungs anfang - 2 >= 1 AND anweisungs ende + 2 <= zeilen laenge
+ THEN IF is kanji esc (zeile SUB anweisungs anfang - 3)
+ THEN zeichen davor := subtext (zeile, anweisungs anfang - 3,
+ anweisungs anfang - 2);
+ ELSE zeichen davor := zeile SUB anweisungs anfang - 2;
+ FI;
+ IF is kanji esc (zeile SUB anweisungs ende + 2)
+ THEN zeichen dahinter := subtext (zeile, anweisungs ende + 2,
+ anweisungs ende + 3 );
+ ELSE zeichen dahinter := zeile SUB anweisungs ende + 2;
+ FI;
+ IF pos (" #", zeichen davor) = 0 AND pos (" #", zeichen dahinter) = 0
+ THEN breite davor := char pitch (a font, zeichen davor);
+ breite dahinter := char pitch (a font, zeichen dahinter);
+ IF breite davor < breite dahinter THEN vertausche zeichen FI;
+ lege token fuer zeichen dahinter an;
+ a xpos INCR (breite davor - breite dahinter) DIV 2;
+ FI;
+ FI;
+
+ . zeichen davor : par1
+ . zeichen dahinter : par2
+
+ . vertausche zeichen :
+ change (zeile, anweisungs anfang - 2 - LENGTH zeichen davor + 1,
+ anweisungs anfang - 2, zeichen dahinter);
+ change (zeile, anweisungs ende + 2,
+ anweisungs ende + 2 + LENGTH zeichen dahinter - 1, zeichen davor);
+ change (tf. text, LENGTH tf. text - LENGTH zeichen davor + 1,
+ LENGTH tf. text, zeichen dahinter);
+ tf. breite INCR (breite dahinter - breite davor);
+ a xpos INCR (breite dahinter - breite davor);
+ int param := breite davor;
+ breite davor := breite dahinter;
+ breite dahinter := int param;
+
+ . lege token fuer zeichen dahinter an :
+ token zeiger := zeilen pos;
+ a breite := breite dahinter;
+ zeilen pos INCR LENGTH zeichen dahinter;
+ a xpos DECR (breite davor + breite dahinter) DIV 2;
+ lege token an (zeile, token zeiger, zeilen pos - 1, text token);
+ anzahl zeichen DECR 1;
+
+ . fillchar anweisung :
+ IF par1 = "" THEN par1 := " " FI;
+ fill char := par1;
+ speichere anweisung;
+
+ . mark anweisung :
+ IF par1 <> ""
+ THEN mark index l := (alter mark index l MOD 2) + 1;
+ neue markierung (par1, mark index l);
+ ELSE mark index l := 0;
+ FI;
+ IF par2 <> ""
+ THEN mark index r := (alter mark index r MOD 2) + 3;
+ neue markierung (par2, mark index r);
+ ELSE mark index r := 0;
+ FI;
+
+ . markend anweisung :
+ loesche markierung;
+
+ . speichere anweisung :
+ anweisungs zaehler INCR 1;
+ anweisungs indizes CAT anweisungs index;
+ IF par1 <> ""
+ THEN insert (params1, par1);
+ params1 zeiger CAT highest entry (params1);
+ ELSE params1 zeiger CAT 0;
+ FI;
+ IF par2 <> ""
+ THEN insert (params2, par2);
+ params2 zeiger CAT highest entry (params2);
+ ELSE params2 zeiger CAT 0;
+ FI;
+
+ . rufe analysator :
+ INT CONST alte xpos := a xpos, alte y pos := a ypos;
+ INT VAR analysatorbreite, analysatorhoehe, analysatortiefe,
+ analysator font := a font,
+ analysator modifikationen := a modifikationen;
+ zeilen pos := anweisungsanfang - 1;
+disable stop;
+ analysator (text code, zeile, zeilen pos,
+ analysator font, analysator modifikationen,
+ analysatorbreite, analysatorhoehe, analysatortiefe, dummy);
+IF is error
+ THEN par1 := error message;
+ par1 CAT " a1-> ";
+ par1 CAT text (errorline);
+ clear error;
+ errorstop (par1);
+FI;
+enable stop;
+ hole token der analyse;
+ a xpos := alte xpos + analysatorbreite;
+ a ypos := alte ypos;
+ a modifikationen := analysator modifikationen;
+ groesste analysatorhoehe := max (analysatorhoehe, groesste analysator hoehe);
+ groesste analysatortiefe := max (analysatortiefe, groesste analysator tiefe);
+ IF analysator font <> a font
+ THEN stelle neuen font ein (analysator font);
+ ueberpruefe groesste fontgroesse;
+ IF nicht innerhalb eines indexes
+ THEN berechne aktuelle zeilengroesse FI;
+ ELSE aktuelle zeilenhoehe := max (groesste analysatorhoehe,
+ aktuelle zeilenhoehe);
+ aktuelle zeilentiefe := max (groesste analysatortiefe,
+ aktuelle zeilentiefe);
+ FI;
+
+ . hole token der analyse :
+ INT VAR token nr := 0, token font, token xpos, token ypos, token typ;
+ BOOL VAR font changed := FALSE;
+ token text := "";
+ REP
+disable stop;
+ analysator (token code, token text, token nr,
+ token font, a modifikationen, a breite,
+ token xpos, token ypos, token typ);
+IF is error
+ THEN par1 := error message;
+ par1 CAT " a2-> ";
+ par1 CAT text (errorline);
+ clear error;
+ errorstop (par1);
+FI;
+enable stop;
+ IF token nr = 0
+ THEN IF font changed THEN a font := -1 FI;
+ LEAVE hole token der analyse
+ FI;
+ IF token font <> a font
+ THEN a font := token font;
+ font offsets := y offsets (a font);
+ offsets := LENGTH font offsets > 2;
+ font changed := TRUE;
+ FI;
+ a xpos := alte xpos + token xpos;
+ a ypos := alte ypos + token ypos;
+ lege token an (token text, 1, max int, token typ)
+ PER;
+
+ . token text : par1
+
+END PROC analysiere anweisung;
+
+
+PROC stelle neuen font ein (INT CONST font nr ) :
+
+ IF font nr <> a font THEN neuer font FI;
+
+ . neuer font :
+ a font := max (1, font nr);
+ get font (a font, einrueckbreite, fontdurchschuss, fonthoehe, fonttiefe,
+ zeichenbreiten);
+ blankbreite := zeichenbreiten (blank code 1);
+ zeichenbreiten (blank code 1) := blank ausgang;
+ zeichenbreiten (anweisungs zeichen code 1) := anweisungs ausgang;
+ font offsets := y offsets (a font);
+ offsets := LENGTH font offsets > int length;
+ berechne fontgroesse;
+ berechne letzte zeilengroesse;
+ IF d code 1 <> leer
+ THEN d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ FI;
+
+END PROC stelle neuen font ein;
+
+
+INT OP PROZENT (INT CONST prozent, wert) :
+
+ (wert * prozent + 99) DIV 100
+
+END OP PROZENT;
+
+
+PROC neue markierung (TEXT CONST text, INT CONST mark index) :
+
+ mark token (mark index). text := text;
+ mark token (mark index). breite := string breite (text);
+ mark token (mark index). font := a font;
+ mark token (mark index). modifikationen := a modifikationen;
+
+END PROC neue markierung;
+
+
+INT PROC string breite (TEXT CONST string) :
+
+ INT VAR summe := 0, pos := 1;
+ REP stranalyze (zeichenbreiten, summe, max breite, string, pos, maxint, ausgang);
+ IF ausgang = erweiterungs ausgang
+ THEN summe INCR extended char pitch (a font,
+ string SUB pos+1, string SUB pos+2);
+ pos INCR 3;
+ ELIF ausgang = blank ausgang
+ THEN summe INCR blankbreite;
+ pos INCR 2;
+ ELIF ausgang = anweisungs ausgang
+ THEN summe INCR char pitch (a font, anweisungszeichen);
+ pos INCR 2;
+ ELSE LEAVE string breite WITH summe
+ FI;
+ PER;
+ 0
+
+END PROC string breite;
+
+(*******************************************************************)
+
+PROC lege token an (TEXT CONST token text,
+ INT CONST token anfang, token ende, token typ) :
+
+ INT VAR anfang := token anfang;
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage token (tf, token text, token anfang, token ende, token typ);
+ IF token typ >= text token
+ THEN IF offsets THEN lege offsets an (font offsets) FI;
+ stranalyze (zeichen zaehler, anzahl zeichen, max int,
+ token text, anfang, token ende, ausgang);
+ a xpos INCR a breite;
+ FI;
+ a breite := 0;
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege token an;
+
+
+PROC uebertrage token (TOKEN VAR tf, TEXT CONST token text,
+ INT CONST token anfang, token ende, token typ) :
+
+ tf. text := subtext (token text, token anfang, token ende);
+ tf. xpos := a xpos;
+ tf. breite := a breite;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := token typ;
+ tf. block token := a block token;
+
+END PROC uebertrage token;
+
+
+PROC lege markierungs token an (INT CONST mark index) :
+
+ aktuelle ypos := a ypos + (mark font offsets ISUB 1);
+ neuer token index;
+ tf := mark token (mark index);
+ IF mark offsets THEN lege offsets an (mark font offsets) FI;
+
+ . mark font offsets : y offsets (mark token (mark index). font)
+
+ . mark offsets : LENGTH mark font offsets > int length
+
+END PROC lege markierungs token an;
+
+
+PROC lege offsets an (TEXT CONST offsets l) :
+
+ INT CONST anzahl offsets := LENGTH offsets l DIV int length;
+ INT VAR index;
+ offset token := tf;
+ offset token. block token := FALSE;
+ reset bit (offset token. modifikationen, underline bit);
+ reset bit (offset token. modifikationen fuer x move, underline bit);
+ FOR index FROM 2 UPTO anzahl offsets
+ REP aktuelle ypos := a ypos + (offsets l ISUB index);
+ neuer token index;
+ tf := offset token;
+ tf. offset index := index;
+ PER;
+
+END PROC lege offsets an;
+
+
+PROC neuer token index :
+
+IF erster ypos index a = 0
+ THEN erste ypos
+ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei gleicher ypos
+ ELSE fuege neue ypos ein
+FI;
+
+ . erste ypos :
+ ypos index f INCR 1;
+ erster ypos index a := ypos index f;
+ letzter ypos index a := ypos index f;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := 0;
+ erstes token bei neuer ypos;
+
+ . fuege neue ypos ein :
+ letztes token bei gleicher ypos;
+ IF ya. ypos > aktuelle ypos
+ THEN richtige ypos ist oberhalb
+ ELSE richtige ypos ist unterhalb
+ FI;
+
+ . richtige ypos ist oberhalb :
+ REP ypos index a := ya. vorheriger ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos vor erstem ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos < aktuelle ypos
+ THEN fuege ypos nach ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ FI;
+ PER;
+
+ . richtige ypos ist unterhalb :
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos nach letztem ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos > aktuelle ypos
+ THEN fuege ypos vor ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ FI;
+ PER;
+
+ . fuege ypos vor erstem ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := erster ypos index a;
+ erster ypos index a := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := ypos index a;
+ yf. naechster ypos index := ya. naechster ypos index;
+ ya. naechster ypos index := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos vor ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := ypos index a;
+ yf. vorheriger ypos index := ya. vorheriger ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach letztem ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := 0;
+ yf. vorheriger ypos index := letzter ypos index a;
+ letzter ypos index a := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+END PROC neuer token index;
+
+
+PROC erstes token bei neuer ypos :
+ token index f INCR 1;
+ ypos index a := ypos index f;
+ ya. erster token index := token index f;
+ ya. ypos := aktuelle ypos;
+END PROC erstes token bei neuer ypos;
+
+
+PROC neues token bei neuer ypos :
+ token index f INCR 1;
+ ya. ypos := aktuelle ypos;
+ token index := ya. letzter token index;
+ t. naechster token index := token index f;
+END PROC neues token bei neuer ypos;
+
+
+PROC neues token bei gleicher ypos :
+ tf. naechster token index := token index f + 1;
+ token index f INCR 1;
+END PROC neues token bei gleicher ypos;
+
+
+PROC letztes token bei gleicher ypos :
+ tf. naechster token index := 0;
+ ya. letzter token index := token index f;
+END PROC letztes token bei gleicher ypos;
+
+
+PROC loesche letztes token :
+
+ IF token index f = ya. erster token index
+ THEN loesche ypos
+ ELSE token index f DECR 1;
+ FI;
+
+ . loesche ypos :
+ kette vorgaenger um;
+ kette nachfolger um;
+ bestimme letzten ypos index;
+
+ . kette vorgaenger um :
+ ypos index := ya. vorheriger ypos index;
+ IF ypos index = 0
+ THEN erster ypos index a := ya. naechster ypos index;
+ ELSE y. naechster ypos index := ya. naechster ypos index;
+ FI;
+
+ . kette nachfolger um :
+ ypos index := ya. naechster ypos index;
+ IF ypos index = 0
+ THEN letzter ypos index a := ya. vorheriger ypos index;
+ ELSE y. vorheriger ypos index := ya. vorheriger ypos index;
+ FI;
+
+ . bestimme letzten ypos index :
+ IF ypos index a = ypos index f THEN ypos index f DECR 1 FI;
+ token index f DECR 1;
+ ypos index a := letzter ypos index a;
+ WHILE ypos index a <> 0
+ CAND ya. letzter token index <> token index f
+ REP ypos index a := ya. vorheriger ypos index PER;
+
+END PROC loesche letztes token;
+
+
+PROC blocke token xpos (INT CONST dehnung 1, dehnung 2,
+ anzahl dehnungen fuer dehnung 1 ) :
+
+ INT VAR dehnung := 0, anzahl dehnungen := 0;
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP erhoehe token xpos bei block token;
+ t. xpos INCR dehnung;
+ token index INCR 1;
+ PER;
+
+ . erhoehe token xpos bei block token :
+ IF t. block token
+ THEN IF anzahl dehnungen < anzahl dehnungen fuer dehnung 1
+ THEN anzahl dehnungen INCR 1;
+ dehnung INCR dehnung 1;
+ ELSE dehnung INCR dehnung 2;
+ FI;
+ FI;
+
+END PROC blocke token xpos;
+
+
+PROC verschiebe token xpos (INT CONST verschiebung l) :
+
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP t. xpos INCR verschiebung l;
+ token index INCR 1;
+ PER;
+
+END PROC verschiebe token xpos;
+
+
+PROC verschiebe token ypos (INT CONST verschiebung l) :
+
+ ypos index := erster ypos index a;
+ WHILE ypos index <> 0
+ REP y. ypos INCR verschiebung l;
+ ypos index := y. naechster ypos index;
+ PER;
+
+END PROC verschiebe token ypos;
+
+
+PROC sortiere neue token ein :
+
+INT VAR index;
+IF analysespeicher ist nicht leer
+ THEN IF druckspeicher ist nicht leer
+ THEN sortiere neue token in sortierte liste ein
+ ELSE sortierte liste ist leer
+ FI;
+FI;
+
+. sortierte liste ist leer :
+ IF erster ypos index a <> 0
+ THEN erster ypos index d := erster ypos index a;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ FI;
+
+. sortiere neue token in sortierte liste ein :
+ gehe zum ersten neuen token;
+ bestimme erste einsortierposition;
+ WHILE es gibt noch neue token
+ REP IF ypos index d = 0
+ THEN haenge neue token ans ende der sortierten liste
+ ELIF ya. ypos > yd. ypos
+ THEN naechste ypos der sortierten liste
+ ELIF ya. ypos = yd. ypos
+ THEN neues token auf gleicher ypos
+ ELSE neue token vor ypos
+ FI;
+ PER;
+
+ . gehe zum ersten neuen token :
+ ypos index a := erster ypos index a;
+
+ . bestimme erste einsortierposition :
+ WHILE ypos index d <> 0 CAND ya. ypos < yd. ypos
+ REP ypos index d := yd. vorheriger ypos index PER;
+ IF ypos index d = 0 THEN erste neue token vor listen anfang FI;
+
+ . erste neue token vor listen anfang :
+ ypos index d := erster ypos index d;
+ erster ypos index d := erster ypos index a;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE erste neue token vor listen anfang
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE erste neue token vor listen anfang
+ FI;
+ PER;
+
+ . es gibt noch neue token :
+ ypos index a <> 0
+
+ . haenge neue token ans ende der sortierten liste :
+ ypos index d := letzter ypos index d;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ ypos index a := 0;
+
+ . naechste ypos der sortierten liste :
+ ypos index d := yd. naechster ypos index;
+
+ . neues token auf gleicher ypos :
+ token index := yd. letzter token index;
+ t . naechster token index := ya. erster token index;
+ yd. letzter token index := ya. letzter token index;
+ ypos index a := ya. naechster ypos index;
+ ypos index d := yd. naechster ypos index;
+ IF ypos index d = 0 THEN ypos index d := letzter ypos index d FI;
+
+ . neue token vor ypos :
+ verkette ya mit vorherigem yd;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE neue token vor ypos
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE neue token vor ypos
+ FI;
+ PER;
+
+
+. verkette ya mit vorherigem yd :
+ index := ypos index d;
+ ypos index d := yd. vorheriger ypos index;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ ypos index d := index;
+
+. verkette letztes ya mit yd :
+ ypos index a := letzter ypos index a;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := 0;
+
+. verkette vorheriges ya mit yd :
+ index := ypos index a;
+ ypos index a := ya. vorheriger ypos index;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := index;
+
+. verkette ya mit yd :
+ verkette vorheriges ya mit yd;
+ neues token auf gleicher ypos;
+
+END PROC sortiere neue token ein;
+
+(***************************************************************)
+
+PROC drucke tokenspeicher
+ (INT CONST max ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF druckspeicher ist nicht leer
+ THEN gehe zur ersten ypos;
+ WHILE yd. ypos <= max ypos
+ REP drucke token bei ypos;
+ gehe zur naechsten ypos;
+ PER;
+ loesche gedruckte token;
+FI;
+
+. gehe zur ersten ypos :
+ ypos index d := erster ypos index d;
+
+. drucke token bei ypos :
+ IF yd. ypos >= - y start
+ THEN druck durchgang;
+ IF bold pass THEN fett durchgang FI;
+ IF underline pass THEN unterstreich durchgang FI;
+ FI;
+
+ . bold pass : bit (pass, bold bit)
+
+ . underline pass : bit (pass, underline bit)
+
+. gehe zur naechsten ypos :
+ IF ypos index d = letzter ypos index d
+ THEN loesche druckspeicher;
+ LEAVE drucke tokenspeicher;
+ FI;
+ ypos index d := yd. naechster ypos index;
+
+. loesche gedruckte token :
+ erster ypos index d := ypos index d;
+ yd. vorheriger ypos index := 0;
+
+.
+ druck durchgang :
+ verschiebung := yd. ypos - d ypos;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ gehe zum ersten token dieser ypos;
+ REP drucke token UNTIL kein token mehr vorhanden PER;
+
+ . drucke token :
+ IF NOT token passt in zeile
+ THEN IF token ist text token
+ THEN berechne token teil
+ ELSE LEAVE drucke token
+ FI;
+ FI;
+ font wechsel wenn noetig;
+ x move mit modifikations ueberpruefung;
+ IF token ist text token
+ THEN gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ ELIF token ist linien token
+ THEN gib linien token aus
+ ELSE gib kommando token aus
+ FI;
+
+ . gib linien token aus :
+ linien verschiebung := d token. breite;
+ ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . gib kommando token aus :
+ execute (write cmd, d token. text, 1, LENGTH d token. text)
+
+ . berechne token teil :
+ INT CONST fuenf punkte := 5 * char pitch (d token. font, punkt);
+ INT VAR token pos, token breite, anzahl punkte, zeichen laenge, zeichen breite;
+ IF d token. xpos < - x start
+ AND d token. xpos + d token. breite > - x start
+ THEN berechne token teil von links
+ ELIF d token. xpos < papierbreite
+ AND d token. xpos + d token. breite > papierbreite
+ THEN berechne token teil nach rechts
+ ELSE LEAVE drucke token
+ FI;
+
+ . berechne token teil von links :
+ rest := min (x size, d token. xpos + d token. breite + x start);
+ d token. xpos := - x start;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := LENGTH d token. text + 1;
+ token breite := fuenf punkte;
+ berechne token teil breite von hinten;
+ change (d token. text, 1, token pos - 1, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von hinten :
+ WHILE naechstes zeichen passt noch davor
+ REP token breite INCR zeichen breite;
+ token pos DECR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch davor :
+ IF within kanji (d token. text, token pos - 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos - zeichen laenge, token pos - 1));
+ token breite + zeichen breite < rest
+
+ . berechne token teil nach rechts :
+ rest := papier breite - d token. xpos;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := 0;
+ token breite := fuenf punkte;
+ berechne token teil breite von vorne;
+ change (d token. text, token pos + 1, LENGTH d token. text, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von vorne :
+ WHILE naechstes zeichen passt noch dahinter
+ REP token breite INCR zeichen breite;
+ token pos INCR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch dahinter :
+ IF is kanji esc (d token. text SUB token pos + 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos + 1, token pos + zeichen laenge));
+ token breite + zeichen breite < rest
+
+.
+ fett durchgang :
+ reset bit (pass, bold bit);
+ gib cr aus;
+ gehe zum ersten token dieser ypos;
+ REP gib token nochmal aus UNTIL kein token mehr vorhanden PER;
+ schalte modifikationen aus wenn noetig;
+
+ . gib token nochmal aus :
+ INT CONST min verschiebung := bold offset (d token. font);
+ d token. xpos INCR min verschiebung;
+ IF bit (d token. modifikationen, bold bit) AND
+ token passt in zeile AND token ist text token
+ THEN verschiebung := d token. xpos - d xpos;
+ font wechsel wenn noetig;
+ schalte italics ein wenn noetig;
+ x move wenn noetig;
+ gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d token. xpos DECR min verschiebung;
+
+ . schalte italics ein wenn noetig :
+ IF bit (d token. modifikationen, italics bit)
+ THEN neue modifikationen := modifikations werte (italics bit + 1);
+ schalte modifikationen ein wenn noetig;
+ ELSE schalte modifikationen aus wenn noetig;
+ FI;
+
+.
+ unterstreich durchgang :
+ INT VAR l xpos := 0;
+ reset bit (pass, underline bit);
+ gib cr aus;
+ schalte modifikationen aus wenn noetig;
+ gehe zum ersten token dieser ypos;
+ REP unterstreiche token UNTIL kein token mehr vorhanden PER;
+
+ . unterstreiche token :
+ IF token muss unterstrichen werden AND
+ token passt in zeile AND token ist text token
+ THEN font wechsel wenn noetig;
+ berechne x move laenge;
+ x move wenn noetig;
+ berechne unterstreich laenge;
+ ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ l xpos := d token. xpos + d token. breite;
+
+ . token muss unterstrichen werden :
+ bit (d token. modifikationen, underline bit) OR
+ bit (d token. modifikationen fuer x move, underline bit)
+
+ . berechne x move laenge :
+ IF bit (d token. modifikationen fuer x move, underline bit)
+ THEN verschiebung := l xpos - d xpos
+ ELSE verschiebung := d token. xpos - d xpos
+ FI;
+
+ . berechne unterstreich laenge :
+ IF bit (d token. modifikationen, underline bit)
+ THEN linien verschiebung := d token. xpos +
+ d token. breite - d xpos
+ ELSE linien verschiebung := d token. xpos - d xpos
+ FI;
+ d token. offset index := - underline line type;
+
+
+. gehe zum ersten token dieser ypos :
+ token index := yd. erster token index;
+ d token := t;
+
+. kein token mehr vorhanden :
+ token index := d token. naechster token index;
+ IF token index = 0
+ THEN TRUE
+ ELSE d token := t;
+ FALSE
+ FI
+
+. token ist text token :
+ d token. offset index >= text token
+
+. token ist linien token :
+ d token. offset index <= linien token
+
+. token passt in zeile :
+ d token. xpos >= - x start AND
+ d token. xpos + d token. breite <= papier breite
+
+. font wechsel wenn noetig :
+ IF d token. font <> d font
+ THEN font wechsel (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen aus wenn noetig :
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. x move wenn noetig :
+ IF verschiebung <> 0
+ THEN x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+.
+ x move mit modifikations ueberpruefung :
+ verschiebung := d token. xpos - d xpos;
+ IF verschiebung <> 0
+ THEN neue modifikationen := d token. modifikationen fuer x move;
+ schalte modifikationen ein wenn noetig;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ neue modifikationen := d token. modifikationen;
+ schalte modifikationen ein wenn noetig;
+
+. gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC drucke tokenspeicher;
+
+
+PROC ziehe horizontale linie (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ IF linien verschiebung > 0
+ THEN disable stop;
+ d xpos INCR linien verschiebung;
+ execute (draw, "", linien verschiebung, 0);
+ IF is error
+ THEN ziehe horizontale linie nach cr;
+ FI;
+ enable stop;
+ FI;
+
+ . ziehe horizontale linie nach cr :
+ clear error;
+ d xpos DECR linien verschiebung;
+ verschiebung := d xpos;
+ gib cr aus;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ d xpos INCR linien verschiebung;
+ execute (draw, "", linien verschiebung, 0);
+ IF is error
+ THEN clear error;
+ d xpos DECR linien verschiebung;
+ FI;
+
+ . gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC ziehe horizontale linie;
+
+
+PROC y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ IF verschiebung <> 0
+ THEN gib cr aus;
+ disable stop;
+ d ypos INCR verschiebung;
+ execute (move, "", 0, verschiebung);
+ IF is error
+ THEN clear error;
+ d ypos DECR verschiebung;
+ verschiebung := 0;
+ FI;
+ enable stop;
+ FI;
+
+ . gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC y move;
+
+
+PROC x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d xpos INCR verschiebung;
+ execute (move, "", verschiebung, 0);
+ IF is error
+ THEN fuehre x move nach cr aus
+ FI;
+
+ . fuehre x move nach cr aus :
+ clear error;
+ schalte modifikationen aus wenn noetig;
+ gib cr bei x move aus;
+ IF d xpos <> 0
+ THEN execute (move, "", d xpos, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI
+ FI;
+ schalte modifikationen ein wenn noetig;
+
+ . gib cr bei x move aus :
+ execute (carriage return, "", d xpos - verschiebung, 0);
+
+ . schalte modifikationen aus wenn noetig :
+ neue modifikationen := d modifikationen;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+END PROC x move;
+
+
+PROC schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d modifikationen := neue modifikationen;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss eingeschaltet werden
+ FI;
+ PER;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss eingeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (on, "", modifikations werte (index), 0);
+ IF is error
+ THEN clear error;
+ reset bit (modifikations modus, modifikations bit);
+ set bit (pass, modifikations bit);
+ FI;
+ ELSE set bit (pass, modifikations bit);
+ FI;
+
+END PROC schalte modifikationen ein;
+
+
+PROC schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss ausgeschaltet werden
+ FI;
+ PER;
+ d modifikationen := 0;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss ausgeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (off, "", modifikations werte (index), 0);
+ IF is error THEN clear error FI;
+ FI;
+
+END PROC schalte modifikationen aus;
+
+
+PROC font wechsel
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d font := d token. font;
+ get replacements (d font, replacements, replacement tabelle);
+ execute (type, "", d font, 0);
+ IF is error THEN font wechsel nach cr FI;
+ enable stop;
+
+ . font wechsel nach cr :
+ clear error;
+ verschiebung := d xpos;
+ gib cr aus;
+ execute (type, "", d font, 0);
+ IF NOT is error
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ x move
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+END PROC font wechsel;
+
+
+PROC gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ INT CONST token laenge := LENGTH d token. text;
+ INT VAR token pos := 1, alte token pos, summe := 0;
+ IF token laenge > 0
+ THEN REP alte token pos := token pos;
+ stranalyze (replacement tabelle, summe, 0,
+ d token. text, token pos, token laenge,
+ ausgang);
+ IF ausgang = 0
+ THEN gib token rest aus;
+ ELSE gib token teil aus;
+ gib ersatzdarstellung aus;
+ FI;
+ PER;
+ FI;
+
+ . gib token rest aus :
+ IF token laenge >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token laenge) FI;
+ d xpos INCR d token. breite;
+ LEAVE gib text token aus;
+
+ . gib token teil aus :
+ IF token pos >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token pos) FI;
+
+ . gib ersatzdarstellung aus :
+ IF ausgang = maxint
+ THEN ersatzdarstellung := extended replacement (d token. font,
+ d token. text SUB token pos + 1, d token. text SUB token pos + 2);
+ execute (write text, ersatzdarstellung, 1, LENGTH ersatzdarstellung);
+ tokenpos INCR 3;
+ ELSE IF ausgang < 0
+ THEN ausgang := ausgang XOR minint;
+ token pos INCR 1;
+ FI;
+ execute (write text, replacements, ausgang + 1, ausgang + code (replacements SUB ausgang));
+ token pos INCR 2;
+ FI;
+
+ . ersatzdarstellung : par1
+
+END PROC gib text token aus;
+
+
+PROC schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+enable stop;
+gebe restliche token aus;
+gib cr aus;
+seiten ende kommando;
+
+. gebe restliche token aus :
+ IF erster ypos index d <> 0
+ THEN drucke tokenspeicher (maxint,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ rest := papier laenge - d ypos;
+ aktuelle zeilentiefe der letzten zeile := 0;
+
+. gib cr aus :
+ IF d xpos <> 0
+ THEN execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ FI;
+
+. seiten ende kommando :
+ seite ist offen := FALSE;
+ a ypos := top margin;
+ aktuelle spalte := 1;
+ close (page, rest);
+
+END PROC schliesse seite ab;
+
+
+PROC eroeffne seite (INT CONST x wanted l, y wanted l,
+ PROC (INT CONST, INT VAR, INT VAR) open ) :
+
+IF vor erster seite THEN eroeffne druck FI;
+seiten anfang kommando;
+initialisiere neue seite;
+
+. eroeffne druck :
+ open (document, x size, y size);
+ vor erster seite := FALSE;
+ d font := -1;
+ d modifikationen := 0;
+
+. seiten anfang kommando :
+ x start := x wanted l;
+ y start := y wanted l;
+ open (page, x start, y start);
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+
+. initialisiere neue seite :
+ INT CONST dif left margin := x wanted l - x start - left margin + indentation,
+ dif top margin := y wanted l - y start - top margin;
+ IF dif left margin <> 0
+ THEN erstes tab token := 1;
+ verschiebe token xpos (dif left margin);
+ a xpos INCR dif left margin;
+ left margin INCR dif left margin;
+ FI;
+ IF dif top margin <> 0
+ THEN verschiebe token ypos (dif top margin);
+ a ypos INCR dif top margin;
+ top margin INCR dif top margin;
+ FI;
+ d xpos := 0;
+ d ypos := 0;
+ IF seitenlaenge <= papierlaenge
+ THEN seitenlaenge := top margin + pagelength;
+ ELSE seitenlaenge DECR papierlaenge;
+ FI;
+ papierlaenge := y size - y start;
+ papierbreite := x size - x start;
+
+END PROC eroeffne seite;
+
+(****************************************************************)
+
+PROC elan fuss und kopf (INT CONST fuss oder kopf,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF fuss oder kopf <= 0 THEN elan fuss FI;
+IF fuss oder kopf >= 0 THEN elan kopf FI;
+
+.
+ elan fuss :
+ y move zur fusszeile;
+ drucke elan fuss;
+ close page cmd;
+
+. y move zur fusszeile :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ verschiebung := rest auf seite - font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. drucke elan fuss :
+ IF bottom label = ""
+ THEN seiten nr := ""
+ ELSE seiten nr := bottom label;
+ seiten nr CAT "/";
+ FI;
+ seiten nr CAT text (gedruckte seiten);
+ elan text := seiten nr;
+ elan text CAT " ";
+ elan text cat blanks ((max zeichen fuss - LENGTH dateiname) DIV 2 - LENGTH elan text);
+ elan text CAT dateiname;
+ elan text cat blanks (max zeichen fuss - LENGTH seiten nr - LENGTH elan text - 3);
+ elan text CAT " ";
+ elan text CAT seiten nr;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . seiten nr : par1
+
+. close page cmd :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ close (page, papierlaenge - d ypos);
+ seite ist offen := FALSE;
+
+.
+ elan kopf :
+ open page cmd ;
+ y move zur kopfzeile;
+ drucke elan kopf;
+
+. open page cmd :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ IF fuss oder kopf = 1 THEN execute (type, "", d font, 0) FI;
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+ top margin := y wanted - y start;
+ left margin := x wanted - x start;
+ rest auf seite := pagelength;
+ papierlaenge := y size - y start;
+ d ypos := 0;
+ d xpos := 0;
+
+. y move zur kopf zeile :
+ verschiebung := top margin;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ IF verschiebung = 0 THEN rest auf seite INCR top margin FI;
+
+. drucke elan kopf :
+ elan text := headline pre;
+ elan text CAT date;
+ elan text CAT headline post;
+ elan text CAT datei name;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC elan fuss und kopf;
+
+
+PROC gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+cr plus lf (1, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+linker rand wenn noetig;
+d token. breite := LENGTH elan text * einrueckbreite;
+gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. linker rand wenn noetig :
+ IF left margin > 0
+ THEN disable stop;
+ d xpos := left margin;
+ execute (move, "", left margin, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC gib elan text aus;
+
+
+PROC cr plus lf (INT CONST anzahl,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+gib cr aus;
+gib lf aus;
+rest auf seite DECR verschiebung;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+. gib lf aus :
+ verschiebung := anzahl * font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+END PROC cr plus lf ;
+
+
+END PACKET eumel printer;
+
diff --git a/system/std.zusatz/1.8.7/src/eumelmeter b/system/std.zusatz/1.8.7/src/eumelmeter
new file mode 100644
index 0000000..ba92476
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/eumelmeter
@@ -0,0 +1,131 @@
+ (* Author: J.Liedtke*)
+PACKET eumelmeter DEFINES (* Stand: 11.10.83 *)
+
+ init log ,
+ log :
+
+
+LET snapshot interval = 590.0 ;
+
+REAL VAR next snapshot time ,
+ time , timex ,
+ paging wait , paging wait x ,
+ paging busy , paging busy x ,
+ fore cpu , fore cpu x ,
+ back cpu , back cpu x ,
+ system cpu , system cpu x ,
+ delta t ;
+INT VAR storage max, used ;
+TEXT VAR record ;
+
+PROC init log :
+
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ next snapshot time := time + snapshot interval
+
+ENDPROC init log ;
+
+PROC log (INT CONST active terminals, active background) :
+
+ new snapshot time if was clock reset ;
+ IF clock (1) >= next snapshot time
+ THEN save values ;
+ get new values ;
+ create stat record ;
+ put log (record) ;
+ define next snapshot time
+ FI .
+
+new snapshot time if was clock reset :
+ IF clock (1) < next snapshot time - snapshot interval
+ THEN next snapshot time := clock (1)
+ FI .
+
+save values :
+ time x := time ;
+ paging wait x := paging wait ;
+ paging busy x := paging busy ;
+ fore cpu x := fore cpu ;
+ back cpu x := back cpu ;
+ system cpu x := system cpu .
+
+get new values :
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ storage (storage max, used) .
+
+create stat record :
+ record := text (used, 5) ;
+ record CAT text (active terminals,3) ;
+ record CAT text (active background,3) ;
+ delta t := (time - time x) ;
+ percent (paging wait, paging wait x) ;
+ percent (paging busy, paging busy x) ;
+ percent (fore cpu, fore cpu x) ;
+ percent (back cpu, back cpu x) ;
+ percent (system cpu, system cpu x) ;
+ percent (last, 0.0) ;
+ percent (nutz, 0.0) .
+
+last : paging wait + paging busy + fore cpu + back cpu + system cpu
+ - paging waitx - paging busyx - fore cpux - back cpux - system cpux .
+
+nutz : time - paging wait - system cpu
+ - timex + paging waitx + system cpux .
+
+define next snapshot time :
+ next snapshot time := time + snapshot interval .
+
+ENDPROC log ;
+
+PROC percent (REAL CONST neu, alt ) :
+
+ record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%"
+
+ENDPROC percent ;
+
+ENDPACKET eumelmeter ;
+
+INT VAR active terminals , active background ;
+
+task password ("-") ;
+break ;
+command dialogue (FALSE) ;
+forget ("eumelmeter") ;
+init log ;
+REP
+ pause (6000) ;
+ count active processes (active terminals, active background) ;
+ log (active terminals, active background)
+PER ;
+
+PROC count active processes (INT VAR active terminals, active background) :
+
+ active terminals := 0 ;
+ active background := 0 ;
+ TASK VAR process := myself ;
+ REP
+ next active (process) ;
+ IF user process
+ THEN IF process at terminal
+ THEN active terminals INCR 1
+ ELSE active background INCR 1
+ FI
+ FI
+ UNTIL process = myself PER .
+
+user process : NOT (process < supervisor) .
+
+process at terminal : channel (process) >= 0 .
+
+ENDPROC count active processes ;
+
diff --git a/system/std.zusatz/1.8.7/src/font convertor 9 b/system/std.zusatz/1.8.7/src/font convertor 9
new file mode 100644
index 0000000..a5d0ea7
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/font convertor 9
@@ -0,0 +1,1095 @@
+PACKET font convertor (* Autor : Rudolf Ruland *)
+ (* Stand : 29.03.88 *)
+ DEFINES create font table ,
+ add fonts,
+ create font file :
+
+(* >>> ***************************************************************** <<< *)
+
+INT CONST int length := length of one int,
+ highest bit := int length * 8 - 1;
+
+. length of one int :
+ INT VAR int counter := 0, int value := max int;
+ REP int counter INCR 1;
+ int value := int value DIV 256;
+ UNTIL int value = 0 PER;
+ int counter
+.;
+
+(* >>> ***************************************************************** <<< *)
+
+LET t tag = 1,
+ t bold = 2,
+ t number = 3,
+ t text = 4,
+ t operator = 5,
+ t delimiter = 6,
+ t end of file = 7,
+
+ nil modus = 0,
+ font table modus = 1,
+ font modus = 2,
+ extension modus = 3,
+
+ x unit = 1,
+ y unit = 2,
+ on string = 3,
+ off string = 4,
+ indentation pitch = 5,
+ font lead = 6,
+ font height = 7,
+ font depth = 8,
+ larger font = 9,
+ smaller font = 10,
+ font string = 11,
+ y off sets = 12,
+ bold off set = 13;
+
+THESAURUS VAR names, english identification := empty thesaurus,
+ german identification := empty thesaurus;
+
+insert (english identification, "xunit");
+insert (english identification, "yunit");
+insert (english identification, "onstring");
+insert (english identification, "offstring");
+insert (english identification, "indentationpitch");
+insert (english identification, "fontlead");
+insert (english identification, "fontheight");
+insert (english identification, "fontdepth");
+insert (english identification, "nextlargerfont");
+insert (english identification, "nextsmallerfont");
+insert (english identification, "fontstring");
+insert (english identification, "yoffsets");
+insert (english identification, "boldoffset");
+
+insert (german identification, "xeinheit");
+insert (german identification, "yeinheit");
+insert (german identification, "onsequenz");
+insert (german identification, "offsequenz");
+insert (german identification, "einrueckbreite");
+insert (german identification, "durchschuss");
+insert (german identification, "fonthoehe");
+insert (german identification, "fonttiefe");
+insert (german identification, "groessererfont");
+insert (german identification, "kleinererfont");
+insert (german identification, "fontsequenz");
+insert (german identification, "yverschiebungen");
+insert (german identification, "boldverschiebung");
+
+INT VAR modus, last modus, symbol type, int symbol, pitch,
+ identification nr, link nr, extension code 1,
+ char code 1, char code, char pos, vorzeichen,
+ replacements length, index;
+TEXT VAR symbol, font table name, replacement, char, buffer, z;
+BOOL VAR english;
+FILE VAR file, font file;
+
+(*****************************************************************)
+
+LET max fonts = 50,
+ max extensions = 120,
+ font table type = 3009,
+
+ FONTTABLE = STRUCT (
+
+ THESAURUS font names,
+
+ TEXT replacements, font name links,
+ extension chars, extension indexes,
+
+ ROW 4 TEXT on strings, off strings,
+
+ REAL x unit, y unit,
+
+ ROW 256 INT replacements table,
+
+ INT last font, last extension,
+
+ ROW max fonts STRUCT (
+ TEXT font string, font name indexes, replacements,
+ extension chars, extension indexes, y offsets,
+ ROW 256 INT pitch table, replacements table,
+ INT indentation pitch, font lead, font height, font depth,
+ next larger font, next smaller font, bold offset ) fonts ,
+
+ ROW max extensions STRUCT (
+ TEXT replacements,
+ ROW 256 INT pitch table, replacements table,
+ INT std pitch ) extensions ,
+
+ );
+
+BOUND FONTTABLE VAR font table;
+
+DATASPACE VAR ds;
+
+INT VAR font nr, extension nr;
+
+. font : font table. fonts (font nr)
+. extension : font table. extensions (extension nr)
+. line nr : line no (file) - 1
+.;
+
+(*****************************************************************)
+
+
+PROC create font table :
+
+ create font table (last param)
+
+END PROC create font table;
+
+
+PROC create font table (TEXT CONST font file name) :
+
+file := sequential file (input, font file name);
+disable stop;
+ds := nilspace;
+modus := nil modus;
+load;
+IF is error THEN error (errormessage) FI;
+forget (ds);
+
+END PROC create font table;
+
+
+PROC add fonts (TEXT CONST font tab name, font file name) :
+
+file := sequential file (input, font file name);
+font table name := font tab name;
+change all (font table name, " ", "");
+IF NOT exists (font table name) COR type (old (font table name)) <> font table type
+ THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht")
+FI;
+disable stop;
+ds := old (font table name);
+fonttable := ds;
+modus := font modus;
+font nr := fonttable. last font;
+extension nr := fonttable. last extension;
+load;
+IF is error THEN error (errormessage) FI;
+forget (ds);
+
+END PROC add fonts;
+
+
+PROC load :
+
+enable stop;
+initialize loading;
+REP get kennung;
+ get identification;
+ get char specifications;
+UNTIL symbol type >= t end of file PER;
+font table found;
+
+. initialize loading :
+ scan (file);
+ get next symbol;
+
+. font table found :
+ IF font nr = 0
+ THEN errorstop ("Fonts zur Fonttabelle """
+ + font table name + """ fehlen");
+ ELSE font table. last font := font nr;
+ font table. last extension := extension nr;
+ forget (font table name, quiet);
+ copy (ds, font table name);
+ type (old (font table name), font table type);
+ forget (ds); ds := nilspace;
+ FI;
+
+. get next symbol :
+ next symbol (file, symbol, symbol type);
+
+. get semicolon :
+ get next symbol;
+ IF symbol <> ";" OR symbol type <> t delimiter
+ THEN errorstop ("';' erwartet") FI;
+
+.
+ get kennung :
+ cout (line nr);
+ IF symbol type <> t bold
+ THEN errorstop ("Kennung erwartet") FI;
+ IF symbol = "FONTTABLE" OR symbol = "FONTTABELLE"
+ THEN initialize font table;
+ get font table name;
+ ELIF symbol = "FONT"
+ THEN initialize font;
+ get font names;
+ ELIF symbol = "EXTENSION" OR symbol = "ERWEITERUNG"
+ THEN get extension char;
+ initialize extension;
+ ELIF modus = nil modus
+ THEN errorstop ("Kennung 'FONTTABLE' oder 'FONTTABELLE' zu Beginn der Datei erwartet")
+ ELSE errorstop ("unzulaessige Kennung")
+ FI;
+
+ . initialize font table :
+ IF modus <> nil modus THEN font table found FI;
+ modus := font table modus;
+ font nr := 0;
+ extension nr := 0;
+ font table := ds;
+ font table. font names := empty thesaurus;
+ font table. replacements := "";
+ font table. font name links := "";
+ font table. extension chars := "";
+ font table. extension indexes := "";
+ font table. x unit := 10.0/2.54;
+ font table. y unit := 6.0/2.54;
+ font table. replacements table := 0;
+ FOR index FROM 1 UPTO 4
+ REP font table. on strings (index) := "";
+ font table. off strings (index) := "";
+ PER;
+
+ . get font table name :
+ get name list;
+ symbol type := t text;
+ symbol := name (names, 1);
+ IF exists (symbol)
+ THEN forget (symbol);
+ IF exists (symbol)
+ THEN errorstop ("Fonttabelle existiert schon") FI;
+ FI;
+ font table name := symbol;
+
+ . initialize font :
+ IF font nr = max fonts
+ THEN errorstop ("zu viele Fonts") FI;
+ font nr INCR 1;
+ modus := font modus;
+ replacements length := LENGTH font table. replacements;
+ font. font string := "";
+ font. font name indexes := "";
+ font. replacements := "";
+ font. extension chars := "";
+ font. extension indexes := "";
+ font. y offsets := int length * ""0"";
+ font. indentation pitch := int (font table. x unit * 2.54 / 10.0);
+ font. font lead := 0;
+ font. font height := int (font table. y unit * 2.54 / 6.0);
+ font. font depth := 0;
+ font. next larger font := 0;
+ font. next smaller font := 0;
+ font. bold offset := 0;
+ font. pitch table := font. indentation pitch;
+ font. replacements table := font table. replacements table;
+ FOR index FROM 1 UPTO LENGTH font table. extension chars
+ REP font. replacements table
+ ( code (font table. extension chars SUB index) + 1 ) := maxint;
+ PER;
+
+ . get font names :
+ get name list;
+ index := 0;
+ symbol type := t text;
+ WHILE next font name
+ REP link nr := link (font table. font names, symbol);
+ IF link nr = 0
+ THEN insert (font table. font names, symbol, link nr);
+ font table. font name links CAT font nr;
+ ELIF (font table. font name links ISUB link nr) = 0
+ THEN replace (font table. font name links, link nr, font nr);
+ ELSE errorstop ("Font existiert in Fonttabelle """
+ + font table name + """ schon")
+ FI;
+ font. font name indexes CAT link nr;
+ PER;
+
+ . next font name :
+ get (names, symbol, index);
+ symbol <> ""
+
+ . get extension char :
+ IF NOT two bytes
+ THEN errorstop ("Erweiterungen nur im zwei-Byte-Modus erlaubt") FI;
+ get name list;
+ symbol type := t text;
+ symbol := name (names, 1);
+ IF LENGTH symbol <> 1
+ THEN errorstop ("nur ein Zeichen bei Erweiterung erlaubt") FI;
+ extension code 1 := code (symbol) + 1;
+ IF NOT is kanji esc (symbol)
+ THEN errorstop ("Kanji-ESC-Zeichen erwartet") FI;
+
+ . initialize extension :
+ IF extension nr = max extensions
+ THEN errorstop ("zu viele Erweiterungen") FI;
+ extension nr INCR 1;
+ IF modus <> extension modus THEN last modus := modus FI;
+ modus := extension modus;
+ IF last modus = font table modus
+ THEN initalize font table extension
+ ELSE initalize font extension
+ FI;
+
+ . initalize font table extension :
+ IF pos (font table. extension chars, symbol) <> 0
+ THEN errorstop ("Erweiterung wurde schon definiert") FI;
+ extension. replacements := "";
+ extension. std pitch := 0;
+ extension. pitch table := 0;
+ extension. replacements table := 0;
+ font table. extension chars CAT symbol;
+ font table. extension indexes CAT extension nr;
+ font table. replacements table (extension code 1) := max int;
+ replacements length := 0;
+
+ . initalize font extension :
+ IF pos (font. extension chars, symbol) <> 0
+ THEN errorstop ("Erweiterung wurde schon definiert") FI;
+ extension. replacements := "";
+ extension. std pitch := font. pitch table (extension code 1) XOR (-maxint-1);
+ extension. pitch table := extension. std pitch;
+ font. extension chars CAT symbol;
+ font. extension indexes CAT extension nr;
+ char pos := pos (font table. extension chars, symbol);
+ IF char pos <> 0
+ THEN index := font table. extension indexes ISUB char pos;
+ extension. replacements table :=
+ font table. extensions (index). replacements table;
+ replacements length :=
+ LENGTH font table. extensions (index). replacements;
+ font. replacements table (extension code 1) := max int;
+ ELSE extension. replacements table := 0;
+ replacements length := 0;
+ FI;
+
+.
+ get identification :
+ WHILE identification found
+ REP cout (line nr);
+ determine identification link nr;
+ select identification;
+ PER;
+
+ . identification found :
+ get next symbol;
+ symbol type = t tag
+
+ . determine identification link nr :
+ identification nr := link (english identification, symbol);
+ english := TRUE;
+ IF identification nr = 0
+ THEN identification nr := link (german identification, symbol);
+ english := FALSE;
+ IF identification nr = 0
+ THEN errorstop ("unzulaesige Identifikation") FI;
+ FI;
+
+ . select identification :
+ get next symbol;
+ IF symbol <> "=" OR symbol type <> t operator
+ THEN errorstop ("'=' nach Identifikation fehlt") FI;
+ get next symbol;
+ SELECT identification nr OF
+ CASE x unit : x unit found
+ CASE y unit : y unit found
+ CASE on string : on string found
+ CASE off string : off string found
+ CASE indentation pitch : indentation pitch found
+ CASE font lead : font lead found
+ CASE font height : font height found
+ CASE font depth : font depth found
+ CASE larger font : larger font found
+ CASE smaller font : smaller font found
+ CASE font string : font string found
+ CASE y offsets : y offsets found
+ CASE bold offset : bold offset found
+ END SELECT;
+
+ . x unit found :
+ check modus (font table modus);
+ font table. x unit := real (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("REAL-Denoter nach 'x unit' erwartet")
+ ELSE errorstop ("REAL-Denoter nach 'x einheit' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . y unit found :
+ check modus (font table modus);
+ font table. y unit := real (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("REAL-Denoter nach 'y unit' erwartet")
+ ELSE errorstop ("REAL-Denoter nach 'y einheit' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . on string found :
+ check modus (font table modus);
+ FOR index FROM 1 UPTO 4
+ REP IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'on string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'on sequenz' erwartet")
+ FI;
+ FI;
+ font table. on strings (index) := symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE on string found FI;
+ IF index = 4 THEN errorstop ("';' erwartet") FI;
+ get next symbol;
+ PER;
+
+ . off string found :
+ check modus (font table modus);
+ FOR index FROM 1 UPTO 4
+ REP IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'off string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'off sequenz' erwartet")
+ FI;
+ FI;
+ font table. off strings (index) := symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE off string found FI;
+ IF index = 4 THEN errorstop ("';' erwartet") FI;
+ get next symbol;
+ PER;
+
+ . indentation pitch found :
+ check modus (font modus);
+ font. indentation pitch := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'indentation pitch' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'einrueckbreite' erwartet")
+ FI;
+ FI;
+ font. pitch table := font. indentation pitch;
+ get semicolon;
+
+ . font lead found :
+ check modus (font modus);
+ font. font lead := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font lead' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'durchschuss' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . font height found :
+ check modus (font modus);
+ font. font height := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font height' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'fonthoehe' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . font depth found :
+ check modus (font modus);
+ font. font depth := int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'font depth' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'fonttiefe' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+ . larger font found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'next larger font' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'groesserer font' erwartet")
+ FI;
+ FI;
+ determine link nr;
+ font. next larger font := link nr;
+ get semicolon;
+
+ . smaller font found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'next smaller font' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'kleinerer font' erwartet")
+ FI;
+ FI;
+ determine link nr;
+ font. next smaller font := link nr;
+ get semicolon;
+
+ . determine link nr :
+ change all (symbol, " ", "");
+ IF symbol = ""
+ THEN link nr := 0
+ ELSE link nr := link (font table. font names, symbol);
+ IF link nr = 0
+ THEN insert (font table. font names, symbol, link nr);
+ font table. font name links CAT 0;
+ FI;
+ FI;
+
+ . font string found :
+ check modus (font modus);
+ IF symbol type <> t text
+ THEN IF english
+ THEN errorstop ("TEXT-Denoter nach 'font string' erwartet")
+ ELSE errorstop ("TEXT-Denoter nach 'fontsequenz' erwartet")
+ FI;
+ FI;
+ font. font string := symbol;
+ get semicolon;
+
+ . y offsets found :
+ check modus (font modus);
+ font. y offsets := "";
+ REP IF symbol = "-" AND symbol type = t operator
+ THEN vorzeichen := -1;
+ get next symbol;
+ ELSE vorzeichen := 1;
+ FI;
+ int symbol := vorzeichen * int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'y offsets' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'y verschiebungen' erwartet")
+ FI;
+ FI;
+ font. y offsets CAT int symbol;
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ IF symbol = ";" THEN LEAVE y offsets found FI;
+ get next symbol;
+ PER;
+
+ . bold offset found :
+ check modus (font modus);
+ IF symbol = "-" AND symbol type = t operator
+ THEN vorzeichen := -1;
+ get next symbol;
+ ELSE vorzeichen := 1;
+ FI;
+ font. bold offset := vorzeichen * int (symbol);
+ IF NOT last conversion ok
+ THEN IF english
+ THEN errorstop ("INT-Denoter nach 'bold offset' erwartet")
+ ELSE errorstop ("INT-Denoter nach 'bold verschiebungen' erwartet")
+ FI;
+ FI;
+ get semicolon;
+
+.
+ get char specifications :
+ WHILE char found
+ REP cout (line nr);
+ char specification;
+ get next symbol;
+ PER;
+
+ . char found :
+ symbol type = t text
+
+ . char specification :
+ IF LENGTH symbol <> 1
+ THEN errorstop ("nur ein Zeichen bei Zeichenangabe erlaubt") FI;
+ char := symbol;
+ char code 1 := code (char) + 1;
+ look for specification;
+ look for specification;
+ get semicolon;
+
+ . look for specification :
+ get next symbol;
+ IF symbol = ";" AND symbol type = t delimiter
+ THEN LEAVE char specification
+ ELIF symbol = "," AND symbol type = t delimiter
+ THEN get specification
+ ELSE errorstop ("',' oder ';' bei Zeichenspezifikation erwartet")
+ FI;
+
+ . get specification :
+ get next symbol;
+ IF symbol type = t number
+ THEN pitch specification;
+ ELIF symbol type = t text
+ THEN replacement specification
+ ELSE errorstop ("unzulaessiger Wert bei Zeichenspezifikation")
+ FI;
+
+ . pitch specification :
+ int symbol := int (symbol);
+ IF NOT last conversion ok
+ THEN errorstop ("INT-Denoter bei Breitenangabe erwartet") FI;
+ IF modus = font modus
+ THEN font. pitch table (char code 1) := int symbol;
+ IF is kanji esc (char)
+ THEN set bit (font. pitch table (char code 1), highest bit) FI;
+ ELIF modus = extension modus
+ THEN IF last modus = font modus AND
+ font. pitch table (extension code 1) <> max int
+ THEN font. pitch table (extension code 1) := max int FI;
+ extension. pitch table (char code 1) := int symbol;
+ FI;
+
+ . replacement specification :
+ IF LENGTH symbol > 255
+ THEN errorstop ("Ersatzdarstellungen duerfen nur 255 Zeichen haben") FI;
+ IF modus = font table modus
+ THEN font table. replacements table (char code 1) :=
+ (LENGTH font table. replacements + 1);
+ font table. replacements CAT code (LENGTH symbol);
+ font table. replacements CAT symbol;
+ IF is kanji esc (char)
+ THEN set bit (font table. replacements table (char code 1), highest bit) FI;
+ ELIF modus = font modus
+ THEN font. replacements table (char code 1) :=
+ (replacements length + LENGTH font. replacements + 1);
+ font. replacements CAT code (LENGTH symbol);
+ font. replacements CAT symbol;
+ IF is kanji esc (char)
+ THEN set bit (font. replacements table (char code 1), highest bit) FI;
+ ELIF modus = extension modus
+ THEN IF last modus = font modus AND
+ font. replacements table (extension code 1) <> max int
+ THEN font. replacements table (extension code 1) := max int FI;
+ extension. replacements table (char code 1) :=
+ (replacements length + LENGTH extension. replacements + 1);
+ extension. replacements CAT code (LENGTH symbol);
+ extension. replacements CAT symbol;
+ FI;
+
+END PROC load;
+
+
+PROC get name list :
+
+ names := empty thesaurus;
+ get next symbol;
+ IF symbol <> ":" OR symbol type <> t delimiter
+ THEN errorstop ("':' nach Kennung erwartet") FI;
+ REP get next symbol;
+ change all (symbol, " ", "");
+ IF symbol type <> t text
+ THEN errorstop ("TEXT-Denoter in Namesliste erwartet") FI;
+ IF symbol = ""
+ THEN errorstop ("'niltext' als Name nicht erlaubt") FI;
+ insert (names, symbol);
+ get next symbol;
+ IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter
+ THEN errorstop ("',' oder ';' in Liste erwartet") FI;
+ UNTIL symbol = ";" PER;
+
+ . get next symbol :
+ next symbol (file, symbol, symbol type);
+
+END PROC get name list;
+
+
+OP := (ROW 256 INT VAR l, INT CONST r) :
+
+INT VAR i;
+IF modus = extension modus OR NOT two bytes
+ THEN FOR i FROM 1 UPTO 256 REP l (i) := r PER;
+ ELSE FOR i FROM 1 UPTO 129 REP l (i) := r PER;
+ FOR i FROM 130 UPTO 160 REP l (i) := r - maxint - 1 PER;
+ FOR i FROM 161 UPTO 224 REP l (i) := r PER;
+ FOR i FROM 225 UPTO 240 REP l (i) := r - maxint - 1 PER;
+ FOR i FROM 241 UPTO 256 REP l (i) := r PER;
+FI;
+
+END OP :=;
+
+
+PROC check modus (INT CONST mod) :
+
+ IF mod <> modus THEN errorstop ("unzulaessige Identifikation") FI;
+
+END PROC check modus;
+
+
+PROC error (TEXT CONST message) :
+
+(*INT CONST l := error line;*)
+ clear error;
+ errorstop ("Zeile " + text (line nr) + " bei " + letztes symbol +
+ " : " + message (* + errorline if neccessary *) );
+
+ . letztes symbol :
+ IF symbol type = t text
+ THEN decode (symbol);
+ """" + symbol + """"
+ ELIF symbol type >= t end of file
+ THEN "EOF"
+ ELSE symbol
+ FI
+(*
+ . errorline if neccessary :
+ IF l = 0
+ THEN ""
+ ELSE " -> " + text (l)
+ FI
+*)
+END PROC error;
+
+
+(*******************************************************************)
+
+
+PROC create font file (TEXT CONST font tab name, font file name) :
+
+enable stop;
+connect font table;
+put font table in font file;
+
+.
+ connect font table :
+ buffer := font tab name;
+ change all (buffer, " ", "");
+ IF NOT exists (buffer) COR type (old (buffer)) <> font table type
+ THEN errorstop ("Fonttabelle """ + buffer + """ gibt es nicht")
+ FI;
+ font table := old (buffer);
+
+.
+ put font table in font file :
+ INT VAR font file nr := 0;
+ enable stop;
+ font file := sequential file (output, font file name);
+ max line length (font file, 16000);
+ check file overflow;
+ z := " ";
+ put font table;
+ FOR font nr FROM 1 UPTO font table. last font REP put font PER;
+
+ . check file overflow :
+ WHILE lines (font file) > 3600
+ REP font file nr INCR 1;
+ font file := sequential file (output, font file name + "." + text (font file nr));
+ max line length (font file, 16000);
+ PER;
+
+. put font table :
+ put z;
+ z CAT "FONTTABLE : """; z CAT buffer; z CAT """;"; put z;
+ z CAT " x unit = "; z CAT text (font table. x unit); z CAT ";"; put z;
+ z CAT " y unit = "; z CAT text (font table. y unit); z CAT ";"; put z;
+ z CAT " on string = """; z cat on strings; z CAT """;"; put z;
+ z CAT " off string = """; z cat off strings; z CAT """;"; put z;
+ put font table replacements;
+ put font table extensions;
+ put z;
+
+ . z cat on strings :
+ FOR index FROM 1 UPTO 4
+ REP buffer := font table. on strings (index);
+ decode (buffer);
+ z CAT buffer;
+ IF index <> 4 THEN z CAT """, """ FI;
+ PER;
+
+ . z cat off strings :
+ FOR index FROM 1 UPTO 4
+ REP buffer := font table. off strings (index);
+ decode (buffer);
+ z CAT buffer;
+ IF index <> 4 THEN z CAT """, """ FI;
+ PER;
+
+ . put font table replacements :
+ put z;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ link nr := font table. replacements table (char code 1);
+ reset bit (link nr, highest bit);
+ IF link nr > 0 AND link nr <> maxint
+ THEN z CAT " ";
+ put char code;
+ put font table replacement;
+ put z;
+ FI;
+ PER;
+
+ . put font table replacement :
+ replacement := subtext (font table. replacements, link nr + 1,
+ link nr + code (font table. replacements SUB link nr) );
+ put replacement;
+
+ . put font table extensions :
+ IF font table. extension chars <> ""
+ THEN FOR index FROM 1 UPTO LENGTH font table. extension chars
+ REP put font table extension PER;
+ FI;
+
+ . put font table extension :
+ check file overflow;
+ put z;
+ z CAT " EXTENSION : """"";
+ z CAT text 3 (code (font table. extension chars SUB index));
+ z CAT """"";";
+ put z; put z;
+ replacements length := 0;
+ extension nr := font table. extension indexes ISUB index;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ link nr := extension. replacements table (char code 1);
+ IF link nr > 0
+ THEN z CAT " ";
+ put char code;
+ put extension replacement;
+ put z;
+ FI;
+ PER;
+
+. put font :
+ check file overflow;
+ put z;
+ z CAT " FONT : "; z cat font names; z CAT ";"; put z;
+ z CAT " indentation pitch = ";
+ z CAT text(font. indentation pitch);
+ z CAT ";"; put z;
+ IF font. font lead <> 0
+ THEN z CAT " font lead = ";
+ z CAT text(font. font lead);
+ z CAT ";"; put z;
+ FI;
+ z CAT " font height = ";
+ z CAT text(font. font height);
+ z CAT ";"; put z;
+ IF font. font depth <> 0
+ THEN z CAT " font depth = ";
+ z CAT text(font. font depth);
+ z CAT ";"; put z;
+ FI;
+ IF next larger <> ""
+ THEN z CAT " next larger font = """;
+ z CAT next larger;
+ z CAT """;"; put z;
+ FI;
+ IF next smaller <> ""
+ THEN z CAT " next smaller font = """;
+ z CAT next smaller;
+ z CAT """;"; put z;
+ FI;
+ IF font. font string <> ""
+ THEN z CAT " font string = """;
+ z CAT font string;
+ z CAT """;"; put z;
+ FI;
+ IF (font. y offsets ISUB 1) <> 0 OR LENGTH font. y offsets > int length
+ THEN z CAT " y offsets = ";
+ z cat y offsets;
+ z CAT ";"; put z;
+ FI;
+ IF font. bold offset <> 0
+ THEN z CAT " bold offset = ";
+ z CAT text(font. bold offset);
+ z CAT ";"; put z;
+ FI;
+ put font pitches and replacements;
+ put font extensions;
+
+ . next larger : name (font table. font names, font. next larger font)
+ . next smaller : name (font table. font names, font. next smaller font)
+ . font string : buffer := font. font string; decode (buffer); buffer
+
+ . z cat font names :
+ z CAT """";
+ z CAT name (font table. font names, font. font name indexes ISUB 1);
+ z CAT """";
+ FOR index FROM 2 UPTO LENGTH font. font name indexes DIV int length
+ REP z CAT ", """;
+ z CAT name (font table. font names, font. font name indexes ISUB index);
+ z CAT """";
+ PER;
+
+ . z cat y offsets :
+ z CAT text (font. y offsets ISUB 1);
+ FOR index FROM 2 UPTO LENGTH font. y offsets DIV int length
+ REP z CAT ", ";
+ z CAT text (font. y offsets ISUB index);
+ PER;
+
+ . put font pitches and replacements :
+ BOOL VAR ausgabe := FALSE;
+ replacements length := LENGTH font table. replacements;
+ put z;
+ z CAT " ";
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ pitch := font. pitch table (char code 1);
+ reset bit (pitch, highest bit);
+ link nr := font. replacements table (char code 1);
+ reset bit (link nr, highest bit);
+ IF (pitch <> font. indentation pitch) OR
+ (link nr > replacements length AND link nr <> maxint)
+ THEN put font char pitch and replacement;
+ IF ausgabe
+ THEN put z;
+ ausgabe := FALSE;
+ ELSE ausgabe := TRUE;
+ FI;
+ z CAT " ";
+ FI;
+ PER;
+ IF ausgabe THEN put z ELSE z := " " FI;
+
+ . put font char pitch and replacement :
+ put char code;
+ put font char pitch;
+ IF link nr > replacements length AND link nr <> maxint
+ THEN put font replacement;
+ IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI;
+ ELIF ausgabe
+ THEN z CAT ";"
+ ELSE z CAT "; ";
+ FI;
+
+ . put font char pitch :
+ IF pitch = max int
+ THEN char pos := pos (font. extension chars, code (char code));
+ IF char pos <> 0
+ THEN pitch := font table. extensions
+ (font. extension indexes ISUB char pos). std pitch
+ FI;
+ FI;
+ put char pitch;
+
+ . put font replacement :
+ link nr DECR replacements length;
+ replacement := subtext (font. replacements, link nr + 1,
+ link nr + code (font. replacements SUB link nr) );
+ put replacement;
+
+ . put font extensions :
+ IF font. extension chars <> ""
+ THEN FOR index FROM 1 UPTO LENGTH font. extension chars
+ REP put font extension PER;
+ FI;
+
+ . put font extension :
+ check file overflow;
+ put z;
+ z CAT " EXTENSION : """"";
+ z CAT text 3 (code (font. extension chars SUB index));
+ z CAT """"";";
+ put z; put z; z CAT " ";
+ detemine replacements length;
+ extension nr := font. extension indexes ISUB index;
+ ausgabe := FALSE;
+ FOR char code FROM 0 UPTO 255
+ REP char code 1 := char code + 1;
+ pitch := extension. pitch table (char code 1);
+ link nr := extension. replacements table (char code 1);
+ IF pitch <> extension. std pitch OR link nr > replacements length
+ THEN put extension char pitch and replacement;
+ IF ausgabe
+ THEN put z;
+ ausgabe := FALSE;
+ ELSE ausgabe := TRUE;
+ FI;
+ z CAT " ";
+ FI;
+ PER;
+ IF ausgabe THEN put z ELSE z := " " FI;
+
+ . detemine replacements length :
+ char pos := pos (font table. extension chars,
+ font. extension chars SUB index);
+ IF char pos <> 0
+ THEN replacements length := LENGTH font table. extensions
+ (font table. extension indexes ISUB char pos). replacements;
+ ELSE replacements length := 0;
+ FI;
+
+ . put extension char pitch and replacement :
+ put char code;
+ put char pitch;
+ IF link nr > replacements length
+ THEN put extension replacement;
+ IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI;
+ ELIF ausgabe
+ THEN z CAT ";"
+ ELSE z CAT "; ";
+ FI;
+
+. put extension replacement :
+ link nr DECR replacements length;
+ replacement := subtext (extension. replacements, link nr + 1,
+ link nr + code (extension. replacements SUB link nr) );
+ put replacement;
+
+. put char code :
+ IF (char code >= 32 AND char code <= 122) OR
+ (char code >= 214 AND char code <= 223) OR
+ char code = 124 OR char code = 126 OR char code = 251
+ THEN z CAT "(* ";
+ z CAT code (char code);
+ z CAT " *) """"";
+ ELSE z CAT " """"";
+ FI;
+ z CAT text 3 (char code);
+ z CAT """""";
+
+. put char pitch :
+ z CAT ",";
+ z CAT text (pitch, 5);
+
+. put replacement :
+ decode (replacement);
+ z CAT ", """;
+ z CAT replacement;
+ z CAT """;"
+
+END PROC create font file;
+
+
+PROC put z :
+
+ putline (font file, z);
+ cout (lines (font file));
+ z := " ";
+
+END PROC put z;
+
+
+PROC decode (TEXT VAR string) :
+
+ INT VAR p;
+ change all (string, """", """""");
+ p := pos (string, ""0"", ""31"", 1);
+ WHILE p <> 0
+ REP change (string, p, p, """" + text (code(string SUB p)) + """");
+ p := pos (string, ""0"", ""31"", p);
+ PER;
+ p := pos (string, ""127"", ""255"", 1);
+ WHILE p <> 0
+ REP change (string, p, p, """" + text (code(string SUB p)) + """");
+ p := pos (string, ""127"", ""255"", p);
+ PER;
+
+END PROC decode;
+
+
+TEXT PROC text 3 (INT CONST value) :
+
+ buffer := text (value, 3);
+ change all (buffer, " ", "0");
+ buffer
+
+END PROC text 3;
+
+END PACKET font convertor;
+
diff --git a/system/std.zusatz/1.8.7/src/free channel b/system/std.zusatz/1.8.7/src/free channel
new file mode 100644
index 0000000..3814f9d
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/free channel
@@ -0,0 +1,430 @@
+PACKET free channel DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 10.06.86 *)
+ FCHANNEL ,
+ := ,
+ free channel ,
+ open ,
+ close ,
+ out ,
+ in ,
+ dialogue ,
+ save ,
+ fetch :
+
+
+
+LET ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ empty message code = 256 ,
+ long message code = 257 ,
+ file send code = 1024 ,
+ file receive code = 2048 ,
+ open code = 1000 ,
+ close code = 1001 ,
+
+ file type = 1003 ;
+
+INT CONST task not existing := - 1 ;
+
+
+TYPE FCHANNEL = STRUCT (TASK server, TEXT input buffer, server name) ;
+
+INT VAR message code , response code ;
+TASK VAR partner ;
+DATASPACE VAR ds ;
+
+BOUND TEXT VAR msg ;
+TEXT VAR response, char, esc char , record ;
+
+FILE VAR file ;
+
+
+OP := (FCHANNEL VAR dest, FCHANNEL CONST source) :
+
+ dest.server := source.server ;
+ dest.input buffer := "" ;
+ dest.server name := source.server name ;
+ open (dest)
+
+ENDOP := ;
+
+FCHANNEL PROC free channel (TEXT CONST channel name) :
+
+ FCHANNEL:(niltask,"", channel name)
+
+ENDPROC free channel ;
+
+PROC open (FCHANNEL VAR channel) :
+
+ INT VAR receipt ;
+
+ initialize message dataspace ;
+ send open code ;
+ IF receipt <> ack
+ THEN errorstop ("channel not free")
+ FI .
+
+initialize message dataspace :
+ forget (ds) ;
+ ds := nilspace .
+
+send open code :
+ ping pong (channel.server, open code, ds, receipt) ;
+ IF receipt = task not existing
+ THEN channel.server := task (channel.server name) ;
+ ping pong (channel.server, open code, ds, receipt)
+ FI .
+
+ENDPROC open ;
+
+PROC close (FCHANNEL VAR channel) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ call (channel.server, close code, ds, response code)
+
+ENDPROC close ;
+
+PROC close (TEXT CONST channel server) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ call (task (channel server), close code, ds, response code)
+
+ENDPROC close ;
+
+
+PROC out (FCHANNEL VAR channel, TEXT CONST message) :
+
+ send message ;
+ get response .
+
+send message :
+ IF message = ""
+ THEN call (channel.server, empty message code, ds, response code)
+ ELSE msg := ds ;
+ CONCR (msg) := message ;
+ call (channel.server, long message code, ds, response code)
+ FI .
+
+get response :
+ IF response code < 0
+ THEN errorstop ("channel not ready")
+ ELIF response code < 256
+ THEN channel.input buffer CAT code (response code)
+ ELIF response code = long message code
+ THEN msg := ds ;
+ channel.input buffer CAT CONCR (msg)
+ FI .
+
+ENDPROC out ;
+
+PROC in (FCHANNEL VAR channel, TEXT VAR response) :
+
+ out (channel, "") ;
+ response := channel.input buffer ;
+ channel.input buffer := ""
+
+ENDPROC in ;
+
+PROC save (FCHANNEL VAR channel, TEXT CONST file name, control chars) :
+
+ prepare ds ;
+ call (channel.server, file send code, ds, response code) ;
+ IF response code = error nak
+ THEN BOUND TEXT VAR error msg := ds ;
+ errorstop (error msg)
+ FI .
+
+prepare ds :
+ forget (ds) ;
+ ds := old (file name, file type) ;
+ FILE VAR f := sequential file (modify, ds) ;
+ headline (f, control chars) .
+
+ENDPROC save ;
+
+PROC fetch (FCHANNEL VAR channel, TEXT CONST file name, control chars) :
+
+ IF NOT exists (file name) COR yes ("""" + file name + """ loeschen")
+ THEN fetch first part ;
+ WHILE more to fetch REP
+ fetch next part
+ PER
+ FI .
+
+fetch first part :
+ INT VAR part := 0 ;
+ receive file (channel, file name, control chars) .
+
+fetch next part :
+ part INCR 1 ;
+ receive file (channel, file name + "." + text (part), control chars) .
+
+more to fetch : response code = file receive code .
+
+ENDPROC fetch ;
+
+PROC receive file (FCHANNEL VAR channel,TEXT CONST file name, control chars):
+
+ prepare ds ;
+ call (channel.server, file receive code, ds, response code);
+ IF response code = error nak
+ THEN BOUND TEXT VAR error msg := ds ;
+ errorstop (error msg)
+ ELSE forget (file name, quiet) ;
+ copy (ds, file name) ;
+ forget (ds) ;
+ ds := nilspace ;
+ FI .
+
+prepare ds :
+ forget (ds) ;
+ ds := nilspace ;
+ BOUND TEXT VAR ctl := ds ;
+ ctl := control chars .
+
+ENDPROC receive file ;
+
+
+PROC dialogue (FCHANNEL CONST channel, TEXT CONST esc) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ partner := channel.server ;
+ esc char := esc ;
+ enable stop ;
+
+ response code := empty message code ;
+ REP
+ get and send message charety ;
+ out response option
+ PER .
+
+get and send message charety :
+ IF response code = empty message code
+ THEN char := incharety (10)
+ ELSE char := incharety
+ FI ;
+ IF char = ""
+ THEN call (partner, empty message code, ds, response code)
+ ELIF char = esc char
+ THEN LEAVE dialogue
+ ELSE call (partner, code (char), ds, response code)
+ FI .
+
+out response option :
+ IF response code < 256
+ THEN out (code (response code))
+ ELIF response code = long message code
+ THEN msg := ds ;
+ out (CONCR (msg))
+ FI .
+
+ENDPROC dialogue ;
+
+PROC free channel (INT CONST nr) :
+
+ INT CONST my channel := nr ;
+ break ;
+ disable stop ;
+ REP
+ wait (ds, message code, partner) ;
+ IF message code = open code
+ THEN connect to my channel ;
+ use channel ;
+ break (quiet)
+ ELIF message code >= 0
+ THEN send (partner, nak, ds)
+ FI
+ PER .
+
+use channel :
+ ping pong (partner, ack, ds, message code) ;
+ WHILE message code <> close code AND message code >= 0 REP
+ IF message code <= long message code THEN dialogue
+ ELIF message code = file receive code THEN receive file
+ ELIF message code = file send code THEN send file
+ ELIF message code = open code THEN ignore open
+ ELSE errorstop ("falsche Sendung")
+ FI
+ UNTIL is error PER ;
+ IF is error
+ THEN send error message
+ ELSE send handshake ack
+ FI .
+
+dialogue :
+ IF message code < 256
+ THEN out (code (message code))
+ ELIF message code = long message code
+ THEN msg := ds ;
+ out (CONCR (msg))
+ FI ;
+ response := incharety (1) ;
+ IF response = ""
+ THEN ping pong (partner, empty message code, ds, message code)
+ ELSE short or long response
+ FI .
+
+short or long response :
+ char := incharety ;
+ IF char = ""
+ THEN short response
+ ELSE long response
+ FI .
+
+short response :
+ ping pong (partner, code (response), ds, message code) .
+
+long response :
+ msg := ds ;
+ response CAT char ;
+ msg := response ;
+ REP
+ cat input (msg, char) ;
+ msg CAT char
+ UNTIL char = "" OR LENGTH msg > 500 PER ;
+ ping pong (partner, long message code, ds, message code) .
+
+connect to my channel :
+ continue (my channel) ;
+ WHILE is error REP
+ clear error ;
+ pause (100) ;
+ continue (my channel)
+ PER .
+
+send handshake ack :
+ send (partner, ack, ds) .
+
+send error message :
+ forget (ds) ;
+ ds := nilspace ;
+ BOUND TEXT VAR error msg := ds ;
+ error msg := error message ;
+ clear error ;
+ send (partner, error nak, ds) .
+
+ignore open :
+ ping pong (partner, ack, ds, message code) .
+
+ENDPROC free channel ;
+
+PROC send file :
+
+ enable stop ;
+ file := sequential file (input,ds) ;
+ get control chars ;
+ skip chars ;
+ REP
+ getline (file, record) ;
+ out (record) ;
+ end of line
+ UNTIL eof (file) PER ;
+ end of transmission ;
+ send ack reply .
+
+get control chars :
+ TEXT CONST
+ control chars := headline (file) ,
+ end of file char := control chars SUB 1 ,
+ end of line char := control chars SUB 2 ,
+ handshake char := control chars SUB 3 .
+
+end of line :
+ out (end of line char) ;
+ IF handshake char <> ""
+ THEN wait for handshake
+ FI .
+
+wait for handshake :
+ REP
+ char := incharety (300) ;
+ IF char = ""
+ THEN errorstop ("timeout")
+ FI
+ UNTIL char = handshake char PER .
+
+end of transmission :
+ skip chars ;
+ out (end of file char) .
+
+skip chars :
+ WHILE incharety (3) <> "" REP PER .
+
+send ack reply :
+ forget (ds) ;
+ ds := nilspace ;
+ ping pong (partner, ack, ds, message code) .
+
+ENDPROC send file ;
+
+PROC receive file :
+
+ enable stop ;
+ get control chars ;
+ open file ;
+ INT VAR line no := 0 ;
+ REP
+ receive line ;
+ IF eof received
+ THEN ping pong (partner, ack, ds, message code) ;
+ LEAVE receive file
+ FI ;
+ putline (file, record) ;
+ line no INCR 1
+ UNTIL near file overflow PER ;
+ ping pong (partner, file receive code, ds, message code) .
+
+get control chars :
+ BOUND TEXT VAR control chars := ds ;
+ TEXT CONST
+ end of file char := control chars SUB 1 ,
+ end of line char := control chars SUB 2 ,
+ handshake char := control chars SUB 3 ,
+ handshake prompt := control chars SUB 4 .
+
+open file :
+ forget (ds) ;
+ ds := nilspace ;
+ file := sequential file (output, ds) .
+
+receive line :
+ record := "" ;
+ REP
+ cat input (record, char) ;
+ IF char = ""
+ THEN wait for char
+ FI ;
+ IF char = handshake prompt THEN out (handshake char)
+ ELIF char = ""9"" THEN expand tabs
+ ELIF char = ""12"" THEN page
+ FI
+ UNTIL char = end of line char OR char = end of file char PER .
+
+wait for char :
+ char := incharety (300) ;
+ IF char = ""
+ THEN errorstop ("timeout")
+ ELIF char >= ""32""
+ THEN record CAT char
+ FI .
+
+expand tabs:
+ record CAT (8-(LENGTH record MOD 8)) * " " .
+
+page:
+ record := "#page# " .
+
+eof received :
+ char = end of file char OR (record SUB LENGTH record ) = end of file char .
+
+near file overflow :
+ line no > 3999 OR (line no > 3800 AND record = "#page# ") .
+
+ENDPROC receive file ;
+
+ENDPACKET free channel ;
+
diff --git a/system/std.zusatz/1.8.7/src/longint b/system/std.zusatz/1.8.7/src/longint
new file mode 100644
index 0000000..e78bb52
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/longint
@@ -0,0 +1,423 @@
+PACKET longint DEFINES LONGINT, (* Autoren: S.Baumann,A.Bentrup *)
+ :=, (* T.Sillke *)
+ <, (* Stand: 17.03.81 *)
+ >,
+ <=,
+ >=,
+ <>,
+ =,
+ -,
+ +,
+ *,
+ **,
+ ABS,
+ abs,
+ DECR,
+ DIV,
+ get,
+ INCR,
+ int,
+ (*last rest,*)
+ longint,
+ max,
+ max longint,
+ min,
+ MOD,
+ put,
+ random,
+ SIGN,
+ sign,
+ text,
+ zero:
+
+TYPE LONGINT = TEXT;
+
+LONGINT VAR result,aleft,aright;
+TEXT VAR ergebnis,x,y,z,h;
+INT VAR v byte,slr,sll;
+INT CONST snull :: code("0"), mtl :: 300 ;
+TEXT CONST negativ :: code(127),max digit :: code(99),null :: code(0),
+ overflow :: "LONGINT overflow",eins :: code(1);
+BOOL VAR vorl,vorr,vleft,vright;
+
+OP := (LONGINT VAR left, LONGINT CONST right) :
+ CONCR(left) := CONCR(right)
+END OP :=;
+
+BOOL OP < (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr > sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) < CONCR(right)
+ ELSE CONCR(left) > CONCR(right) FI
+ FI
+END OP < ;
+
+BOOL OP > (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr < sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) > CONCR(right)
+ ELSE CONCR(left) < CONCR(right) FI
+ FI
+END OP > ;
+
+BOOL OP <= (LONGINT CONST left,right) :
+ NOT (left > right)
+END OP <=;
+
+BOOL OP >= (LONGINT CONST left,right) :
+ NOT (left < right)
+END OP >=;
+
+BOOL OP <> (LONGINT CONST left,right) :
+ CONCR (left) <> CONCR (right)
+END OP <>;
+
+BOOL OP = (LONGINT CONST left,right) :
+ CONCR (left) = CONCR (right)
+END OP = ;
+
+LONGINT OP - (LONGINT CONST arg) :
+ SELECT code(CONCR(arg)SUB1) OF
+ CASE 0 : zero
+ CASE 127: LONGINT : (subtext(CONCR(arg),2))
+ OTHERWISE LONGINT : (negativ + CONCR(arg))
+ END SELECT
+END OP -;
+
+LONGINT OP + (LONGINT CONST arg) : arg END OP +;
+
+LONGINT OP - (LONGINT CONST left,right) :
+ IF CONCR(left ) = null THEN LEAVE - WITH -right
+ ELIF CONCR(right) = null THEN LEAVE - WITH left
+ ELIF sign(left) <> sign(right) THEN LEAVE - WITH left + (-right) FI;
+ betrag(left,right);
+ BOOL CONST betrag max :: aleft > aright;
+ IF betrag max
+ THEN result := LONGINT : (CONCR(aleft ) SUB CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) SUB CONCR(aleft )) FI;
+ kuerze fuehrende nullen(CONCR(result),null);
+ IF vleft XOR betrag max THEN -result ELSE result FI
+END OP -;
+
+LONGINT OP + (LONGINT CONST left,right) :
+ IF sign(left) <> sign(right) THEN LEAVE + WITH left - (-right) FI;
+ betrag(left,right);
+ IF aleft > aright
+ THEN result := LONGINT : (CONCR(aleft ) ADD CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) ADD CONCR(aleft )) FI;
+ IF vleft THEN result ELSE -result FI
+END OP +;
+
+LONGINT OP * (LONGINT CONST left,right) :
+ IF CONCR(left) = null OR CONCR(right) = null THEN LEAVE * WITH zero
+ ELIF length(left) + length(right) > mtl THEN errorstop (overflow) FI;
+ betrag(left,right);
+ IF aleft < aright
+ THEN result := LONGINT : (CONCR(aright) MUL CONCR(aleft ))
+ ELSE result := LONGINT : (CONCR(aleft ) MUL CONCR(aright)) FI;
+ IF length(CONCR(result)) = mtl THEN errorstop(overflow) FI;
+ IF vleft XOR vright THEN -result ELSE result FI
+END OP *;
+
+LONGINT OP ** (LONGINT CONST arg,exp) :
+ IF exp > longint(max int) THEN errorstop (overflow) FI;
+ arg ** int(exp)
+END OP **;
+
+LONGINT OP ** (LONGINT CONST arg,INT CONST exp) :
+ IF exp < 0 THEN errorstop ("LONGINT OP ** : negativ exp")
+ ELIF CONCR(arg)=null AND exp=0 THEN errorstop(text(0 ** 0)) FI;
+ IF exp = 0 THEN one
+ ELIF exp = 1 THEN arg
+ ELIF sign(arg) = -1 AND exp MOD 2 <> 0
+ THEN -LONGINT:(CONCR(abs(arg))EXPexp)
+ ELSE LONGINT:(CONCR(abs(arg))EXPexp) FI
+END OP **;
+
+LONGINT OP ABS (LONGINT CONST arg) : abs(arg) END OP ABS;
+
+LONGINT PROC abs (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN LONGINT:(subtext(CONCR(a),2)) ELSE a FI
+END PROC abs;
+
+OP DECR (LONGINT VAR result,LONGINT CONST ab) :
+ result := result - ab;
+END OP DECR;
+
+LONGINT OP DIV (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN error stop("LONGINT OP DIV by zero") FI;
+ betrag(left,right); h := CONCR(aright);
+ y := null + CONCR(aleft ); vorl := vleft;
+ z := null + CONCR(aright); vorr := vright;
+ IF aleft < aright THEN y:=CONCR(aleft); LEAVE DIV WITH zero FI;
+ INT VAR try,i,cr1 :: code(z SUB 2),cr2,cr3,zw;
+ BOOL VAR sh :: length(z) <> 2;
+ IF sh THEN cr3:=code(zSUB3); cr2:=10*cr1+cr3DIV10; cr3:=100*cr1+cr3 FI;
+ CONCR(result) := "";
+ FOR i FROM 0 UPTO length(y)-length(z) REP
+ laufe eine abschaetzung durch;
+ CONCR (result) CAT code(try)
+ PER; kuerze fuehrende nullen(y,null);
+ IF(CONCR(result)SUB1)=nullTHEN CONCR(result):=subtext(CONCR(result),2)FI;
+ IF vleft XOR vright THEN -result ELSE result FI.
+
+ laufe eine abschaetzung durch :
+ zw := 100*code(y SUB i+1) + code(y SUB i+2);
+ IF zw < 3276 AND sh THEN IF zw < 327
+ THEN try := min((100*zw + code(ySUBi+3)) DIV cr3, 99)
+ ELSE try := min(( 10*zw + code(ySUBi+3)DIV10)DIV cr2, 99) FI
+ ELSE try := min( zw DIV cr1, 99) FI;
+ x := z MUL code(try);
+ WHILE x > subtext(y,i+1,i+length(x)) REP
+ try DECR 1; x := x SUB z PER;
+ replace(y,i + 1,subtext(y,i + 1,i + length(x)) SUB x)
+END OP DIV;
+
+PROC get (LONGINT VAR result) :
+ get (ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+PROC get (FILE VAR file,LONGINT VAR result) :
+ get(file,ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+OP INCR (LONGINT VAR result,LONGINT CONST dazu) :
+ result := result + dazu;
+END OP INCR;
+
+INT PROC int (LONGINT CONST longint) :
+ IF length(longint) > 3
+ THEN max int + 1
+ ELSE ergebnis := (3-length(longint))*null + CONCR(abs(longint));
+ (code(ergebnis SUB 1) * 10000 +
+ code(ergebnis SUB 2) * 100 +
+ code(ergebnis SUB 3)) * sign(longint)
+ FI
+END PROC int;
+
+LONGINT PROC longint (INT CONST int) :
+ CONCR(result) := code( abs(int) DIV 10000) +
+ code((abs(int) MOD 10000) DIV 100) +
+ code( abs(int) MOD 100);
+ kuerze fuehrende nullen (CONCR(result),null);
+ IF int < 1 THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC longint (TEXT CONST text) :
+ INT VAR i;
+ ergebnis := compress(text);
+ BOOL VAR minus :: (ergebnisSUB1) = "-";
+ IF (ergebnisSUB1)="+" OR minus THEN ergebnis:=subtext(ergebnis,2) FI;
+ kuerze fuehrende nullen(ergebnis,"0");
+ kuerze die unzulaessigen zeichen aus ergebnis;
+ schreibe ergebnis im hundertersystem in result;
+ result mit vorzeichen.
+
+ kuerze die unzulaessigen zeichen aus ergebnis :
+ ergebnis := subtext(ergebnis,1,letztes zulaessiges zeichen).
+ letztes zulaessiges zeichen :
+ FOR i FROM 1 UPTO length(ergebnis) REP
+ UNTIL pos("0123456789", ergebnis SUB i) = 0 PER;
+ i - 1.
+ schreibe ergebnis im hundertersystem in result :
+ sll := length(ergebnis);
+ IF sll MOD 2 <> 0 THEN ergebnis := "0"+ergebnis; sll INCR 1 FI;
+ i := 1; CONCR(result) := "";
+ REP schreibe ein zeichen im hundertersystem in result;
+ i INCR 2
+ UNTIL i >= sll PER.
+ schreibe ein zeichen im hundertersystem in result :
+ CONCR(result) CAT code((code(ergebnis SUB i ) - snull) * 10 +
+ code(ergebnis SUB i + 1) - snull).
+ result mit vorzeichen :
+ IF ergebnis="" THEN zero ELIF minus THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC max (LONGINT CONST left,right) :
+ IF left > right THEN left ELSE right FI
+END PROC max;
+
+LONGINT PROC max longint :
+ LONGINT : ((mtl - 1) * max digit)
+END PROC max longint;
+
+LONGINT PROC min (LONGINT CONST left,right) :
+ IF left < right THEN left ELSE right FI
+END PROC min;
+
+LONGINT OP MOD (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN errorstop("LONGINT OP MOD by zero") FI;
+ result := left DIV right; last rest
+END OP MOD;
+
+PROC put (LONGINT CONST longint) :
+ INT VAR i :: 1,zwei ziffern;
+ IF sign(longint) = -1 THEN out("-"); i:=2 FI;
+ out(text(code(CONCR(longint) SUB i)));
+ FOR i FROM i + 1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ out(code(zwei ziffern DIV 10 + snull));
+ out(code(zwei ziffern MOD 10 + snull));
+ PER;out(" ")
+END PROC put;
+
+PROC put (FILE VAR file,LONGINT CONST longint) :
+ put(file,text(longint));
+END PROC put;
+
+LONGINT PROC random (LONGINT CONST lower bound,upper bound) :
+ INT VAR i; x := CONCR(upper bound - lower bound - one); y := "";
+ FOR i FROM 1 UPTO length(x) REP y CAT code(random(0,99)) PER;
+ upper bound - (LONGINT : (y) MOD LONGINT : (x))
+END PROC random;
+
+INT OP SIGN (LONGINT CONST arg) : sign(arg) END OP SIGN;
+
+INT PROC sign (LONGINT CONST arg) :
+ SELECT code(CONCR(arg) SUB 1) OF
+ CASE 0 : 0
+ CASE 127 : -1
+ OTHERWISE 1
+ END SELECT
+END PROC sign;
+
+TEXT PROC text (LONGINT CONST longint) :
+ INT VAR i::1,zwei ziffern; ergebnis := "";
+ IF sign(longint) = -1 THEN ergebnis := "-"; i:=2 FI;
+ ergebnis CAT text (code (CONCR (longint) SUB i ) ) ;
+ FOR i FROM i+1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ ergebnis CAT code(zwei ziffern DIV 10 + snull);
+ ergebnis CAT code(zwei ziffern MOD 10 + snull)
+ PER; ergebnis
+END PROC text;
+
+TEXT PROC text (LONGINT CONST longint,INT CONST length) :
+ x := text(longint); sll := LENGTH x;
+ IF sll > length THEN length * "*" ELSE (length - sll)*" " + x FI
+END PROC text;
+
+LONGINT PROC last rest :
+ IF y=null THEN LEAVE last rest WITH zero FI;
+ IF vorl XOR vorr THEN y := h SUB y; kuerze fuehrende nullen(y,null);
+ vorl := TRUE FI;
+ IF NOTvorr THEN y:=negativ+y; vorr := TRUE FI; LONGINT:(y)
+END PROC last rest;
+
+LONGINT PROC zero : LONGINT : (null) END PROC zero;
+LONGINT PROC one : LONGINT : (""1"") END PROC one;
+
+
+(* ----------------------- INTERNE HILFSPROZEDUREN ----------------------- *)
+
+TEXT OP ADD (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der addition)
+ PER;
+ IF carrybit = 1 THEN addiere den uebertrag FI;
+ ergebnis.
+
+ das result der addition :
+ v byte := (code(left SUB i) + code(right SUB i - dif) + carrybit);
+ IF v byte > 99
+ THEN carrybit := 1; code(v byte - 100)
+ ELSE carrybit := 0; code(v byte)
+ FI.
+ addiere den uebertrag :
+ FOR i FROM i DOWNTO 1
+ WHILE (ergebnis SUB i) >= max digit REP
+ replace(ergebnis,i,null)
+ PER;
+ IF (ergebnis SUB 1) = null OR dif = 0
+ THEN pruefe auf longint overflow
+ ELSE replace(ergebnis,i,code(code(ergebnis SUB i) + 1))
+ FI.
+ pruefe auf longint overflow :
+ IF length(ergebnis) = mtl - 1 THEN errorstop(overflow) FI;
+ ergebnis := eins + ergebnis
+END OP ADD;
+
+PROC betrag (LONGINT CONST a, b) :
+ vleft := (CONCR(a)SUB1)<>negativ; vright := (CONCR(b)SUB1)<>negativ;
+ IF vleft THEN aleft :=a ELSE CONCR(aleft ):=subtext(CONCR(a),2) FI;
+ IF vright THEN aright:=b ELSE CONCR(aright):=subtext(CONCR(b),2) FI
+END PROC betrag;
+
+TEXT OP EXP (TEXT CONST arg,INT CONST exp) :
+ INT VAR zaehler :: exp;
+ x := arg; z := eins;
+ REP IF zaehler MOD 2 = 1 THEN z := z MUL x FI;
+ zaehler := zaehler DIV 2; x := x MUL x
+ UNTIL zaehler = 1 PER;
+ x MUL z
+END OP EXP;
+
+PROC kuerze fuehrende nullen ( TEXT VAR text,TEXT CONST snull) :
+ INT VAR i;
+ text := subtext(text,erste nicht snull).
+
+ erste nicht snull :
+ FOR i FROM 1 UPTO length (text) - 1 REP
+ UNTIL (text SUB i) <> snull PER;
+ i
+END PROC kuerze fuehrende nullen;
+
+INT PROC length (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN length(CONCR(a))-1 ELSE length(CONCR(a)) FI
+END PROC length;
+
+TEXT OP MUL (TEXT CONST left,right) :
+ INT VAR i,j,carrybit,v,w;
+ ergebnis := (length(left) + length(right) - 1) * null;
+ FOR i FROM length(ergebnis) DOWNTO length(left) REP
+ v := i - length(left); w := length(right) - length(ergebnis) + i;
+ carrybit := 0;
+ FOR j FROM length(left) DOWNTO 1 REP
+ replace(ergebnis,v + j,result der addition)
+ PER;
+ replace(ergebnis,v,code(code(ergebnis SUB v) + carrybit));
+ PER;
+ IF carrybit = 0 THEN ergebnis ELSE code(carrybit) + ergebnis FI.
+
+ result der addition :
+ v byte := code(right SUB w) * code(left SUB j) + carrybit +
+ code(ergebnis SUB v + j);
+ carrybit := v byte DIV 100;
+ code(v byte MOD 100)
+END OP MUL;
+
+TEXT OP SUB (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der subtraktion);
+ PER;
+ IF carrybit = 1 THEN subtrahiere den uebertrag FI;
+ ergebnis.
+
+ das result der subtraktion :
+ v byte := (code(left SUB i) - code(right SUB i - dif) - carrybit);
+ IF v byte < 0
+ THEN carrybit := 1;code(v byte + 100)
+ ELSE carrybit := 0;code(v byte)
+ FI.
+ subtrahiere den uebertrag :
+ FOR i FROM i DOWNTO 2
+ WHILE (ergebnis SUB i) = null REP
+ replace(ergebnis,i,max digit)
+ PER;
+ replace(ergebnis,i,code(code(ergebnis SUB i) - 1))
+END OP SUB;
+
+END PACKET longint;
+
diff --git a/system/std.zusatz/1.8.7/src/matrix b/system/std.zusatz/1.8.7/src/matrix
new file mode 100644
index 0000000..d9de9fb
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/matrix
@@ -0,0 +1,482 @@
+PACKET matrix DEFINES MATRIX, matrix, idn, (* Stand : 16.06.86 wk *)
+ :=, sub, (* Autor : H.Indenbirken *)
+ row, column,
+ COLUMNS,
+ ROWS,
+ DET,
+ INV,
+ TRANSP,
+ transp,
+ replace row, replace column,
+ replace element,
+ get, put,
+ =, <>,
+ +, -, * :
+
+TYPE MATRIX = STRUCT (INT rows, columns, VECTOR elems);
+TYPE INITMATRIX = STRUCT (INT rows, columns, REAL value, BOOL idn);
+
+MATRIX VAR a :: idn (1);
+INT VAR i;
+
+(****************************************************************************
+PROC dump (MATRIX CONST m) :
+ put line (text (m.rows) + " Reihen, " + text (m.columns) + " Spalten.");
+ dump (m.elems) .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (MATRIX VAR l, MATRIX CONST r) :
+ CONCR (l) := CONCR (r);
+END OP :=;
+
+OP := (MATRIX VAR l, INITMATRIX CONST r) :
+ l.rows := r.rows;
+ l.columns := r.columns;
+ l.elems := vector (r.rows*r.columns, r.value);
+ IF r.idn
+ THEN idn FI .
+
+idn :
+ INT VAR i;
+ FOR i FROM 1 UPTO r.rows
+ REP replace (l.elems, calc pos (l.columns, i, i), 1.0) PER
+
+END OP :=;
+
+INITMATRIX PROC matrix (INT CONST rows, columns, REAL CONST value) :
+ IF rows <= 0
+ THEN errorstop ("PROC matrix : rows <= 0")
+ ELIF columns <= 0
+ THEN errorstop ("PROC matrix : columns <= 0") FI;
+
+ INITMATRIX : (rows, columns, value, FALSE)
+
+END PROC matrix;
+
+INITMATRIX PROC matrix (INT CONST rows, columns) :
+ matrix (rows, columns, 0.0)
+
+END PROC matrix;
+
+INITMATRIX PROC idn (INT CONST size) :
+ IF size <= 0
+ THEN errorstop ("MATRIX PROC idn : size <= 0") FI;
+
+ INITMATRIX : (size, size, 0.0, TRUE)
+
+END PROC idn;
+
+VECTOR PROC row (MATRIX CONST m, INT CONST i) :
+ VECTOR VAR v :: vector (m.columns);
+ INT VAR j, k :: 1, pos :: (i-1) * m.columns;
+ FOR j FROM pos+1 UPTO pos + m.columns
+ REP replace (v, k, m.elems SUB j);
+ k INCR 1
+ PER;
+ v
+
+END PROC row;
+
+VECTOR PROC column (MATRIX CONST m, INT CONST j) :
+ VECTOR VAR v :: vector (m.rows);
+ INT VAR i, k :: j;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (v, i, m.elems SUB k);
+ k INCR m.columns
+ PER;
+ v
+
+END PROC column;
+
+INT OP COLUMNS (MATRIX CONST m) :
+ m.columns
+
+END OP COLUMNS;
+
+INT OP ROWS (MATRIX CONST m) :
+ m.rows
+
+END OP ROWS;
+
+REAL PROC sub (MATRIX CONST a, INT CONST row, column) :
+ a.elems SUB calc pos (a.columns, row, column)
+
+END PROC sub;
+
+PROC replace row (MATRIX VAR m, INT CONST rowindex, VECTOR CONST rowvalue) :
+ test ("PROC replace row : ", "LENGTH rowvalue", "COLUMNS m",
+ LENGTH rowvalue, m.columns);
+ test ("PROC replace row : row ", rowindex, m.rows);
+
+ INT VAR i, pos :: (rowindex-1) * m.columns;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (m.elems, pos+i, rowvalue SUB i) PER
+
+END PROC replace row;
+
+PROC replace column (MATRIX VAR m, INT CONST columnindex,
+ VECTOR CONST columnvalue) :
+ test ("PROC replace column : ", "LENGTH columnvalue", "ROWS m",
+ LENGTH columnvalue, m.rows);
+ test ("PROC replace column : column ", columnindex, m.columns);
+
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (m.elems, calc pos (m.columns, i, columnindex),
+ columnvalue SUB i) PER
+
+END PROC replace column;
+
+PROC replace element (MATRIX VAR a, INT CONST row, column, REAL CONST x) :
+ test ("PROC replace element : row ", row, a.rows);
+ test ("PROC replace element : column ", column, a.columns);
+ replace (a.elems, calc pos (a.columns, row, column), x)
+
+END PROC replace element;
+
+BOOL OP = (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN FALSE
+ ELIF l.columns <> r.columns
+ THEN FALSE
+ ELSE l.elems = r.elems FI
+
+END OP =;
+
+BOOL OP <> (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN TRUE
+ ELIF l.columns <> r.columns
+ THEN TRUE
+ ELSE l.elems <> r.elems FI
+
+END OP <>;
+
+INT PROC calc pos (INT CONST columns, z, s) :
+ (z-1) * columns + s
+END PROC calc pos;
+
+MATRIX OP + (MATRIX CONST m) :
+ m
+
+END OP +;
+
+MATRIX OP + (MATRIX CONST l, r) :
+ test ("MATRIX OP + : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP + : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) + (r.elems SUB i))
+ PER;
+ a
+
+END OP +;
+
+MATRIX OP - (MATRIX CONST m) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, -a.elems SUB i)
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP - (MATRIX CONST l, r) :
+ test ("MATRIX OP - : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP - : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) - (r.elems SUB i))
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP * (REAL CONST x, MATRIX CONST m) :
+ m*x
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST m, REAL CONST x) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, x*m.elems SUB i) PER;
+ a
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, MATRIX CONST m) :
+ test ("VECTOR OP * : ", "LENGTH v", "ROWS m", LENGTH v, m.rows);
+ VECTOR VAR result :: vector (m.columns); (*wk*)
+ INT VAR i;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (result, i, v * column (m, i)) PER;
+ result .
+
+END OP *;
+
+VECTOR OP * (MATRIX CONST m, VECTOR CONST v) :
+ test ("VECTOR OP * : ", "COLUMNS m", "LENGTH v", COLUMNS m, LENGTH v);
+ VECTOR VAR result :: vector (m.rows); (*wk*)
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (result, i, row (m, i) * v) PER;
+ result .
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST l, r) :
+ test ("MATRIX OP * : ","COLUMNS l","ROWS r", l.columns, r.rows);
+
+ a.rows := l.rows;
+ a.columns := r.columns;
+ a.elems := vector (a.rows*a.columns)
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP VECTOR VAR rl :: row (l, i), cr :: column (r, j);
+ replace (a.elems, calc pos (a.columns, i, j), rl * cr)
+ PER
+ PER;
+ a .
+
+END OP *;
+
+PROC get (MATRIX VAR a, INT CONST rows, columns) :
+
+ a := matrix (rows,columns);
+ INT VAR i, j;
+ VECTOR VAR v;
+ FOR i FROM 1 UPTO rows
+ REP get (v, columns);
+ store row
+ PER .
+
+store row :
+ FOR j FROM 1 UPTO a.columns
+ REP replace (a.elems, calc pos (a.columns, i, j), v SUB j)
+ PER .
+
+END PROC get;
+
+PROC put (MATRIX CONST a, INT CONST length, fracs) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP put (text (sub (a, i, j), length, fracs)) PER;
+ line (2);
+ PER
+
+END PROC put;
+
+PROC put (MATRIX CONST a) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP TEXT CONST number :: " " + text (sub (a, i, j));
+ put (subtext (number, LENGTH number - 15))
+ PER;
+ line (2);
+ PER
+
+END PROC put;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, l text, r text, INT CONST left, right) :
+ IF left <> right
+ THEN error := proc;
+ error CAT l text;
+ error CAT " (";
+ error CAT text (left);
+ error CAT ") <> ";
+ error CAT r text;
+ error CAT " (";
+ error CAT text (right);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, INT CONST i, n) :
+ IF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i > n
+ THEN error := proc;
+ error CAT "subscript overflow (i=";
+ error CAT text (i);
+ error CAT ", max=";
+ IF n <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (n) FI;
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+
+MATRIX OP TRANSP (MATRIX CONST m) :
+ MATRIX VAR a :: m;
+ transp (a);
+ a
+
+END OP TRANSP;
+
+PROC transp (MATRIX VAR m) :
+ INT VAR k :: 1, n :: m.rows*m.columns;
+ a := m;
+ FOR i FROM 2 UPTO n
+ REP replace (m.elems, i, a.elems SUB position) PER;
+ a := idn (1);
+ i := m.rows;
+ m.rows := m.columns;
+ m.columns := i .
+
+position :
+ k INCR m.columns;
+ IF k > n
+ THEN k DECR (n-1) FI;
+ k .
+END PROC transp;
+
+MATRIX OP INV (MATRIX CONST m) :
+ a := m;
+ ROW 32 INT VAR pivots;
+ INT VAR i, j, k :: ROWS a, n :: COLUMNS a, pos;
+
+ IF n <> k
+ THEN errorstop ("MATRIX OP INV : no square matrix") FI;
+
+ initialisiere die pivotpositionen;
+
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ IF sub (a, pos, pos) = 0.0
+ THEN errorstop ("MATRIX OP INV : singular matrix") FI;
+ zeilentausch (a, j, pos);
+ merke dir die vertauschung;
+ transformiere die matrix
+ PER;
+
+ spaltentausch;
+ a .
+
+initialisiere die pivotpositionen :
+ FOR i FROM 1 UPTO n
+ REP pivots [i] := i PER .
+
+merke dir die vertauschung :
+ IF pos > j
+ THEN INT VAR hi :: pivots [j];
+ pivots [j] := pivots [pos];
+ pivots [pos] := hi
+ FI .
+
+transformiere die matrix :
+ REAL VAR h := 1.0/sub (a, j, j);
+
+ FOR k FROM 1 UPTO n
+ REP IF k <> j
+ THEN FOR i FROM 1 UPTO n
+ REP IF i <> j
+ THEN replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*sub (a, j, k)*h);
+ FI
+ PER;
+ FI
+ PER;
+
+ FOR k FROM 1 UPTO n
+ REP replace element (a, j, k, -h*sub (a, j, k));
+ replace element (a, k, j, h*sub (a, k, j))
+ PER;
+ replace element (a, j, j, h) .
+
+spaltentausch :
+ VECTOR VAR v :: vector (n);
+ FOR i FROM 1 UPTO n
+ REP FOR k FROM 1 UPTO n
+ REP replace (v, pivots [k], sub(a, i, k)) PER;
+ replace row (a, i, v)
+ PER .
+
+END OP INV;
+
+REAL OP DET (MATRIX CONST m) :
+ IF COLUMNS m <> ROWS m
+ THEN errorstop ("REAL OP DET : no square matrix") FI;
+
+ a := m;
+ INT VAR i, j, k, n :: COLUMNS m, pos;
+ REAL VAR merker := 1.0;
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ IF j<> pos
+ THEN zeilentausch (a, j, pos);
+ zeilen tausch merken
+ FI;
+ transformiere die matrix
+ PER;
+ produkt der pivotelemente .
+
+transformiere die matrix :
+ REAL VAR hp := sub(a,j,j);
+ IF hp = 0.0
+ THEN LEAVE DET WITH 0.0
+ ELSE REAL VAR h := 1.0/hp;
+ FI;
+ FOR i FROM j+1 UPTO n
+ REP FOR k FROM j+1 UPTO n
+ REP replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*h*sub (a, j, k))
+ PER
+ PER .
+
+produkt der pivotelemente :
+ REAL VAR produkt :: sub (a, 1, 1);
+ FOR j FROM 2 UPTO n
+ REP produkt := produkt * sub (a, j, j) PER;
+ a := idn (1);
+ produkt * merker.
+
+zeilen tausch merken:
+ merker := merker * (-1.0).
+
+END OP DET;
+
+PROC pivotsuche (MATRIX CONST a, INT CONST start pos, INT VAR pos) :
+ REAL VAR max :: abs (sub (a, start pos, start pos));
+ INT VAR i;
+ pos := start pos;
+
+ FOR i FROM start pos+1 UPTO COLUMNS a
+ REP IF abs (sub (a, i, start pos)) > max
+ THEN max := abs (sub (a, i, start pos));
+ pos := i
+ FI
+ PER .
+
+END PROC pivotsuche;
+
+PROC zeilentausch (MATRIX VAR a, INT CONST old pos, pos) :
+ VECTOR VAR v := row (a, pos);
+ replace row (a, pos, row (a, old pos));
+ replace row (a, old pos, v) .
+
+END PROC zeilentausch;
+
+END PACKET matrix;
+
diff --git a/system/std.zusatz/1.8.7/src/port server b/system/std.zusatz/1.8.7/src/port server
new file mode 100644
index 0000000..46c647f
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/port server
@@ -0,0 +1,164 @@
+PACKET port server: (* Autor : R. Ruland *)
+ (* Stand : 21.03.86 *)
+
+INT VAR port station;
+TEXT VAR port := "PRINTER";
+
+put ("gib Name des Zielspools : "); editget (port); line;
+put ("gib Stationsnummer des Zielspools : "); get (port station);
+
+server channel (15);
+spool duty ("Verwalter fuer Task """ + port +
+ """ auf Station " + text (port station));
+
+LET max counter = 10 ,
+ time slice = 300 ,
+
+ ack = 0 ,
+ fetch code = 11 ,
+ param fetch code = 21 ,
+ file save code = 22 ,
+ file type = 1003 ,
+
+ begin char = ""0"",
+ end char = ""1"";
+
+
+INT VAR reply, old heap size;
+TEXT VAR file name, write pass, read pass, sendername, buffer;
+FILE VAR file;
+
+DATASPACE VAR ds, file ds, send ds;
+
+BOUND STRUCT (TEXT file name, write pass, read pass, sendername, INT station) VAR msg;
+BOUND TEXT VAR error msg ;
+
+spool manager (PROC save file);
+
+PROC save file :
+
+ disable stop ;
+ command dialogue (FALSE);
+ ds := nilspace; file ds := nilspace; send ds := nil space;
+ old heap size := heap size;
+
+ REP
+ execute save file;
+
+ IF is error THEN save error (error message) FI;
+
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI;
+
+ PER
+
+ENDPROC save file;
+
+
+PROC execute save file :
+
+enable stop;
+forget (file ds) ; file ds := nilspace;
+call (father, fetch code, file ds, reply);
+IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE save file ds
+FI;
+
+. save file ds :
+ IF type (file ds) = file type
+ THEN get file params;
+ insert file params;
+ call station (port station, port, file save code, file ds);
+ ELSE errorstop ("Datenraum hat falschen Typ")
+ FI;
+
+. get file params :
+ forget (ds); ds := nilspace;
+ call (father, param fetch code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE msg := ds;
+ file name := msg. file name;
+ write pass := msg. write pass;
+ read pass := msg. read pass;
+ sendername := msg. sender name;
+ FI;
+
+. insert file params :
+ buffer := "";
+ in headline (filename);
+ in headline (write pass);
+ in headline (read pass);
+ in headline (sendername);
+ file := sequential file (input, file ds) ;
+ headline (file, buffer);
+
+END PROC execute save file;
+
+
+PROC call station (INT CONST order task station, TEXT CONST order task name,
+ INT CONST order code, DATASPACE VAR order ds) :
+
+ INT VAR counter := 0;
+ TASK VAR order task;
+ disable stop;
+ REP order task := order task station // order task name;
+ IF is error CAND pos (error message, "antwortet nicht") > 0
+ THEN clear error;
+ counter := min (max counter, counter + 1);
+ pause (counter * time slice);
+ ELSE enable stop;
+ forget (send ds); send ds := order ds;
+ call (order task, order code, send ds, reply);
+ disable stop;
+ IF reply = ack
+ THEN forget (order ds); order ds := send ds;
+ forget (send ds);
+ LEAVE call station
+ ELSE error msg := send ds;
+ errorstop (error msg);
+ FI;
+ FI;
+ PER;
+
+END PROC call station;
+
+
+TASK OP // (INT CONST station, TEXT CONST name) :
+
+ enable stop;
+ station / name
+
+END OP //;
+
+
+PROC in headline (TEXT CONST information) :
+ IF pos (information, begin char) <> 0
+ OR pos (information, end char) <> 0
+ THEN errorstop ("Name darf nicht Code 0 oder Code 1 enthalten") FI;
+ buffer CAT begin char;
+ buffer CAT information;
+ buffer CAT end char;
+END PROC in headline;
+
+
+PROC save error (TEXT CONST message) :
+ clear error;
+ file name CAT ".";
+ file name CAT sender name;
+ file name CAT ".ERROR";
+ file := sequential file (output, file name);
+ putline (file, " ");
+ putline (file, "Uebertragung nicht korrekt beendet ");
+ putline (file, " ");
+ put (file, "ERROR :"); put (file, message);
+ save (file name, public);
+ clear error;
+ forget(file name, quiet);
+END PROC save error;
+
+ENDPACKET port server;
+
diff --git a/system/std.zusatz/1.8.7/src/printer server b/system/std.zusatz/1.8.7/src/printer server
new file mode 100644
index 0000000..b1a30bc
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/printer server
@@ -0,0 +1,99 @@
+PACKET multi user printer : (* Autor : Rudolf Ruland *)
+ (* Stand : 24.03.86 *)
+
+INT VAR c;
+put ("gib Druckerkanal : "); get (c);
+
+ server channel (c);
+ station only (FALSE) ;
+ spool duty ("Ausgabe mit dem Drucker");
+ spool control task (myself);
+
+LET ack = 0 ,
+
+ fetch code = 11 ,
+ param fetch code = 21 ,
+ file type = 1003 ;
+
+INT VAR reply, old heap size, sender station;
+TEXT VAR file name, userid, password, sendername;
+FILE VAR file ;
+
+DATASPACE VAR ds, file ds;
+
+BOUND STRUCT (TEXT file name, userid, password, sendername, INT station) VAR msg;
+BOUND TEXT VAR error msg ;
+
+spool manager (PROC printer);
+
+PROC printer :
+
+ disable stop ;
+ command dialogue (FALSE);
+ ds := nilspace; file ds := nilspace;
+ continue (server channel) ;
+ check error ("Kanal belegt");
+
+ old heap size := heap size ;
+ REP
+ execute print ;
+
+ IF is error
+ THEN put error;
+ clear error;
+ FI ;
+
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI
+ PER
+
+ENDPROC printer ;
+
+
+PROC execute print :
+
+ enable stop ;
+ forget (file ds) ; file ds := nilspace ;
+ call (father, fetch code, file ds, reply) ;
+ IF reply = ack CAND type (file ds) = file type
+ THEN get file params;
+ print file
+ FI ;
+
+. get file params :
+ forget (ds); ds := nilspace;
+ call (father, param fetch code, ds, reply);
+ IF reply <> ack
+ THEN error msg := ds; errorstop (error msg);
+ ELSE msg := ds;
+ file name := msg. file name;
+ userid := msg. userid;
+ password := msg. password;
+ sendername := msg. sender name;
+ sender station := msg. station;
+ FI;
+
+. print file :
+ file := sequential file (input, file ds);
+ print (file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC execute print ;
+
+
+PROC check error (TEXT CONST message) :
+ IF is error
+ THEN clear error;
+ rename myself (message);
+ IF is error THEN clear error; end (myself) FI;
+ pause (18000);
+ end (myself);
+ FI;
+END PROC check error;
+
+ENDPACKET multi user printer ;
+
diff --git a/system/std.zusatz/1.8.7/src/purge b/system/std.zusatz/1.8.7/src/purge
new file mode 100644
index 0000000..55230ff
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/purge
@@ -0,0 +1,85 @@
+PACKET purge DEFINES purge :
+
+
+TEXT VAR task name, record, file name, dummy ;
+
+FILE VAR permit ;
+
+
+PROC purge :
+
+ IF exists ("permitted tasks")
+ THEN access catalogue ;
+ permit := sequential file (input, "permitted tasks") ;
+ say (""10""13"TASKS :"10""10""13"") ;
+ IF myself < supervisor
+ THEN purge son tasks (brother (supervisor))
+ ELSE purge son tasks (myself)
+ FI
+ FI ;
+ IF exists ("permitted files")
+ THEN permit := sequential file (input, "permitted files") ;
+ say (""10""13"DATEIEN :"10""10""13"") ;
+ purge files
+ FI
+
+ENDPROC purge ;
+
+PROC purge son tasks (TASK CONST father task) :
+
+ TASK VAR actual task := son (father task) ;
+ WHILE NOT is niltask (actual task) REP
+ purge son tasks (actual task) ;
+ IF NOT actual task permitted
+ THEN erase actual task
+ FI ;
+ actual task := brother (actual task)
+ END REP .
+
+erase actual task :
+ say ("""") ; say (task name) ; say ("""") ;
+ IF yes (" loeschen")
+ THEN end (actual task)
+ FI .
+
+actual task permitted :
+ task name := name (actual task) ;
+ reset (permit) ;
+ WHILE NOT eof (permit) REP
+ getline (permit, record) ;
+ IF task name = record
+ THEN LEAVE actual task permitted WITH TRUE
+ FI
+ END REP ;
+ FALSE .
+
+ENDPROC purge son tasks ;
+
+PROC purge files :
+
+ begin list ;
+ get list entry (file name, dummy) ;
+ WHILE file name <> "" REP
+ IF NOT file permitted
+ THEN forget (file name)
+ FI ;
+ get list entry (file name, dummy)
+ END REP .
+
+file permitted :
+ IF file name = "permitted tasks" OR file name = "permitted files"
+ THEN LEAVE file permitted WITH TRUE
+ FI ;
+ reset (permit) ;
+ WHILE NOT eof (permit) REP
+ getline (permit, record) ;
+ IF file name = record
+ THEN LEAVE file permitted WITH TRUE
+ FI
+ END REP ;
+ FALSE .
+
+ENDPROC purge files ;
+
+ENDPACKET purge ;
+
diff --git a/system/std.zusatz/1.8.7/src/referencer b/system/std.zusatz/1.8.7/src/referencer
new file mode 100644
index 0000000..2ee65e4
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/referencer
@@ -0,0 +1,1077 @@
+(* ------------------- VERSION 10 vom 01.08.86 -------------------- *)
+PACKET referencer errors DEFINES report referencer error:
+
+(* Programm zur Fehlerbehandlung des referencers.
+ Autor: Rainer Hahn *)
+
+TEXT VAR fehlerdummy,
+ message;
+
+PROC report referencer error (INT CONST error nr,
+ INT CONST line nr,
+ TEXT CONST addition):
+
+ einfache fehlermeldung aufbauen;
+ diese auf terminal ausgeben;
+ fehlermeldung in fehlerdatei ausgeben.
+
+einfache fehlermeldung aufbauen:
+ message := "WARNUNG in Zeile ";
+ message CAT text (line nr);
+ message CAT " : ";
+ message CAT simple message.
+
+diese auf terminal ausgeben:
+ line ;
+ putline (message).
+
+fehlermeldung in fehlerdatei ausgeben:
+ note (message);
+ note line ;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1: "Text Denoter ueber mehr als eine Zeile"
+ CASE 2: "Nicht beendeter Text Denoter bei Programmende"
+ CASE 3: "Kommentar ueber mehr als eine Zeile"
+ CASE 4: "Nicht beendeter Kommentar bei Programmende"
+ CASE 5: "Ueberdeckung"
+ CASE 6, 9: "Refinement mehrmals eingesetzt"
+ CASE 7, 10: "Refinement wird nicht aufgerufen"
+ CASE 8: "Objekt wird nicht angesprochen"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 1, 2, 3, 4: "Ueber " + addition + " Zeilen"
+ CASE 5: addition
+ CASE 6, 7, 8: addition
+ CASE 9, 10: addition + " in mindestens einer Prozedur"
+ OTHERWISE "interner Fehler: HRZ Bielefeld benachrichtigen!"
+ END SELECT.
+END PROC report referencer error
+END PACKET referencer errors;
+(************************************************************************)
+
+PACKET name table handling
+ DEFINES NAMETABLE,
+ empty name table,
+ put name,
+ get name,
+ dump table:
+
+(* Programm zur Speicherung von Namen.
+ Autor: Rainer Hahn *)
+
+LET hash table length = 1024,
+ hash table length minus one = 1023,
+ start of name table = 255,
+ name table length = 2000;
+
+TYPE NAMETABLE = STRUCT (INT number of entries,
+ ROW hash table length INT hash table,
+ ROW name table length INT next,
+ ROW name table length TEXT name table);
+
+TEXT VAR dummy, f;
+
+PROC put name (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ INT VAR errechneter index;
+ hash (name, errechneter index);
+ IF noch kein eintrag
+ THEN gaenzlich neuer eintrag
+ ELSE name in vorhandener kette
+ FI.
+
+noch kein eintrag:
+ n . hash table [errechneter index] = 0.
+
+gaenzlich neuer eintrag:
+ n . hash table [errechneter index] := n . number of entries;
+ neuer eintrag (n, name, pointer).
+
+name in vorhandener kette:
+ INT VAR dieser eintrag :: n. hash table [errechneter index];
+ REP
+ IF name ist vorhanden
+ THEN pointer := dieser eintrag;
+ LEAVE put name
+ ELIF kette zu ende
+ THEN neuer eintrag an vorhandene kette anketten;
+ neuer eintrag (n, name, pointer);
+ LEAVE put name
+ ELSE naechster eintrag in der kette
+ FI
+ END REP.
+
+name ist vorhanden:
+ n . name table [dieser eintrag] = name.
+
+kette zu ende:
+ n . next [dieser eintrag] = 0.
+
+neuer eintrag an vorhandene kette anketten:
+ n . next [dieser eintrag] := n . number of entries.
+
+naechster eintrag in der kette:
+ dieser eintrag := n . next [dieser eintrag].
+END PROC put name;
+
+PROC neuer eintrag (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ n . name table [n . number of entries] := name;
+ n . next [n . number of entries] := 0;
+ pointer := n . number of entries;
+ n . number of entries INCR 1;
+ IF n . number of entries > name table length
+ THEN errorstop ("volle Namenstabelle")
+ FI
+END PROC neuer eintrag;
+
+PROC hash (TEXT CONST name, INT VAR index) :
+ INT VAR i;
+ index := code (name SUB 1);
+ FOR i FROM 2 UPTO length (name) REP
+ addmult cyclic
+ ENDREP.
+
+addmult cyclic :
+ index INCR index ;
+ IF index > hash table length minus one
+ THEN wrap around
+ FI;
+ index := (index + code (name SUB i)) MOD hash table length.
+
+wrap around :
+ index DECR hash table length minus one
+ENDPROC hash ;
+
+PROC get name (NAMETABLE CONST n, INT CONST index, TEXT VAR t):
+ IF index < n . number of entries AND index >= start of name table
+ THEN t := n . name table [index]
+ ELSE errorstop ("Interner Fehler 1")
+ FI
+END PROC get name;
+
+PROC empty name table (NAMETABLE VAR n):
+INT VAR i;
+ n . number of entries := start of name table;
+ FOR i FROM 1 UPTO hash table length REP
+ n . hash table [i] := 0
+ END REP
+END PROC empty name table;
+
+PROC dump table (NAMETABLE CONST n):
+ line ;
+ put ("Bitte Name der Datei, in die die Namenstabelle gehen soll:");
+ getline (f);
+ line ;
+ file assoziieren;
+ dump namens ketten;
+ zusammenfassung.
+
+file assoziieren:
+ FILE VAR file :: sequential file (output, f).
+
+dump namens ketten:
+ INT VAR i,
+ anz hash eintraege :: 0,
+ kette 3 eintraege :: 0;
+ FOR i FROM 1 UPTO hash table length REP
+ IF n . hash table [i] <> 0
+ THEN anz hash eintraege INCR 1;
+ INT VAR naechster eintrag :: n . hash table [i];
+ dump hash eintrag;
+ ketten eintraege
+ FI
+ END REP.
+
+dump hash eintrag:
+ dummy := text (i);
+ WHILE length (dummy) < 4 REP dummy CAT " " END REP;
+ dummy CAT ": ".
+
+ketten eintraege:
+ INT VAR anz eintraege pro kette :: 0;
+ WHILE naechster eintrag > 0 REP
+ anz eintraege pro kette INCR 1;
+ dummy CAT " ";
+ dummy CAT text (naechster eintrag);
+ dummy CAT " -> ";
+ dummy CAT n . name table [naechster eintrag];
+ naechster eintrag := n . next [naechster eintrag];
+ END REP;
+ IF anz eintraege pro kette > 2
+ THEN kette 3 eintraege INCR 1
+ FI;
+ putline (file, dummy).
+
+zusammenfassung:
+ statistik ueberschrift;
+ anzahl hash eintraege;
+ anzahl namens eintraege;
+ verkettungsfaktor;
+ anzahl laengerer ketten.
+
+statistik ueberschrift:
+ line (file, 2);
+ dummy := " ---------- ";
+ dummy CAT "S T A T I S T I K:";
+ dummy CAT " ---------- ";
+ putline (file, dummy);
+ line (file, 2).
+
+anzahl hash eintraege:
+ dummy := "Anzahl Hash-Eintraege (max. ";
+ dummy CAT text (hash table length);
+ dummy CAT "): ";
+ dummy CAT text (anz hash eintraege);
+ putline (file, dummy).
+
+anzahl namens eintraege:
+ dummy := "Anzahl Namen (max. ";
+ dummy CAT text (name table length - start of name table + 1);
+ dummy CAT "): ";
+ dummy CAT text (n . number of entries - start of name table);
+ putline (file, dummy).
+
+verkettungsfaktor:
+ dummy := "Verkettungsfaktor (Anzahl Namen / Anzahl Ketten): ";
+ dummy CAT text (real (n . number of entries - start of name table) /
+ real (anz hash eintraege));
+ putline (file, dummy).
+
+anzahl laengerer ketten:
+ dummy := "Anzahl Ketten > 2 Eintraege: ";
+ dummy CAT text (kette 3 eintraege);
+ putline (file, dummy).
+END PROC dump table;
+END PACKET name table handling;
+(***************************************************************************)
+
+PACKET scanner DEFINES init scanning,
+ init name table with,
+ dump name table,
+ get name,
+ end scanning,
+ line number,
+ symbol:
+
+(* Programm zum scannen von ELAN-Programmen.
+ Autor: Rainer Hahn *)
+
+FILE VAR eingabe;
+
+DATASPACE VAR ds alt := nilspace,
+ ds neu := nilspace;
+
+BOUND NAMETABLE VAR tabelle;
+
+TEXT VAR zeile,
+ zeichen,
+ dummy;
+
+LET end of program = ""30"",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ delimiter = 4,
+ punkt = 46,
+ doppelpunkt = 58,
+ init symbol = 30,
+ assign symbol = 31;
+
+INT VAR zeilen nr,
+ zeichen pos;
+
+PROC init name table with (TEXT CONST worte):
+INT VAR index;
+ forget (ds alt);
+ ds alt := nilspace;
+ tabelle := dsalt;
+ empty name table (CONCR (tabelle));
+ INT VAR anf :: 1,
+ ende :: pos (worte, ",", 1);
+ WHILE ende > 0 REP
+ dummy := subtext (worte, anf, ende - 1);
+ put name (CONCR (tabelle), dummy, index);
+ anf := ende + 1;
+ ende := pos (worte, ",", ende + 1)
+ END REP;
+ dummy := subtext (worte, anf);
+ put name (CONCR (tabelle), dummy, index)
+END PROC init name table with;
+
+PROC init scanning (TEXT CONST f):
+ IF exists (f)
+ THEN namenstabelle holen;
+ erste zeile lesen
+ ELSE errorstop ("Datei existiert nicht")
+ FI.
+
+namenstabelle holen:
+ forget (ds neu);
+ ds neu := ds alt;
+ tabelle := ds neu.
+
+erste zeile lesen:
+ eingabe := sequential file (input, f);
+ IF eof (eingabe)
+ THEN errorstop ("Datei ist leer")
+ ELSE zeile := "";
+ zeilen nr := 0;
+ zeile lesen;
+ naechstes non blank zeichen
+ FI
+END PROC init scanning;
+
+PROC dump name table:
+ dump table (CONCR (tabelle))
+END PROC dump name table;
+
+PROC end scanning (TEXT CONST f):
+ IF anything noted
+ THEN eingabe := sequential file (modify, f);
+ note edit (eingabe)
+ FI
+END PROC end scanning;
+
+PROC get name (INT CONST index, TEXT VAR t):
+ get name (CONCR (tabelle), index, t)
+END PROC get name;
+
+PROC zeile lesen:
+ getline (eingabe, zeile);
+ zeilen nr INCR 1;
+ cout (zeilen nr);
+ zeichen pos := 0
+END PROC zeile lesen;
+
+PROC naechstes non blank zeichen:
+ REP
+ zeichen pos := pos (zeile, ""33"", ""254"", zeichen pos + 1);
+ IF zeichen pos <> 0
+ THEN zeichen := (zeile SUB zeichen pos);
+ LEAVE naechstes non blank zeichen
+ ELIF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes non blank zeichen
+ ELSE zeile lesen
+ FI
+ END REP.
+END PROC naechstes non blank zeichen;
+
+PROC naechstes zeichen:
+ IF zeichen pos > length (zeile)
+ THEN IF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes zeichen
+ ELSE zeile lesen
+ FI
+ FI;
+ zeichenpos INCR 1;
+ zeichen := zeile SUB zeichenpos
+END PROC naechstes zeichen;
+
+INT PROC line number:
+ IF zeichenpos = pos (zeile, ""33"", ""254"", 1)
+ THEN zeilen nr - 1
+ ELSE zeilen nr
+ FI
+END PROC line number;
+
+PROC symbol (INT VAR symb, type):
+ REP
+ suche naechstes checker symbol
+ END REP.
+
+suche naechstes checker symbol:
+ SELECT code (zeichen) OF
+ CASE 30: (* end of programn *)
+ symb := eop;
+ type := eop;
+ LEAVE symbol
+ CASE 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110,
+ 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122:
+ (* small letters *)
+ identifier aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := identifier;
+ LEAVE symbol
+ CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 90: (* large letters *)
+ schluesselwort aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := keyword;
+ LEAVE symbol
+ CASE 34: (* " *)
+ skip text denoter
+ CASE 40: (* ( *)
+ IF (zeile SUB zeichen pos + 1) = "*"
+ THEN skip comment
+ ELSE symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol;
+ FI
+ CASE 58: (* : *)
+ IF (zeile SUB zeichenpos + 1) = "="
+ THEN symb := assign symbol;
+ zeichenpos INCR 1
+ ELIF (zeile SUB zeichenpos + 1) = ":"
+ THEN symb := init symbol;
+ zeichenpos INCR 1
+ ELSE symb := doppelpunkt
+ FI;
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57: (* 0 - 9 *)
+ int denoter skippen;
+ IF zeichen = "."
+ THEN naechstes non blank zeichen;
+ IF digit
+ THEN real denoter skippen
+ ELSE symb := punkt;
+ type := delimiter;
+ LEAVE symbol
+ FI
+ FI
+ CASE 41, 44, 46, 59, 61: (* ) , . ; = *)
+ symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ OTHERWISE naechstes non blank zeichen
+ END SELECT.
+END PROC symbol;
+
+PROC real denoter skippen:
+ int denoter skippen;
+ IF zeichen = "e"
+ THEN naechstes non blank zeichen;
+ int denoter skippen
+ FI
+END PROC real denoter skippen;
+
+PROC int denoter skippen:
+ naechstes non blank zeichen;
+ WHILE zeichen >= "0" AND zeichen <= "9" REP
+ naechstes non blank zeichen
+ ENDREP;
+ zeichenpos DECR 1;
+ naechstes non blank zeichen
+END PROC int denoter skippen;
+
+PROC identifier aufsammeln:
+ dummy := zeichen;
+ REP
+ naechstes non blank zeichen;
+ IF small letter or digit
+ THEN dummy CAT zeichen
+ ELSE LEAVE identifier aufsammeln
+ FI
+ END REP
+END PROC identifier aufsammeln;
+
+PROC schluesselwort aufsammeln:
+ dummy := "";
+ sammle schluesselwort;
+ IF dummy = "END"
+ THEN noch einmal
+ FI.
+
+sammle schluesselwort:
+ WHILE large letter REP
+ dummy CAT zeichen;
+ naechstes zeichen
+ END REP;
+ IF zeichen = " "
+ THEN naechstes non blank zeichen
+ FI.
+
+noch einmal:
+ sammle schluesselwort
+END PROC schluesselwort aufsammeln;
+
+PROC skip text denoter:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, """", zeichenpos + 1);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, """");
+ END REP;
+ ende text denoter.
+
+ende text denoter:
+ IF anz zeilen > 1
+ THEN report referencer error (1, zeilen nr, text (anz zeilen))
+ FI;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (2, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip text denoter
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip text denoter;
+
+PROC skip comment:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, "*)", zeichenpos + 2);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, "*)");
+ END REP;
+ ende comment.
+
+ende comment:
+ IF anz zeilen > 1
+ THEN report referencer error (3, zeilen nr, text (anz zeilen))
+ FI;
+ zeichen pos INCR 2;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (4, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip comment
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip comment;
+
+BOOL PROC small letter or digit:
+ (zeichen >= "0" AND zeichen <= "9") OR (zeichen >= "a" AND zeichen <= "z")
+END PROC small letter or digit;
+
+BOOL PROC small letter:
+ zeichen >= "a" AND zeichen <= "z"
+END PROC small letter;
+
+BOOL PROC large letter:
+ zeichen >= "A" AND zeichen <= "Z"
+END PROC large letter;
+
+BOOL PROC digit:
+ zeichen >= "0" AND zeichen <= "9"
+END PROC digit;
+END PACKET scanner;
+(*************************************************************************)
+PACKET referencer2 DEFINES referencer:
+
+(* Programm fuer den 'referencer'
+ Autor: Rainer Hahn *)
+
+INT VAR symb,
+ typ,
+ max index;
+
+TEXT VAR dummy,
+ dummy2,
+ name;
+
+DATASPACE VAR ds;
+
+BOUND ROW max TEXT VAR liste;
+
+FILE VAR f;
+
+BOOL VAR initialisiert :: FALSE,
+ symbol bereits geholt,
+ globale deklarationen;
+
+LET max = 1751,
+ global text = "<--G",
+ local text = "<--L",
+ refinement text = "<--R",
+ procedure text = "<--P",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ init symbol = 30,
+ assign symbol = 31,
+ klammer auf = 40,
+ klammer zu = 41,
+ komma = 44,
+ punkt = 46,
+ doppelpunkt = 58,
+ semikolon = 59,
+ proc symbol = 255,
+ end proc symbol = 256,
+ packet symbol = 257,
+ end packet symbol = 258,
+ type symbol = 259,
+ var symbol = 260,
+ const symbol = 261,
+ let symbol = 262,
+ leave symbol = 263,
+ op symbol = 264,
+ endop symbol = 265,
+ endif symbol = 266,
+ fi symbol = 266;
+
+PROC referencer:
+ referencer (last param)
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file):
+ referencer (check file, check file + ".r")
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file, dump file):
+ IF exists (check file)
+ THEN dump file ggf loeschen
+ ELSE errorstop ("Eingabe-Datei nicht vorhanden")
+ FI;
+ disable stop;
+ start referencing (check file, dump file);
+ forget (ds);
+ enable stop.
+
+dump file ggf loeschen:
+ IF exists (dump file)
+ THEN forget (dump file, quiet)
+ FI.
+END PROC referencer;
+
+PROC start referencing (TEXT CONST check file, dump file):
+ enable stop;
+ ueberschrift;
+ initialisierung;
+ verkuerzte syntax analyse;
+ line ;
+ in dump file kopieren (dump file);
+ line ;
+ end scanning (check file).
+
+ueberschrift:
+ page;
+ put ("REFERENCER:");
+ put (check file);
+ put ("->");
+ putline (dump file).
+
+initialisierung:
+ IF NOT initialisiert
+ THEN init name table with
+("PROC,ENDPROC,PACKET,ENDPACKET,TYPE,VAR,CONST,LET,LEAVE,OP,ENDOP,ENDIF,FI");
+ initialisiert := TRUE
+ FI;
+ ds := nilspace;
+ liste := ds;
+ max index := end op symbol;
+ dummy := checkfile.
+
+verkuerzte syntax analyse:
+ globale deklarationen := TRUE;
+ line ;
+ init scanning (dummy);
+ symbol bereits geholt := FALSE;
+ REP
+ IF symbol bereits geholt
+ THEN symbol bereits geholt := FALSE
+ ELSE symbol (symb, typ)
+ FI;
+ IF typ = keyword
+ THEN nach schluesselwort verarbeiten
+ ELIF symb = punkt
+ THEN ggf refinement aufnehmen
+ ELIF typ = identifier
+ THEN identifier aufnehmen und ggf aktuelle parameter liste
+ FI
+ UNTIL typ = eop ENDREP.
+
+identifier aufnehmen und ggf aktuelle parameter liste:
+ in die liste (symb, "");
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN aktuelle parameter aufnehmen
+ ELSE symbol bereits geholt := TRUE
+ FI.
+
+nach schluesselwort verarbeiten:
+ SELECT symb OF
+ CASE let symbol:
+ let deklarationen aufsammeln
+ CASE packet symbol:
+ namen des interface aufsammeln
+ CASE end packet symbol:
+ skip naechstes symbol
+ CASE var symbol, const symbol:
+ datenobjekt deklaration aufnehmen
+ CASE proc symbol:
+ globale deklarationen := FALSE;
+ prozedur name und ggf parameter aufsammeln
+ CASE end proc symbol:
+ globale deklarationen := TRUE;
+ skip naechstes symbol
+ CASE op symbol:
+ globale deklarationen := FALSE;
+ operatornamen skippen und ggf parameter aufsammeln
+ CASE end op symbol:
+ globale deklarationen := TRUE;
+ skip until (semikolon)
+ CASE type symbol:
+ namen der typ definition aufsammeln
+ CASE leave symbol:
+ skip naechstes symbol
+ OTHERWISE:
+ ENDSELECT.
+
+skip naechstes symbol:
+ symbol (symb, typ).
+END PROC start referencing;
+
+PROC aktuelle parameter aufnehmen:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = klammer zu END REP.
+END PROC aktuelle parameter aufnehmen;
+
+PROC ggf refinement aufnehmen:
+ symbol (symb, typ);
+ symbol bereits geholt := TRUE;
+ WHILE typ = identifier REP
+ doppelpunkt oder selektor
+ END REP.
+
+doppelpunkt oder selektor:
+ INT CONST letzter id :: symb;
+ symbol (symb, typ);
+ IF symb = doppelpunkt
+ THEN in die liste (letzter id, refinement text);
+ LEAVE ggf refinement aufnehmen
+ ELSE in die liste (letzter id, "");
+ IF symb = punkt
+ THEN symbol (symb, typ)
+ ELSE LEAVE ggf refinement aufnehmen
+ FI
+ FI
+END PROC ggf refinement aufnehmen;
+
+PROC namen des interface aufsammeln:
+ packet name ueberspringen;
+ namen der schnittstelle aufsammeln.
+
+packet name ueberspringen:
+ symbol (symb, typ).
+
+namen der schnittstelle aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = doppelpunkt END REP.
+END PROC namen des interface aufsammeln;
+
+PROC let deklarationen aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN let name aufnehmen
+ ELIF typ = keyword
+ THEN bis zum komma oder semikolon
+ FI;
+ UNTIL symb = semikolon END REP.
+
+let name aufnehmen:
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, "")
+ FI;
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = komma OR symb = semikolon END REP.
+END PROC let deklarationen aufsammeln;
+
+PROC namen der typ definition aufsammeln:
+ REP
+ symbol (symb, typ);
+ bis zum komma oder semikolon
+ UNTIL symb = semikolon END REP
+END PROC namen der typ definition aufsammeln;
+
+PROC bis zum komma oder semikolon:
+ INT VAR anz klammern :: 0;
+ REP
+ symbol (symb, typ); (* fields aufnehmen weggelassen *)
+ IF symb = klammer auf
+ THEN anz klammern INCR 1
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1
+ FI
+ UNTIL (symb = komma AND anz klammern = 0) OR symb = semikolon ENDREP.
+END PROC bis zum komma oder semikolon;
+
+PROC datenobjekt deklaration aufnehmen:
+ symbol (symb, typ);
+ REP
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, local text)
+ FI;
+ skip ggf initialisierung;
+ IF symb = komma
+ THEN symbol (symb, typ)
+ FI
+ UNTIL symb = semikolon OR symb = punkt END REP.
+
+skip ggf initialisierung:
+ symbol (symb, typ);
+ IF symb = init symbol OR symb = assign symbol
+ THEN initialisierung skippen
+ FI.
+
+initialisierung skippen:
+ INT VAR anz klammern :: 0;
+ REP
+ INT CONST vorheriges symbol :: symb,
+ vorheriger typ :: typ;
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN anz klammern INCR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF vorheriger typ = identifier AND symb = doppelpunkt
+ THEN in die liste (vorheriges symbol, refinement text);
+ LEAVE datenobjekt deklaration aufnehmen
+ ELIF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ UNTIL (symb = komma AND anz klammern = 0)
+ OR symb = semikolon OR symb = end proc symbol OR
+ symb = end op symbol OR symb = endif symbol OR symb = fi symbol
+ END REP.
+END PROC datenobjekt deklaration aufnehmen;
+
+PROC prozedur name und ggf parameter aufsammeln:
+ prozedurname aufsammeln;
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI.
+
+prozedurname aufsammeln:
+ symbol (symb, typ);
+ in die liste (symb, procedure text).
+END PROC prozedurname und ggf parameter aufsammeln;
+
+PROC operatornamen skippen und ggf parameter aufsammeln:
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI
+END PROC operatornamen skippen und ggf parameter aufsammeln;
+
+PROC formale parameter aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, local text);
+ FI
+ UNTIL symb = doppelpunkt END REP
+END PROC formale parameter aufsammeln;
+
+PROC skip until (INT CONST zeichencode):
+ skip until (zeichencode, 0)
+END PROC skip until;
+
+PROC skip until (INT CONST z1, z2):
+ REP
+ symbol (symb, typ)
+ UNTIL symb = z1 OR symb = z2 END REP
+END PROC skip until;
+
+PROC in die liste (INT CONST index, TEXT CONST zusatz):
+ IF index > max index
+ THEN listenelemente initialisieren;
+ FI;
+ IF aktueller eintrag = ""
+ THEN namens eintrag
+ FI;
+ aktueller eintrag CAT " ";
+ aktueller eintrag CAT text (line number);
+ aktueller eintrag CAT zusatz.
+
+aktueller eintrag:
+ liste [index].
+
+listenelemente initialisieren:
+ INT VAR i;
+ FOR i FROM max index + 1 UPTO index REP
+ liste [i] := ""
+ END REP;
+ max index := index.
+
+namens eintrag:
+ get name (index, aktueller eintrag);
+ WHILE length (aktueller eintrag) < 15 REP
+ aktueller eintrag CAT " "
+ END REP;
+ aktueller eintrag CAT ":".
+END PROC in die liste;
+
+TEXT VAR zeile;
+
+PROC in dump file kopieren (TEXT CONST dump file):
+ putline ("Ausgabedatei erstellen");
+ f := sequential file (output, dump file);
+ INT VAR i;
+ kopieren und ggf fehlermeldung;
+ modify (f);
+ ggf sortieren;
+ zeile ggf aufspalten;
+ modify (f);
+ to line (f, 1).
+
+kopieren und ggf fehlermeldung:
+ FOR i FROM fi symbol UPTO max index REP
+ cout (i);
+ zeile := liste [i];
+ IF zeile <> ""
+ THEN ausgabe der referenz und ggf fehlermeldung
+ FI
+ ENDREP.
+
+ausgabe der referenz und ggf fehlermeldung:
+ putline (f, zeile);
+ ggf referencer fehlermeldung.
+
+ggf sortieren:
+ IF yes (dump file + " sortieren")
+ THEN sort (dump file);
+ FI.
+
+zeile ggf aufspalten:
+ i := 0;
+ to line (f, 1);
+ WHILE NOT eof (f) REP
+ i INCR 1;
+ cout (i);
+ read record (f, zeile);
+ ggf aufspalten
+ END REP.
+
+ggf aufspalten:
+INT VAR anf :: 1, ende :: pos (zeile, " ", 72);
+ IF ende > 0
+ THEN dummy := subtext (zeile, 1, ende - 1);
+ write record (f, dummy);
+ spalte bis restzeile auf;
+ dummy CAT subtext (zeile, anf);
+ write record (f, dummy);
+ FI;
+ down (f).
+
+spalte bis restzeile auf:
+ REP
+ dummy := " ";
+ anf := ende + 1;
+ ende := pos (zeile, " ", ende + 55);
+ down (f);
+ insert record (f);
+ IF ende <= 0
+ THEN LEAVE spalte bis restzeile auf
+ FI;
+ dummy CAT subtext (zeile, anf, ende - 1);
+ write record (f, dummy);
+ END REP.
+END PROC in dump file kopieren;
+
+PROC ggf referencer fehlermeldung:
+ name := subtext (zeile, 1, min( pos(zeile, " "), pos(zeile, ":")) - 1);
+ dummy := subtext (zeile, pos (zeile, ": ") + 2);
+ ueberdeckungs ueberpruefung;
+ not used ueberpruefung;
+ IF pos (dummy, "R") > 0
+ THEN refinement mehr als zweimal verwendet
+ FI.
+
+ueberdeckungs ueberpruefung:
+ IF pos (dummy, global text) > 0 AND pos (dummy, local text) > 0
+ THEN dummy2 := "und Zeile ";
+ dummy2 CAT text (nr (pos (dummy, local text)));
+ dummy2 CAT ": ";
+ dummy2 CAT name;
+ report referencer error
+ (5, nr (pos (dummy, global text)), dummy2)
+ FI.
+
+not used ueberpruefung:
+ IF pos (dummy, " ") = 0 AND
+ (pos (dummy, global text) > 0 OR pos (dummy, local text) > 0 OR
+ pos (dummy, refinement text) > 0)
+ THEN not used fehlermeldung
+ FI.
+
+not used fehlermeldung:
+ report referencer error
+ (8, nr (length (dummy) - length (local text) + 1), name).
+
+refinement mehr als zweimal verwendet:
+ INT VAR refinement deklarationen :: 0,
+ refinement aufrufe :: 0,
+ anf :: 1;
+ WHILE pos (dummy,"R", anf) > 0 REP
+ refinement deklarationen INCR 1;
+ anf := pos (dummy, "R", anf) + 1
+ END REP;
+ anf := 1;
+ WHILE pos (dummy, " ", anf) > 0 REP
+ refinement aufrufe INCR 1;
+ anf := pos (dummy, " ", anf) + 1
+ END REP;
+ IF refinement deklarationen = 1
+ THEN IF refinement aufrufe > 1
+ THEN report referencer error
+ (6, nr (pos (dummy, refinement text)), name)
+ ELIF refinement aufrufe = 0
+ THEN report referencer error
+ (7, nr (pos (dummy, refinement text)), name)
+ FI
+ ELIF refinement deklarationen > 1
+ THEN IF 2 * refinement deklarationen - 1 > refinement aufrufe
+ THEN report referencer error (9, 0, name)
+ ELIF 2 * refinement deklarationen - 1 < refinement aufrufe
+ THEN report referencer error (10, 0, name)
+ FI
+ FI.
+END PROC ggf referencer fehlermeldung;
+
+INT PROC nr (INT CONST ende):
+ INT VAR von :: ende - 1;
+ WHILE von > 0 AND ((dummy SUB von) >= "0" AND (dummy SUB von) <= "9") REP
+ von DECR 1
+ END REP;
+ int (subtext (dummy, von + 1, ende - 1))
+END PROC nr;
+END PACKET referencer2;
+
+(*
+REP
+ referencer ("ref fehler");
+ edit ("ref fehler.r");
+UNTIL no ("nochmal") END REP*)
+
diff --git a/system/std.zusatz/1.8.7/src/reporter b/system/std.zusatz/1.8.7/src/reporter
new file mode 100644
index 0000000..4febc32
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/reporter
@@ -0,0 +1,531 @@
+(* ------------------- VERSION 12 vom 06.08.86 -------------------- *)
+PACKET reporter routines DEFINES generate counts,
+ count on,
+ count off,
+ generate reports,
+ eliminate reports,
+ assert,
+ report on,
+ report off,
+ report:
+
+(* Programm zur Ablaufverfolgung von ELAN Programmen. Das Programm
+ verfolgt Prozedur- und Refinementaufrufe ('trace') und erstellt
+ eine Haeufigkeitszaehlung ('count') und beachtet 'assertions'.
+ Autor: Rainer Hahn *)
+
+FILE VAR input file;
+
+INT VAR zeilen nr,
+ type;
+
+TEXT VAR zeile,
+ dummy,
+ dummy1,
+ symbol;
+
+LET quadro fis = "####",
+ triple fis = "###",
+ double fis = "##",
+ tag = 1,
+ bold = 2;
+
+DATASPACE VAR ds := nilspace;
+BOUND ROW max STRUCT (INT anzahl, BOOL proc) VAR zaehlwerk;
+
+LET max = 3000;
+
+(******************* gen report-Routinen ******************************)
+
+PROC generate reports:
+ generate reports (last param)
+END PROC generate reports;
+
+PROC generate reports (TEXT CONST name):
+ disable stop;
+ gen trace statements (name);
+ IF is error AND error message = "ende"
+ THEN clear error;
+ last param (name)
+ FI;
+ to line (input file, 1);
+ enable stop.
+END PROC generate reports;
+
+PROC gen trace statements (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ input file modifizieren
+END PROC gen trace statements;
+
+(*************************** Test file modifizieren *****************)
+
+PROC input file modifizieren:
+ zeilen nr := 1;
+ to line (input file, 1);
+ col (input file, 1);
+ REP
+ lese zeile;
+ IF triple fis symbol
+ THEN wandele in quadro fis
+ FI;
+ IF proc oder op symbol
+ THEN verarbeite operator oder prozedurkopf
+ ELIF refinement symbol
+ THEN verarbeite ggf refinements
+ FI;
+ vorwaerts
+ END REP.
+
+triple fis symbol:
+ pos (zeile, triple fis) > 0 AND
+ (pos (zeile, triple fis) <> pos (zeile, quadro fis)).
+
+wandele in quadro fis:
+ change all (zeile, triple fis, quadro fis);
+ write record (input file, zeile).
+
+proc oder op symbol:
+ pos (zeile, "PROC") > 0 OR pos (zeile, "OP") > 0.
+
+verarbeite operator oder prozedurkopf:
+ scan (zeile);
+ symbol lesen;
+ IF symbol = "PROC" OR symbol = "OP"
+ THEN
+ ELIF symbol = "END"
+ THEN LEAVE verarbeite operator oder prozedurkopf
+ ELIF type = bold
+ THEN next symbol (symbol, type);
+ IF NOT (symbol = "PROC" OR symbol = "OP")
+ THEN LEAVE verarbeite operator oder prozedurkopf
+ FI
+ ELSE LEAVE verarbeite operator oder prozedurkopf
+ FI;
+ scanne kopf;
+ insertiere trace anweisung.
+
+scanne kopf:
+ dummy := double fis;
+ dummy CAT "report(""";
+ dummy CAT text (line no (input file) + 1);
+ dummy CAT ": ";
+ dummy CAT symbol; (* PROC oder OP *)
+ dummy CAT " ";
+ symbol lesen;
+ dummy CAT symbol;
+ fuege bis namens ende an;
+ dummy CAT " ";
+ ueberlese ggf parameterliste.
+
+fuege bis namens ende an:
+ REP
+ symbol lesen;
+ IF symbol = "(" OR symbol = ":"
+ THEN LEAVE fuege bis namensende an
+ FI;
+ dummy CAT symbol
+ END REP.
+
+ueberlese ggf parameterliste:
+ WHILE symbol <> ":" REP
+ symbol lesen
+ END REP.
+
+insertiere trace anweisung:
+ WHILE pos (zeile, ":") = 0 REP
+ vorwaerts;
+ lese zeile
+ END REP;
+ schreibe zeile mit report statement.
+
+refinement symbol:
+ INT CONST point pos := pos (zeile, ".") ;
+ point pos > 0 AND point pos >= length (zeile) - 1.
+
+verarbeite ggf refinements:
+ ueberlies leere zeilen ;
+ IF ist wirklich refinement
+ THEN insertiere report fuer refinement
+ FI .
+
+ueberlies leere zeilen :
+ REP
+ vorwaerts;
+ lese zeile
+ UNTIL pos (zeile, ""33"", ""254"", 1) > 0 PER .
+
+ist wirklich refinement :
+ scan (zeile) ;
+ next symbol (symbol, type) ;
+ next symbol (symbol) ;
+ symbol = ":" AND type = tag .
+
+insertiere report fuer refinement:
+ dummy := double fis;
+ dummy CAT "report("" ";
+ dummy CAT text (line no (input file) + 1);
+ dummy CAT ": ";
+ dummy1 := subtext (zeile, 1, pos (zeile, ":") - 1);
+ dummy CAT dummy1;
+ schreibe zeile mit report statement
+END PROC input file modifizieren;
+
+PROC schreibe zeile mit report statement:
+ dummy CAT """);";
+ dummy CAT double fis;
+ IF doppelpunkt steht am ende der zeile
+ THEN vorwaerts;
+ insert record (input file);
+ write record (input file, dummy)
+ ELSE insert char (dummy, ":", 1);
+ change (zeile, ":", dummy);
+ write record (input file, zeile)
+ FI.
+
+doppelpunkt steht am ende der zeile:
+ (zeile SUB length (zeile)) = ":" OR (zeile SUB length (zeile) - 1) = ":".
+END PROC schreibe zeile mit report statement;
+
+PROC symbol lesen:
+ next symbol (symbol, type);
+ IF ende der zeile gescannt
+ THEN vorwaerts;
+ lese zeile;
+ continue scan (zeile);
+ next symbol (symbol, type)
+ FI.
+
+ende der zeile gescannt:
+ type >= 7.
+END PROC symbol lesen;
+
+PROC vorwaerts:
+ IF eof (input file)
+ THEN errorstop ("ende")
+ FI;
+ down (input file);
+ IF eof (input file)
+ THEN errorstop ("ende")
+ FI
+END PROC vorwaerts;
+
+PROC lese zeile:
+ read record (input file, zeile);
+ cout (zeilen nr);
+ zeilen nr INCR 1
+END PROC lese zeile;
+
+(************************ eliminate reports-Routinen ******************)
+
+PROC eliminate reports:
+ eliminate reports (last param)
+END PROC eliminate reports;
+
+PROC eliminate reports (TEXT CONST name):
+ disable stop;
+ eliminate statements (name);
+ IF is error AND error message = "ende"
+ THEN clear error;
+ last param (name)
+ FI;
+ to line (input file, 1);
+ enable stop.
+END PROC eliminate reports;
+
+PROC eliminate statements (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ statements entfernen.
+
+statements entfernen:
+ to line (input file, 1);
+ col (input file, 1);
+ zeilen nr := 1;
+ WHILE NOT eof (input file) REP
+ lese zeile;
+ IF pos (zeile, double fis) > 0
+ THEN eliminiere zeichenketten in dieser zeile
+ ELSE vorwaerts
+ FI
+ END REP.
+
+eliminiere zeichenketten in dieser zeile:
+ INT VAR anfang := pos (zeile, double fis);
+ WHILE es ist noch etwas zu eliminieren REP
+ IF es ist ein quadro fis
+ THEN wandele es in ein triple fis
+ ELIF es ist ein triple fis
+ THEN lass diese sequenz stehen
+ ELSE entferne zeichenkette
+ FI
+ END REP;
+ IF zeile ist jetzt leer
+ THEN delete record (input file)
+ ELSE write record (input file, zeile);
+ vorwaerts
+ FI.
+
+es ist noch etwas zu eliminieren:
+ anfang > 0.
+
+es ist ein quadro fis:
+ pos (zeile, quadro fis, anfang) = anfang.
+
+wandele es in ein triple fis:
+ delete char (zeile, anfang);
+ anfang := pos (zeile, double fis, anfang + 3).
+
+es ist ein triple fis:
+ pos (zeile, triple fis, anfang) = anfang.
+
+lass diese sequenz stehen:
+ anfang := pos (zeile, triple fis, anfang + 1) + 3.
+
+entferne zeichenkette:
+ INT VAR end := pos (zeile, double fis, anfang+2) ;
+ IF end > 0
+ THEN change (zeile, anfang, end + 1, "");
+ anfang := pos (zeile, double fis, anfang)
+ ELSE anfang := pos (zeile, double fis, anfang+2)
+ FI .
+
+zeile ist jetzt leer:
+ pos (zeile, ""33"", ""254"", 1) = 0.
+END PROC eliminate statements;
+
+(********************** Trace-Routinen *******************************)
+
+FILE VAR trace file;
+
+BOOL VAR zaehlwerk initialisiert :: FALSE,
+ trace on,
+ haeufigkeit on;
+
+PROC report (TEXT CONST message):
+ IF exists ("TRACE")
+ THEN
+ ELSE trace on := TRUE;
+ haeufigkeit on := FALSE;
+ FI;
+ BOOL CONST ist prozedur ::
+ pos (message, "PROC") > 0 OR pos (message, "OP") > 0;
+ trace file := sequential file (modify, "TRACE");
+ IF lines (trace file) <= 0
+ THEN insert record (trace file);
+ write record (trace file, "")
+ ELSE to line (trace file, lines (trace file));
+ read record (trace file, dummy);
+ IF dummy <> ""
+ THEN down (trace file);
+ insert record (trace file);
+ write record (trace file, "")
+ FI
+ FI;
+ IF trace on
+ THEN write record (trace file, message);
+ down (trace file);
+ insert record (trace file);
+ write record (trace file, "")
+ FI;
+ IF haeufigkeit on
+ THEN haeufigkeits zaehlung
+ FI.
+
+haeufigkeits zaehlung:
+ hole zeilen nr;
+ zaehle mit.
+
+hole zeilen nr:
+ INT CONST von pos :: pos (message, ""33"", ""254"", 1);
+ zeilen nr :=
+ int (subtext (message, von pos, pos (message, ":", von pos + 1) - 1)).
+
+zaehle mit:
+ IF last conversion ok AND zeilen nr > 0 AND zeilen nr <= max
+ THEN zaehlwerk [zeilen nr] . anzahl INCR 1;
+ zaehlwerk [zeilen nr] . proc := ist prozedur
+ FI
+END PROC report;
+
+PROC report (TEXT CONST message, INT CONST value):
+ report (message, text (value))
+END PROC report;
+
+PROC report (TEXT CONST message, REAL CONST value):
+ report (message, text (value))
+END PROC report;
+
+PROC report (TEXT CONST message, TEXT CONST value):
+ dummy1 := message;
+ dummy1 CAT ": ";
+ dummy1 CAT value;
+ report (dummy1)
+END PROC report;
+
+PROC report (TEXT CONST message, BOOL CONST value):
+ dummy1 := message;
+ dummy1 CAT ": ";
+ IF value
+ THEN dummy1 CAT "TRUE"
+ ELSE dummy1 CAT "FALSE"
+ FI;
+ report (dummy1)
+END PROC report;
+
+PROC report on:
+ trace on := TRUE;
+ dummy1 := "REPORT ---> ON";
+ report (dummy1)
+END PROC report on;
+
+PROC report off:
+ dummy1 := "REPORT ---> OFF";
+ report (dummy1);
+ trace on := FALSE;
+END PROC report off;
+
+PROC assert (BOOL CONST value):
+ assert ("", value)
+END PROC assert;
+
+PROC assert (TEXT CONST message, BOOL CONST value):
+ dummy1 := "ASSERTION:";
+ dummy1 CAT message;
+ dummy1 CAT " ---> ";
+ IF value
+ THEN dummy1 CAT "TRUE"
+ ELSE line;
+ put ("ASSERTION:");
+ put (message);
+ put ("---> FALSE");
+ line;
+ IF yes ("weiter")
+ THEN dummy1 CAT "FALSE"
+ ELSE errorstop ("assertion failed")
+ FI
+ FI;
+ report (dummy1)
+END PROC assert;
+
+(************************** haeufigkeits-zaehlung ****************)
+
+PROC count on:
+ report ("COUNT ---> ON");
+ haeufigkeit on := TRUE;
+ initialisiere haeufigkeit.
+
+initialisiere haeufigkeit:
+ INT VAR i;
+ forget (ds);
+ ds := nilspace;
+ zaehlwerk initialisiert := TRUE;
+ zaehlwerk := ds;
+ FOR i FROM 1 UPTO max REP
+ zaehlwerk [i] . anzahl := 0
+ END REP
+END PROC count on;
+
+PROC count off:
+ report ("COUNT ---> OFF");
+ haeufigkeit on := FALSE
+END PROC count off;
+
+PROC generate counts:
+ generate counts (last param)
+END PROC generate counts;
+
+PROC generate counts (TEXT CONST name):
+ disable stop;
+ insert counts (name);
+ last param (name);
+ to line (input file, 1);
+ enable stop.
+END PROC generate counts;
+
+PROC insert counts (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name);
+ col (input file, 1)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ IF NOT zaehlwerk initialisiert
+ THEN errorstop ("count nicht eingeschaltet")
+ FI;
+ counts insertieren;
+ dataspace loeschen;
+ statistik ausgeben.
+
+counts insertieren:
+ REAL VAR gesamt aufrufe :: 0.0,
+ proc aufrufe :: 0.0,
+ andere aufrufe :: 0.0;
+ zeilen nr := 1;
+ WHILE zeilen nr <= lines (input file) REP
+ cout (zeilen nr);
+ IF zaehlwerk [zeilen nr] . anzahl > 0
+ THEN anzahl aufrufe in die eingabe zeile einfuegen;
+ aufrufe mitzaehlen
+ FI;
+ zeilen nr INCR 1
+ END REP.
+
+anzahl aufrufe in die eingabe zeile einfuegen:
+ to line (input file, zeilen nr);
+ read record (input file, zeile);
+ dummy := double fis;
+ dummy CAT text (zaehlwerk [zeilen nr] . anzahl);
+ dummy CAT double fis;
+ change (zeile, 1, 0, dummy);
+ write record (input file, zeile).
+
+aufrufe mitzaehlen:
+ gesamt aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl);
+ IF zaehlwerk [zeilen nr] . proc
+ THEN proc aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl)
+ ELSE andere aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl)
+ FI.
+
+dataspace loeschen:
+ zaehlwerk initialisiert := FALSE;
+ forget (ds).
+
+statistik ausgeben:
+ line (2);
+ put ("Anzahl der Gesamtaufrufe:");
+ ggf int put (gesamt aufrufe);
+ line;
+ put ("davon:");
+ line;
+ ggf int put (proc aufrufe); put ("Prozeduren oder Operatoren");
+ line;
+ ggf int put (andere aufrufe); put ("Refinements und andere");
+ line.
+END PROC insert counts;
+
+PROC ggf int put (REAL CONST wert):
+ IF wert >= real (maxint)
+ THEN put (wert)
+ ELSE put (int (wert))
+ FI
+END PROC ggf int put;
+END PACKET reporter routines;
+(*
+REP
+ IF exists ("rep fehler")
+ THEN copy ("rep fehler", "zzz")
+ ELSE errorstop ("rep fehler exisitiert nicht")
+ FI;
+ generate reports ("zzz");
+ edit("zzz");
+ forget ("zzz")
+UNTIL no ("nochmal") END REP;
+edit("reporter")*)
+
diff --git a/system/std.zusatz/1.8.7/src/scheduler b/system/std.zusatz/1.8.7/src/scheduler
new file mode 100644
index 0000000..cba48e0
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/scheduler
@@ -0,0 +1,420 @@
+
+PACKET std schedule strategy DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 15.10.82 *)
+ strategic decision :
+
+
+PROC strategic decision
+ (INT CONST foreground workers, background workers,
+ REAL CONST fore cpu load, back cpu load, paging load,
+ INT VAR lowest activation prio, max background tasks) :
+
+ IF no background permitted
+ THEN lowest activation prio := 0 ;
+ max background tasks := 0
+ ELSE lowest activation prio := 10 ;
+ select max background tasks
+ FI .
+
+no background permitted :
+ foreground workers > 0 AND fore cpu load > 0.03 .
+
+select max background tasks :
+ IF fore cpu load > 0.01
+ THEN max background tasks := 1
+ ELIF paging load < 0.07
+ THEN max background tasks := 3
+ ELIF paging load < 0.15
+ THEN max background tasks := 2
+ ELSE max background tasks := 1
+ FI .
+
+ENDPROC strategic decision ;
+
+ENDPACKET std schedule strategy ;
+
+
+ (* Autor: J.Liedtke*)
+PACKET eumelmeter DEFINES (* Stand: 11.10.83 *)
+
+ init log ,
+ log :
+
+
+LET snapshot interval = 590.0 ;
+
+REAL VAR next snapshot time ,
+ time , timex ,
+ paging wait , paging wait x ,
+ paging busy , paging busy x ,
+ fore cpu , fore cpu x ,
+ back cpu , back cpu x ,
+ system cpu , system cpu x ,
+ delta t ;
+INT VAR storage max, used ;
+TEXT VAR record ;
+
+PROC init log :
+
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ next snapshot time := time + snapshot interval
+
+ENDPROC init log ;
+
+PROC log (INT CONST active terminals, active background) :
+
+ new snapshot time if was clock reset ;
+ IF clock (1) >= next snapshot time
+ THEN save values ;
+ get new values ;
+ create stat record ;
+ put log (record) ;
+ define next snapshot time
+ FI .
+
+new snapshot time if was clock reset :
+ IF clock (1) < next snapshot time - snapshot interval
+ THEN next snapshot time := clock (1)
+ FI .
+
+save values :
+ time x := time ;
+ paging wait x := paging wait ;
+ paging busy x := paging busy ;
+ fore cpu x := fore cpu ;
+ back cpu x := back cpu ;
+ system cpu x := system cpu .
+
+get new values :
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ storage (storage max, used) .
+
+create stat record :
+ record := text (used, 5) ;
+ record CAT text (active terminals,3) ;
+ record CAT text (active background,3) ;
+ delta t := (time - time x) ;
+ percent (paging wait, paging wait x) ;
+ percent (paging busy, paging busy x) ;
+ percent (fore cpu, fore cpu x) ;
+ percent (back cpu, back cpu x) ;
+ percent (system cpu, system cpu x) ;
+ percent (last, 0.0) ;
+ percent (nutz, 0.0) .
+
+last : paging wait + paging busy + fore cpu + back cpu + system cpu
+ - paging waitx - paging busyx - fore cpux - back cpux - system cpux .
+
+nutz : time - paging wait - system cpu
+ - timex + paging waitx + system cpux .
+
+define next snapshot time :
+ next snapshot time := time + snapshot interval .
+
+ENDPROC log ;
+
+PROC percent (REAL CONST neu, alt ) :
+
+ record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%"
+
+ENDPROC percent ;
+
+ENDPACKET eumelmeter ;
+
+
+
+PACKET background que manager DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 15.10.82 *)
+ into background que ,
+ delete from background que ,
+ get first from background que ,
+ get next from background que :
+
+LET que size = 100 ,
+ ENTRY = STRUCT (TASK task, INT class) ;
+
+INT VAR end of que := 0 ,
+ actual entry pos ;
+
+ROW que size ENTRY VAR que ;
+
+
+PROC into background que (TASK CONST task) :
+
+ INT VAR class := prio (task) ;
+ IF end of que = que size
+ THEN delete all not existing tasks
+ FI ;
+ check whether already in que ;
+ IF already in que
+ THEN IF in same class
+ THEN LEAVE into background que
+ ELSE delete from background que (task) ;
+ into background que (task)
+ FI
+ ELSE insert new entry
+ FI .
+
+check whether already in que :
+ INT VAR entry pos := 1 ;
+ WHILE entry pos <= end of que REP
+ IF que (entry pos).task = task
+ THEN LEAVE check whether already in que
+ FI ;
+ entry pos INCR 1
+ PER .
+
+already in que : entry pos <= end of que .
+
+in same class : que (entry pos).class = class .
+
+insert new entry :
+ end of que INCR 1 ;
+ que (end of que) := ENTRY:( task, class ) .
+
+delete all not existing tasks :
+ INT VAR j ;
+ FOR j FROM 1 UPTO end of que REP
+ TASK VAR examined := que (j).task ;
+ IF NOT exists (examined)
+ THEN delete from background que (examined)
+ FI
+ PER .
+
+ENDPROC into background que ;
+
+PROC delete from background que (TASK CONST task) :
+
+ search for entry ;
+ IF entry found
+ THEN delete entry ;
+ update actual entry pos
+ FI .
+
+search for entry :
+ INT VAR entry pos := 1 ;
+ WHILE entry pos <= end of que REP
+ IF que (entry pos).task = task
+ THEN LEAVE search for entry
+ FI ;
+ entry pos INCR 1
+ PER .
+
+entry found : entry pos <= end of que .
+
+delete entry :
+ INT VAR i ;
+ FOR i FROM entry pos UPTO end of que - 1 REP
+ que (i) := que (i+1)
+ PER ;
+ end of que DECR 1 .
+
+update actual entry pos :
+ IF actual entry or following one deleted
+ THEN actual entry pos DECR 1
+ FI .
+
+actual entry or following one deleted :
+ entry pos >= actual entry pos .
+
+ENDPROC delete from background que ;
+
+PROC get first from background que (TASK VAR task, INT CONST lowest class) :
+
+ actual entry pos := 0 ;
+ get next from background que (task, lowest class)
+
+ENDPROC get first from background que ;
+
+PROC get next from background que (TASK VAR task, INT CONST lowest class) :
+
+ search next entry of permitted class ;
+ IF actual entry pos <= end of que
+ THEN task := que (actual entry pos).task
+ ELSE task := niltask
+ FI .
+
+search next entry of permitted class :
+ REP
+ actual entry pos INCR 1
+ UNTIL actual entry pos > end of que
+ COR que (actual entry pos).class <= lowest class PER.
+
+ENDPROC get next from background que ;
+
+ENDPACKET background que manager ;
+
+
+
+PACKET scheduler DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 09.12.82 *)
+ scheduler :
+
+
+LET std background prio = 7 ,
+ highest background prio = 5 ,
+ long slice = 6000 ,
+ short slice = 600 ,
+ blocked busy = 4 ;
+
+INT VAR slice ,
+ foreground workers ,
+ background workers ;
+
+BOOL VAR is logging ;
+
+REAL VAR fore cpu load , back cpu load , paging load ;
+
+
+access catalogue ;
+TASK CONST ur task := brother (supervisor) ;
+
+TASK VAR actual task ;
+
+
+PROC scheduler :
+ IF yes ("mit eumelmeter")
+ THEN is logging := TRUE
+ ELSE is logging := FALSE
+ FI ;
+ task password ("-") ;
+ break ;
+ set autonom ;
+ command dialogue (FALSE) ;
+ forget ("scheduler", quiet) ;
+ disable stop;
+ REP scheduler operation;
+ clear error
+ PER;
+
+END PROC scheduler;
+
+PROC scheduler operation:
+ enable stop;
+ IF is logging
+ THEN init log
+ FI;
+ slice := short slice ;
+ init system load moniting ;
+ REP
+ pause (slice) ;
+ monit system load ;
+ look at all active user tasks and block background workers ;
+ activate next background workers if possible ;
+ IF is logging
+ THEN log (foreground workers, background workers)
+ FI
+ PER .
+
+init system load moniting :
+ REAL VAR
+ time x := clock (1) ,
+ fore cpu x := clock (4) ,
+ back cpu x := clock (5) ,
+ paging x := clock (2) + clock (3) .
+
+monit system load :
+ REAL VAR interval := clock (1) - time x ;
+ fore cpu load := (clock (4) - fore cpu x) / interval ;
+ back cpu load := (clock (5) - back cpu x) / interval ;
+ paging load := (clock (2) + clock (3) - paging x) / interval ;
+ time x := clock (1) ;
+ fore cpu x := clock (4) ;
+ back cpu x := clock (5) ;
+ paging x := clock (2) + clock (3) .
+
+ENDPROC scheduler operation;
+
+PROC look at all active user tasks and block background workers :
+
+ foreground workers := 0 ;
+ background workers := 0 ;
+ actual task := myself ;
+ next active (actual task) ;
+ WHILE NOT (actual task = myself) REP
+ IF actual task < ur task
+ THEN look at this task
+ FI ;
+ next active (actual task)
+ END REP .
+
+look at this task :
+ IF channel (actual task) >= 0
+ THEN foreground workers INCR 1
+ ELSE background workers INCR 1 ;
+ block actual task if simple worker
+ FI .
+
+block actual task if simple worker :
+ IF son (actual task) = niltask
+ THEN pause (5) ;
+ block (actual task) ;
+ IF status (actual task) = blocked busy
+ THEN set background prio ;
+ into background que (actual task)
+ ELIF prio (actual task) < highest background prio
+ THEN unblock (actual task)
+ FI
+ FI .
+
+set background prio :
+ IF prio (actual task) < highest background prio
+ THEN prio (actual task, std background prio)
+ FI .
+
+ENDPROC look at all active user tasks and block background workers ;
+
+PROC activate next background workers if possible :
+
+ INT VAR lowest activation prio ,
+ max background workers ,
+ active background workers := 0 ;
+
+ strategic decision (foreground workers, background workers,
+ fore cpu load, back cpu load, paging load,
+ lowest activation prio, max background workers) ;
+
+ IF background permitted
+ THEN try to activate background workers
+ FI ;
+ IF active background workers > 0
+ THEN slice := short slice
+ ELSE slice := long slice
+ FI .
+
+background permitted : max background workers > 0 .
+
+try to activate background workers :
+ get first from background que (actual task, lowest activation prio) ;
+ IF NOT is niltask (actual task)
+ THEN delete from background que (actual task)
+ FI ;
+
+ WHILE active background workers < max background workers REP
+ IF is niltask (actual task)
+ THEN LEAVE try to activate background workers
+ ELIF status (actual task) <> blocked busy
+ THEN delete from background que (actual task)
+ ELSE
+ unblock (actual task) ;
+ active background workers INCR 1
+ FI ;
+ get next from background que (actual task, lowest activation prio)
+ PER .
+
+ENDPROC activate next background workers if possible ;
+
+ENDPACKET scheduler ;
+
+scheduler;
+
diff --git a/system/std.zusatz/1.8.7/src/spool cmd b/system/std.zusatz/1.8.7/src/spool cmd
new file mode 100644
index 0000000..9b43d36
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/spool cmd
@@ -0,0 +1,178 @@
+PACKET spool cmd (* Autor : R. Ruland *)
+ (* Stand : 13.08.87 *)
+ DEFINES
+ spool control password,
+
+ kill spool,
+ first spool,
+ start spool,
+ stop spool,
+ halt spool,
+ wait for halt :
+
+LET error nak = 2 ,
+
+ entry line code = 23 ,
+ killer code = 24 ,
+ first code = 25 ,
+ start code = 26 ,
+ stop code = 27 ,
+ halt code = 28 ,
+ wait for halt code = 29 ;
+
+DATASPACE VAR ds;
+
+BOUND STRUCT (TEXT entry line, INT index, TEXT actual entries, password) VAR control msg;
+BOUND TEXT VAR error msg;
+INT VAR reply;
+
+INITFLAG VAR in this task := FALSE;
+BOOL VAR dialogue;
+TEXT VAR control password, password;
+
+control password := "";
+
+PROC spool control password (TEXT CONST new password):
+
+ IF on line THEN say (""3""13""5"") FI;
+ disable stop;
+ do ("enter spool control password (""" + new password + """)");
+ clear error;
+ no do again;
+ cover tracks;
+ cover tracks (control password);
+ control password := new password;
+
+END PROC spool control password;
+
+
+PROC call spool (INT CONST op code, TEXT CONST name, TASK CONST spool) :
+
+ dialogue := command dialogue;
+ password := write password;
+ password CAT "/";
+ password CAT read password;
+ disable stop;
+ command dialogue (FALSE);
+ enter password (control password);
+ command dialogue (dialogue);
+ call (op code, name, spool);
+ command dialogue (FALSE);
+ enter password (password);
+ command dialogue (dialogue);
+
+END PROC call spool;
+
+
+PROC start spool (TASK CONST spool) :
+
+ enable stop;
+ call spool (halt code, "", spool);
+ call spool (start code, "", spool);
+
+END PROC start spool;
+
+
+PROC start spool (TASK CONST spool, INT CONST new channel) :
+
+ enable stop;
+ call spool (halt code, "", spool);
+ call spool (start code, text (new channel), spool);
+
+END PROC start spool;
+
+
+PROC stop spool (TASK CONST spool) :
+
+ call spool (stop code, "", spool);
+
+END PROC stop spool;
+
+PROC stop spool (TASK CONST spool, TEXT CONST deactive msg) :
+
+ call spool (stop code, deactive msg, spool);
+
+END PROC stop spool;
+
+
+PROC halt spool (TASK CONST spool) :
+
+ call spool (halt code, "", spool);
+
+END PROC halt spool;
+
+PROC halt spool (TASK CONST spool, TEXT CONST deactive msg) :
+
+ call spool (halt code, deactive msg, spool);
+
+END PROC halt spool;
+
+
+PROC wait for halt (TASK CONST spool) :
+
+ call spool (wait for halt code, "", spool);
+
+END PROC wait for halt;
+
+PROC wait for halt (TASK CONST spool, TEXT CONST deactive msg) :
+
+ call spool (wait for halt code, deactive msg, spool);
+
+END PROC wait for halt;
+
+
+PROC control spool (TASK CONST spool, INT CONST control code,
+ TEXT CONST question, BOOL CONST leave) :
+
+ enable stop;
+ initialize control msg;
+ WHILE valid spool entry
+ REP IF control question THEN control spool entry FI PER;
+
+ . initialize control msg :
+ IF NOT initialized (in this task) THEN ds := nilspace FI;
+ forget (ds); ds := nilspace; control msg := ds;
+ control msg. entry line := "";
+ control msg. password := control password;
+ control msg. index := 0;
+ say (""13""10"");
+
+ . valid spool entry :
+ call (spool, entry line code, ds, reply);
+ IF reply = error nak
+ THEN error msg := ds;
+ errorstop (error msg);
+ FI;
+ control msg. index <> 0
+
+ . control question :
+ say (control msg. entry line);
+ yes (question)
+
+ . control spool entry :
+ call (spool, control code, ds, reply);
+ IF reply = error nak
+ THEN error msg := ds;
+ errorstop (error msg);
+ FI;
+ IF leave THEN LEAVE control spool FI;
+
+END PROC control spool;
+
+
+PROC kill spool (TASK CONST spool) :
+
+ control spool (spool, killer code, " loeschen", FALSE)
+
+END PROC kill spool;
+
+
+PROC first spool (TASK CONST spool) :
+
+ control spool (spool, first code, " als erstes", TRUE)
+
+END PROC first spool;
+
+
+END PACKET spool cmd;
+
diff --git a/system/std.zusatz/1.8.7/src/spool manager b/system/std.zusatz/1.8.7/src/spool manager
new file mode 100644
index 0000000..6b4fe55
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/spool manager
@@ -0,0 +1,1058 @@
+PACKET spool manager DEFINES (* Autor : R. Ruland *)
+ (* Stand : 23.02.88 *)
+
+ spool manager ,
+
+ server channel ,
+ spool duty,
+ station only,
+ auto stop,
+ enter spool control password,
+ spool control password,
+
+ start spool,
+ stop spool,
+ halt spool,
+ kill spool,
+ first spool,
+ spool entry line,
+ number spool entries,
+ spool status,
+ server task,
+ clear spool,
+ list spool,
+ :
+
+LET que size = 200 ,
+
+ ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ second phase ack = 5 ,
+ false code = 6 ,
+
+ fetch code = 11 ,
+ save code = 12 ,
+ exists code = 13 ,
+ erase code = 14 ,
+ list code = 15 ,
+ all code = 17 ,
+ param fetch code = 21 ,
+ file save code = 22 ,
+ entry line code = 23 ,
+ killer code = 24 ,
+ first code = 25 ,
+ start code = 26 ,
+ stop code = 27 ,
+ halt code = 28 ,
+ wait for halt code = 29 ,
+ help code = 49 ,
+ continue code = 100 ,
+
+ control codes = ""23""24""25""26""27""28""29"" ,
+
+ file type = 1003 ,
+ help file name = "help";
+
+LET begin char = ""0"",
+ end char = ""1"";
+
+LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station);
+
+BOUND ROW que size STRUCT (PARAMS ds params, TEXT entry line) VAR que;
+
+ ROW que size DATASPACE VAR que space;
+
+PARAMS VAR save params;
+
+DATASPACE VAR que ds, global ds;
+
+FILE VAR file;
+
+INT VAR last order, reply, old heap size, que index, fetch index,
+ station by start, begin pos, end pos, order task station, sp channel;
+
+TEXT VAR que entries, free entries, order task name, buffer, deactive message,
+ error message buffer, sp duty, start time, control password;
+
+BOOL VAR server is waiting, stop cmd pending, start cmd pending,
+ auto stop pending, stat only;
+
+TASK VAR last order task, server, calling parent, task in control;
+
+INITFLAG VAR in this task := FALSE, init que space := FALSE;
+
+BOUND STRUCT (TEXT name, userid, password) VAR msg;
+BOUND STRUCT (TEXT entry line, INT index, TEXT actual entries, password) VAR control msg;
+BOUND PARAMS VAR fetch msg;
+BOUND THESAURUS VAR all msg;
+BOUND TEXT VAR error msg;
+
+
+. que is empty : que entries = ""
+. que is full : free entries = ""
+. number entries : LENGTH que entries
+
+. first index : code (que entries SUB 1)
+. list index : code (que entries SUB que index)
+. last index : code (que entries SUB number entries)
+
+. fetch entry : que (fetch index)
+. list entry : que (list index)
+. last entry : que (last index)
+
+. was define station : station by start <> station (myself)
+. is valid fetch entry : fetch index > 0
+.;
+
+INT VAR command index , params ;
+TEXT VAR param 1, param 2 ;
+LET spool command list = "start:1.01stop:3.0halt:4.0first:5.0killer:6.0";
+
+sp channel := 0;
+sp duty := "";
+deactive message := "";
+stat only := FALSE;
+auto stop pending := FALSE;
+task in control := supervisor;
+control password := "-";
+
+
+PROC server channel (INT CONST channel nr) :
+ IF channel nr <= 0 OR channel nr >= 33
+ THEN errorstop ("falsche Kanalangabe") FI;
+ sp channel := channel nr;
+END PROC server channel;
+
+INT PROC server channel : sp channel END PROC server channel;
+
+
+PROC station only (BOOL CONST flag) :
+ stat only := flag
+END PROC station only;
+
+BOOL PROC station only : stat only END PROC station only;
+
+
+PROC auto stop (BOOL CONST flag) :
+ auto stop pending := flag
+END PROC auto stop;
+
+BOOL PROC auto stop : auto stop pending END PROC auto stop;
+
+
+PROC spool duty (TEXT CONST duty) :
+ sp duty := duty;
+END PROC spool duty;
+
+TEXT PROC spool duty : sp duty END PROC spool duty;
+
+
+PROC enter spool control password (TEXT CONST new password):
+ disable stop;
+ cover tracks;
+ cover tracks (control password);
+ control password := new password;
+END PROC enter spool control password;
+
+PROC spool control password (TEXT CONST new password):
+ IF on line THEN say (""3""13""5"") FI;
+ enter spool control password (new password);
+END PROC spool control password;
+
+
+PROC spool manager (PROC server start) :
+ spool manager (PROC (DATASPACE VAR, INT CONST,
+ INT CONST, TASK CONST) spool manager,
+ PROC server start, TRUE)
+END PROC spool manager;
+
+
+PROC spool manager (PROC server start, BOOL CONST initial start) :
+ spool manager (PROC (DATASPACE VAR, INT CONST,
+ INT CONST, TASK CONST) spool manager,
+ PROC server start, initial start)
+END PROC spool manager;
+
+
+PROC spool manager (PROC (DATASPACE VAR, INT CONST,
+ INT CONST, TASK CONST) spool,
+ PROC server start,
+ BOOL CONST initial start) :
+
+ set autonom;
+ break;
+ disable stop;
+ command dialogue (FALSE);
+ initialize spool manager;
+ REP start spool if necessary;
+ wait for next order;
+ IF order not allowed THEN reject order
+ ELIF is first phase THEN first phase
+ ELIF is second phase THEN second phase
+ ELSE send nak
+ FI;
+ send error if necessary;
+ collect heap garbage if necessary;
+ PER
+
+ . initialize spool manager :
+ initialize if necessary;
+ stop server;
+ erase fetch entry;
+ start cmd pending := initial start;
+ stop cmd pending := FALSE;
+ last order task := niltask;
+
+ . initialize if necessary :
+ IF NOT initialized (in this task)
+ THEN clear spool;
+ global ds := nilspace;
+ que ds := nilspace;
+ que := que ds;
+ server := niltask;
+ calling parent := niltask;
+ server is waiting := FALSE;
+ station by start := station (myself);
+ old heap size := 0;
+ error message buffer := "";
+ FI;
+
+ . start spool if necessary :
+ IF start cmd pending AND NOT stop cmd pending
+ THEN start server (PROC server start) FI;
+
+ . wait for next order :
+ INT VAR order, phase;
+ TASK VAR order task;
+ forget (global ds);
+ wait (global ds, order, order task);
+
+ . order not allowed :
+ station only CAND station (ordertask) <> station (myself) CAND
+ ( order > 255 COR pos (control codes, code (order)) = 0 )
+
+ . reject order :
+ errorstop ("kein Zugriffsrecht auf Task " + text (station(myself))
+ + "/""" + name(myself) + """")
+
+ . is first phase :
+ order <> second phase ack
+
+ . first phase :
+ phase := 1;
+ last order := order;
+ last order task := order task;
+ spool (global ds, order, phase, order task);
+
+ . is second phase :
+ order task = last order task
+
+ . second phase :
+ phase INCR 1 ;
+ order := last order;
+ spool (global ds, order, phase, order task);
+
+ . send nak :
+ forget (global ds);
+ global ds := nilspace;
+ send (order task, nak, global ds);
+
+ . send error if necessary :
+ IF is error
+ THEN forget (global ds);
+ global ds := nilspace;
+ error msg := global ds;
+ CONCR (error msg) := error message;
+ clear error;
+ send (order task, error nak, global ds);
+ FI;
+
+ . collect heap garbage if necessary :
+ IF heap size > old heap size + 2
+ THEN collect heap garbage;
+ old heap size := heap size;
+ FI;
+
+END PROC spool manager;
+
+
+PROC spool manager (DATASPACE VAR order ds,
+ INT CONST order, phase,
+ TASK CONST order task ):
+
+ enable stop;
+ SELECT order OF
+ CASE fetch code, help code : out of que or help
+ CASE param fetch code : send fetch params
+ CASE save code : new que entry
+ CASE file save code : new file que entry
+ CASE exists code : exists que entry
+ CASE erase code : erase que entry
+ CASE list code : send spool list
+ CASE all code : send owners ds names
+
+ CASE entry line code : send next entry line
+ CASE killer code : kill entry
+ CASE first code : make to first
+ CASE start code : start server task
+ CASE stop code : stop server task
+ CASE halt code, wait for halt code
+ : halt server task
+
+ OTHERWISE :
+
+ IF order >= continue code AND order task = supervisor
+ THEN spool monitor
+ ELSE wrong operation
+ FI;
+
+ END SELECT;
+
+. wrong operation :
+ IF order > error nak
+ THEN errorstop ("falscher Auftrag fuer Task " + text (station(myself))
+ + "/""" + name(myself) + """")
+ FI;
+
+.
+ out of que or help :
+ IF order task = server
+ THEN out of que
+ ELSE send help file
+ FI;
+
+ . out of que :
+ erase fetch entry;
+ IF stop cmd pending
+ THEN stop server
+ ELIF que is empty
+ THEN IF auto stop pending
+ THEN stop server
+ ELSE server is waiting := TRUE
+ FI;
+ ELSE send first entry;
+ FI;
+
+ . send help file :
+ check server (TRUE);
+ IF order = fetch code
+ THEN msg := order ds;
+ IF msg. name <> help file name
+ THEN errorstop ("keine Servertask") FI;
+ FI;
+ forget (order ds);
+ order ds := old (help file name);
+ send (order task, ack, order ds);
+
+.
+ send fetch params :
+ IF order task = server
+ THEN send params
+ ELSE errorstop ("keine Servertask")
+ FI;
+
+ . send params :
+ forget(order ds); order ds := nilspace;
+ fetch msg := order ds;
+ fetch msg := fetch entry. ds params;
+ send (order task, ack, order ds);
+
+.
+ new que entry :
+ IF phase = 1
+ THEN prepare into que
+ ELSE into que (order ds, order task)
+ FI;
+
+.
+ prepare into que :
+ msg := order ds ;
+ save params. name := msg.name;
+ save params. userid := msg.userid;
+ save params. password := msg.password;
+ save params. sendername := name (order task);
+ save params. station := station (order task);
+ forget (order ds); order ds := nilspace;
+ send (order task, second phase ack, order ds);
+
+.
+ new file que entry :
+ IF type (order ds) <> file type
+ THEN errorstop ("Datenraum hat falschen Typ");
+ ELSE get file params;
+ into que (order ds, order task);
+ FI;
+
+ . get file params :
+ file := sequential file (input, order ds);
+ end pos := 0;
+ next headline information (save params. name);
+ next headline information (save params. userid);
+ next headline information (save params. password);
+ next headline information (save params. sendername);
+ next headline information (buffer);
+ save params. station := int (buffer);
+ IF NOT last conversion ok
+ THEN save params. station := station (order task) FI;
+ IF save params. sendername = ""
+ THEN save params. sendername := name (order task) FI;
+ IF save params. name = ""
+ THEN IF headline (file) <> ""
+ THEN save params. name := headline (file);
+ ELSE errorstop ("Name unzulaessig")
+ FI;
+ ELSE headline (file, save params. name);
+ FI;
+
+.
+ exists que entry :
+ msg := order ds ;
+ order task name := name (order task);
+ order task station := station (order task);
+ FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task (msg. name)
+ THEN send ack;
+ LEAVE exists que entry
+ FI;
+ PER ;
+ forget (order ds); order ds := nilspace;
+ send (order task, false code, order ds)
+
+.
+ erase que entry :
+ msg := order ds ;
+ order task name := name (order task);
+ order task station := station (order task);
+ IF phase = 1
+ THEN ask for erase
+ ELSE erase entry from order task
+ FI;
+
+ . ask for erase :
+ FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task (msg. name)
+ THEN manager question ("""" + msg.name + """ loeschen", order task);
+ LEAVE erase que entry
+ FI;
+ PER ;
+ manager message ("""" + msg.name + """ existiert nicht", order task);
+
+ . erase entry from order task :
+ IF is valid que index (que index) CAND is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ ELSE FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task (msg. name)
+ THEN delete que entry;
+ LEAVE erase que entry
+ FI;
+ PER;
+ manager message ("""" + msg.name + """ existiert nicht", order task);
+ FI;
+
+ . delete que entry :
+ kill spool (que index);
+ send ack;
+
+.
+ send owners ds names:
+ order task name := name (order task);
+ order task station := station (order task);
+ forget (order ds); order ds := nilspace; all msg := order ds;
+ all msg := empty thesaurus;
+ FOR que index FROM 1 UPTO number entries
+ REP IF is entry from order task ("")
+ THEN insert (all msg, list entry. ds params. name)
+ FI;
+ PER;
+ send (order task, ack, order ds)
+
+.
+ send spool list :
+ forget (global ds); global ds := nilspace;
+ file := sequential file (output, global ds);
+ list spool (file);
+ send (order task, ack, global ds);
+
+.
+ send next entry line :
+ control msg := order ds; check control password (control msg. password);
+ IF control msg. index = 0 THEN control msg. actual entries := que entries FI;
+ get next entry line;
+ send (order task, ack, order ds);
+
+ . get next entry line :
+ REP control msg. index INCR 1;
+ IF control msg. index > LENGTH control msg. actual entries
+ THEN control msg. index := 0;
+ control msg. entry line := "";
+ LEAVE get next entry line;
+ FI;
+ que index := control que index;
+ UNTIL is valid que index (que index) PER;
+ control msg. entry line := list entry. entry line;
+
+ . control que index :
+ pos (que entries, control msg. actual entries SUB control msg. index)
+
+.
+ kill entry :
+ control msg := order ds; check control password (control msg. password);
+ kill spool (control que index);
+ send (order task, ack, order ds);
+
+.
+ make to first :
+ control msg := order ds; check control password (control msg. password);
+ first spool (control que index);
+ send (order task, ack, order ds);
+
+.
+ start server task :
+ msg := order ds; check control password (msg. password);
+ IF exists (server) AND NOT stop cmd pending
+ THEN errorstop ("Spool muß zuerst gestoppt werden") FI;
+ new server channel is necessary;
+ start cmd pending := TRUE;
+ IF server channel <= 0 OR server channel >= 33
+ THEN manager message ("WARNUNG : Serverkanal nicht eingestellt", order task);
+ ELSE send ack
+ FI;
+
+ . new server channel is necessary :
+ INT CONST new channel := int (msg. name);
+ IF last conversion ok THEN server channel (new channel) FI;
+
+.
+ stop server task :
+ msg := order ds; check control password (msg. password);
+ IF phase = 1
+ THEN start cmd pending := FALSE;
+ deactive message := msg. name;
+ stop server;
+ check fetch entry;
+ ELSE reinsert fetch entry;
+ send ack;
+ FI;
+
+.
+ halt server task :
+ msg := order ds; check control password (msg. password);
+ IF phase = 1
+ THEN stop cmd pending := TRUE;
+ start cmd pending := FALSE;
+ deactive message := msg. name;
+ IF NOT exists (server) OR server is waiting
+ THEN stop server;
+ check fetch entry;
+ ELIF order = wait for halt code
+ THEN calling parent := order task;
+ ELSE send ack;
+ FI;
+ ELSE reinsert fetch entry;
+ send ack;
+ FI;
+
+ . check fetch entry :
+ IF is valid fetch entry
+ THEN manager question (""13""10"" +
+ fetch entry. entry line + " neu eintragen", order task);
+ fetch index := -fetch index;
+ ELSE send ack;
+ FI;
+
+.
+ send ack :
+ forget (order ds); order ds := nilspace;
+ send (order task, ack, order ds)
+
+.
+ spool monitor :
+ continue (order - continue code);
+ disable stop;
+ put error message if there is one;
+ WHILE online
+ REP command dialogue (TRUE);
+ sysout ("");
+ sysin ("");
+ get command ("gib Spool-Kommando:");
+ analyze command (spool command list, 3, command index, params, param1, param2);
+ reset editor;
+ SELECT command index OF
+ CASE 1 : start spool
+ CASE 2 : start spool (int (param1))
+ CASE 3 : stop spool
+ CASE 4 : halt spool
+ CASE 5 : first spool
+ CASE 6 : kill spool
+ OTHERWISE : do command
+ END SELECT;
+ PER;
+ save error message if there is one;
+ command dialogue (FALSE);
+ break (quiet);
+ set autonom;
+
+ . put error message if there is one :
+ IF error message buffer <> ""
+ THEN errorstop (error message buffer); FI;
+
+ . save error message if there is one :
+ IF is error
+ THEN error message buffer := error message;
+ clear error;
+ ELSE error message buffer := "";
+ FI;
+
+ . reset editor :
+ WHILE aktueller editor > 0 REP quit PER;
+ clear error;
+
+END PROC spool manager;
+
+
+PROC send first entry :
+
+ forget (global ds);
+ global ds := que space (first index);
+ send (server, ack, global ds, reply) ;
+ IF reply = ack
+ THEN fetch index := first index;
+ que entries := subtext (que entries, 2);
+ server is waiting := FALSE;
+ start time := time of day;
+ start time CAT " am ";
+ start time CAT date;
+ FI;
+
+END PROC send first entry;
+
+
+PROC into que (DATASPACE VAR order ds, TASK CONST order task) :
+
+ IF que is full
+ THEN errorstop ("Spool ist voll")
+ ELSE make new entry;
+ send ack;
+ awake server if necessary
+ FI;
+
+ . make new entry :
+ que entries CAT (free entries SUB 1);
+ free entries := subtext (free entries, 2);
+ que space (last index) := order ds;
+ last entry. ds params := save params;
+ build entry line;
+
+ . build entry line :
+ IF LENGTH last entry. ds params. sender name > 16
+ THEN buffer := subtext (last entry. ds params. sender name, 1, 13);
+ buffer CAT "...""";
+ ELSE buffer := last entry. ds params. sender name;
+ buffer CAT """";
+ buffer := text (buffer, 17);
+ FI;
+ last entry. entry line := entry station text;
+ last entry. entry line CAT "/""";
+ last entry. entry line CAT buffer;
+ last entry. entry line CAT " : """ ;
+ last entry. entry line CAT last entry. ds params. name;
+ last entry. entry line CAT """ (" ;
+ last entry. entry line CAT text (storage (order ds));
+ last entry. entry line CAT " K)";
+
+ . entry station text :
+ IF last entry. ds params. station = 0
+ THEN " "
+ ELSE text (last entry. ds params. station, 3)
+ FI
+
+ . send ack :
+ forget (order ds); order ds := nilspace;
+ send (order task, ack, order ds)
+
+ . awake server if necessary :
+ IF server is waiting THEN send first entry FI;
+
+END PROC into que;
+
+
+(*********************************************************************)
+(* Hilfsprozeduren zum Spoolmanager *)
+(*********************************************************************)
+
+
+PROC reinsert fetch entry :
+
+ IF fetch index <> 0
+ THEN insert char (que entries, code (abs (fetch index)), 1);
+ fetch index := 0;
+ FI;
+
+END PROC reinsert fetch entry;
+
+
+PROC erase fetch entry :
+
+ IF fetch index <> 0
+ THEN free entries CAT code (abs (fetch index));
+ forget (que space (abs (fetch index)));
+ fetch index := 0;
+ FI;
+
+END PROC erase fetch entry;
+
+
+PROC start server (PROC server start):
+
+ stop server;
+ begin (PROC server start, server);
+ station by start := station (myself);
+ start cmd pending := FALSE;
+ deactive message := "";
+
+END PROC start server;
+
+
+PROC stop server :
+
+ IF exists (server) THEN end (server) ELSE check server (FALSE) FI;
+ server := niltask;
+ server is waiting := FALSE;
+ stop cmd pending := FALSE;
+ send calling parent reply if necessary;
+
+ . send calling parent reply if necessary :
+ IF exists (calling parent)
+ THEN forget (global ds); global ds := nilspace;
+ send (calling parent, ack, global ds);
+ calling parent := niltask;
+ FI;
+
+END PROC stop server;
+
+
+PROC check server (BOOL CONST with stop) :
+
+ IF was define station CAND NOT is niltask (server)
+ THEN stop old server if necessary FI;
+
+ . stop old server if necessary :
+ access catalogue;
+ TASK VAR old server := son (myself);
+ WHILE NOT is niltask (old server)
+ REP IF index (old server) = index (server) THEN old server found FI;
+ old server := brother (old server);
+ PER;
+
+ . old server found :
+ IF name (old server) = "-" THEN end (old server) FI;
+ IF with stop THEN stop server FI;
+ LEAVE stop old server if necessary;
+
+END PROC check server;
+
+
+BOOL PROC is valid que index (INT CONST index) :
+
+ 1 <= index AND index <= number entries
+
+END PROC is valid que index;
+
+
+BOOL PROC is entry from order task (TEXT CONST file name) :
+
+ correct order task CAND correct filename
+
+ . correct order task :
+ order task name = list entry. ds params. sendername
+ AND order task station = list entry. ds params. station
+
+ . correct file name :
+ file name = "" OR file name = list entry. ds params. name
+
+END PROC is entry from order task;
+
+
+PROC check control password (TEXT CONST password) :
+
+ IF control password = "-"
+ THEN errorstop ("Kontrolle des Spools nicht erlaubt")
+ ELIF control password <> "" CAND control password <> password
+ THEN errorstop ("Passwort falsch")
+ FI;
+
+END PROC check control password;
+
+
+PROC next headline information (TEXT VAR t):
+
+ begin pos := pos (headline (file), begin char, end pos + 1);
+ IF begin pos = 0
+ THEN begin pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE end pos := pos (headline (file), end char, begin pos + 1);
+ IF end pos = 0
+ THEN end pos := LENGTH headline (file) + 1;
+ t := "";
+ ELSE t := subtext (headline (file), begin pos+1, end pos-1)
+ FI
+ FI
+
+END PROC next headline information;
+
+(*********************************************************************)
+(* Prozeduren zur Verwaltung der Warteschlange *)
+(*********************************************************************)
+
+PROC start spool :
+
+ enable stop;
+ IF server channel <= 0 OR server channel >= 33
+ THEN display (""13""10"WARNUNG : Serverkanal nicht eingestellt"13""10"")
+ FI;
+ halt spool;
+ start cmd pending := TRUE;
+
+END PROC start spool;
+
+PROC start spool (INT CONST new channel) :
+
+ enable stop;
+ server channel (new channel);
+ start spool;
+
+END PROC start spool;
+
+PROC stop spool (TEXT CONST deactive msg) :
+
+ disable stop;
+ deactive message := deactive msg;
+ start cmd pending := FALSE;
+ stop server;
+ IF is valid fetch entry CAND on line CAND
+ yes (""13""10"" + fetch entry. entry line + " neu eintragen")
+ THEN reinsert fetch entry
+ ELSE erase fetch entry;
+ FI;
+
+END PROC stop spool;
+
+PROC stop spool : stop spool ("") END PROC stop spool;
+
+PROC halt spool (TEXT CONST deactive msg) :
+
+ enable stop;
+ deactive message := deactive msg;
+ stop cmd pending := TRUE;
+ start cmd pending := FALSE;
+ IF NOT exists (server) OR server is waiting THEN stop spool FI;
+
+END PROC halt spool;
+
+PROC halt spool : halt spool ("") END PROC halt spool;
+
+
+PROC kill spool :
+
+ enable stop;
+ say (""13""10"");
+ que index := 1;
+ WHILE que index <= number entries
+ REP IF yes (list entry. entry line + " loeschen")
+ THEN kill spool (que index)
+ ELSE que index INCR 1
+ FI;
+ PER;
+
+END PROC kill spool;
+
+PROC kill spool (INT CONST index) :
+
+ IF is valid que index (index)
+ THEN forget (que space (code (que entries SUB index)));
+ free entries CAT (que entries SUB index);
+ delete char (que entries, index);
+ FI;
+
+END PROC kill spool;
+
+
+PROC first spool :
+
+ enable stop;
+ say (""13""10"");
+ FOR que index FROM 1 UPTO number entries
+ REP IF yes (list entry. entry line + " als erstes")
+ THEN first spool (que index);
+ LEAVE first spool
+ FI;
+ PER;
+
+END PROC first spool;
+
+PROC first spool (INT CONST index) :
+
+ IF is valid que index (index)
+ THEN insert char (que entries, que entries SUB index, 1);
+ delete char (que entries, index + 1);
+ FI;
+
+END PROC first spool;
+
+
+TEXT PROC spool entry line (INT CONST index) :
+
+ IF index = 0 CAND is valid fetch entry
+ THEN fetch entry. entry line
+ ELIF is valid que index (index)
+ THEN entry. entry line
+ ELSE ""
+ FI
+
+ . entry : que (code (que entries SUB index))
+
+END PROC spool entry line;
+
+
+INT PROC number spool entries : number entries END PROC number spool entries;
+
+INT PROC spool status :
+
+ IF exists (server)
+ THEN IF stop cmd pending
+ THEN IF start cmd pending
+ THEN 3 (* aktiviert (neu start) *)
+ ELSE 2 (* aktiviert (warten auf halt) *)
+ FI
+ ELSE IF server is waiting
+ THEN 0 (* kein Auftrag in Bearbeitung *)
+ ELSE 1 (* aktiviert *)
+ FI
+ FI
+ ELIF start cmd pending
+ THEN 0 (* wird aktiviert *)
+ ELIF is valid fetch entry
+ THEN IF was define station
+ THEN -3 (* deaktiviert (define station) *)
+ ELSE -2 (* deaktiviert (server gelöcht) *)
+ FI
+ ELSE -1 (* deaktiviert *)
+ FI
+
+END PROC spool status;
+
+TASK PROC server task : server END PROC server task;
+
+
+PROC clear spool :
+
+ disable stop;
+ IF NOT initialized (init que space)
+ THEN FOR que index FROM 1 UPTO que size
+ REP que space (que index) := nilspace PER;
+ FI;
+ que entries := "";
+ free entries := "";
+ fetch index := 0;
+ stop server;
+ FOR que index FROM 1 UPTO que size
+ REP forget (que space (que index));
+ free entries CAT code (que index);
+ PER;
+
+END PROC clear spool;
+
+
+PROC list spool :
+
+ disable stop;
+ DATASPACE VAR list ds := nilspace;
+ FILE VAR list file := sequential file (output, list ds);
+ list spool (list file);
+ show (list file);
+ forget (list ds);
+
+END PROC list spool;
+
+
+PROC list spool (FILE VAR f) :
+
+ enable stop;
+ output (f);
+ max line length (f, 1000);
+ headline (f, station text + name (myself) + """");
+ put spool duty;
+ put current job;
+ put spool que;
+
+ . station text :
+ IF station(myself) = 0
+ THEN "/"""
+ ELSE text (station(myself)) + "/"""
+ FI
+
+ . put spool duty :
+ IF spool duty <> ""
+ THEN write (f, "Aufgabe: ");
+ write (f, spool duty );
+ line (f, 2);
+ FI;
+
+ . put current job :
+ IF is valid fetch entry
+ THEN write (f, "In Bearbeitung seit ");
+ write (f, start time);
+ write (f, ":");
+ line (f, 2);
+ putline (f, fetch entry. entry line);
+ IF NOT exists (server)
+ THEN IF was define station
+ THEN putline (f, "Spool ist deaktiviert, da Stationsnummer geaendert wurde")
+ ELSE putline (f, "Spool ist deaktiviert, da der Server gelöscht wurde")
+ FI;
+ ELIF stop cmd pending
+ THEN IF start cmd pending
+ THEN putline (f, "Spool wird nach diesem Auftrag neu aktiviert");
+ ELSE putline (f, "Spool wird nach diesem Auftrag deaktiviert");
+ FI;
+ FI;
+ line (f);
+ ELSE write (f, "kein Auftrag in Bearbeitung");
+ IF NOT exists (server)
+ THEN write (f, ", da Spool deaktiviert");
+ IF start cmd pending
+ THEN line (f);
+ write (f, "Spool wird nach Verlassen der Task aktiviert");
+ FI;
+ IF deactive message <> ""
+ THEN line (f);
+ write (f, deactive message);
+ FI;
+ ELIF que is empty
+ THEN write (f, ", da Warteschlange leer");
+ LEAVE list spool;
+ FI;
+ line (f, 2);
+ FI;
+
+ . put spool que :
+ IF que is empty
+ THEN putline (f, "Warteschlange ist leer");
+ ELSE write (f, "Warteschlange (");
+ write (f, text (number entries));
+ IF number entries = 1
+ THEN write (f, " Auftrag):");
+ ELSE write (f, " Auftraege):");
+ FI;
+ line (f, 2);
+ FOR que index FROM 1 UPTO number entries
+ REP putline (f, list entry. entry line) PER;
+ FI;
+
+END PROC list spool;
+
+
+ENDPACKET spool manager;
+
diff --git a/system/std.zusatz/1.8.7/src/std analysator b/system/std.zusatz/1.8.7/src/std analysator
new file mode 100644
index 0000000..7e14722
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/std analysator
@@ -0,0 +1,68 @@
+PACKET std analysator (* Autor : Rudolf Ruland *)
+ (* Stand : 06.11.86 *)
+ DEFINES std analysator :
+
+
+LET text code = 1,
+ error code = 2,
+ token code = 3;
+
+INT VAR instruction begin;
+TEXT VAR unknown instruction := "";
+
+PROC std analysator (INT CONST op code, TEXT VAR string,
+ INT VAR par1, par2, par3, par4, par5, par6, par7) :
+
+ SELECT op code OF
+
+ CASE text code : analyse text
+ CASE error code : report errors
+ CASE token code : report tokens
+
+ END SELECT ;
+
+ . record : string
+ . record pos : par1
+ . width : par4
+ . height : par5
+ . depth : par6
+
+ . analyse text :
+ instruction begin := record pos + 1;
+ record pos := pos (record, "#", instruction begin) + 1;
+ width := 0;
+ height := 0;
+ depth := 0;
+ unknown instruction := subtext (record, instruction begin, instruction end);
+
+ . instruction end : record pos - 2
+
+
+. error msg : string
+. error nr : par1
+.
+ report errors :
+ IF error nr = 0
+ THEN error msg := "unbekannte Anweisung (ignoriert): ";
+ error msg CAT unknown instruction;
+ error nr := 1;
+ ELSE error msg := "";
+ error nr := 0;
+ FI;
+
+
+. token text : string
+. token nr : par1
+. token font nr : par2
+. token modifications : par3
+. token width : par4
+. token x pos : par5
+. token y pos : par6
+. token type : par7
+.
+ report tokens :
+
+END PROC std analysator;
+
+END PACKET std analysator;
+
diff --git a/system/std.zusatz/1.8.7/src/vector b/system/std.zusatz/1.8.7/src/vector
new file mode 100644
index 0000000..5c9e896
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/vector
@@ -0,0 +1,213 @@
+PACKET vector DEFINES VECTOR, :=, vector, (* Autor : H.Indenbirken *)
+ SUB, LENGTH, length, norm, (* Stand : 21.10.83 *)
+ nilvector, replace, =, <>,
+ +, -, *, /,
+ get, put :
+
+
+TYPE VECTOR = STRUCT (INT lng, TEXT elem);
+TYPE INITVECTOR = STRUCT (INT lng, REAL value);
+
+INT VAR i;
+TEXT VAR t :: "12345678";
+VECTOR VAR v :: nilvector;
+
+(****************************************************************************
+PROC dump (VECTOR CONST v) :
+ put line (text (v.lng) + " Elemente :");
+ FOR i FROM 1 UPTO v.lng
+ REP put line (text (i) + ": " + text (element i)) PER .
+
+element i :
+ v.elem RSUB i .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (VECTOR VAR l, VECTOR CONST r) :
+ l.lng := r.lng;
+ l.elem := r.elem
+
+END OP :=;
+
+OP := (VECTOR VAR l, INITVECTOR CONST r) :
+ l.lng := r.lng;
+ replace (t, 1, r.value);
+ l.elem := r.lng * t
+
+END OP :=;
+
+INITVECTOR PROC nilvector :
+ vector (1, 0.0)
+
+END PROC nilvector;
+
+INITVECTOR PROC vector (INT CONST lng, REAL CONST value) :
+ IF lng <= 0
+ THEN errorstop ("PROC vector : lng <= 0") FI;
+ INITVECTOR : (lng, value)
+
+END PROC vector;
+
+INITVECTOR PROC vector (INT CONST lng) :
+ vector (lng, 0.0)
+
+END PROC vector;
+
+REAL OP SUB (VECTOR CONST v, INT CONST i) :
+ test ("REAL OP SUB : ", v, i);
+ v.elem RSUB i
+
+END OP SUB;
+
+INT OP LENGTH (VECTOR CONST v) :
+ v.lng
+
+END OP LENGTH;
+
+INT PROC length (VECTOR CONST v) :
+ v.lng
+
+END PROC length;
+
+REAL PROC norm (VECTOR CONST v) :
+ REAL VAR result :: 0.0;
+ FOR i FROM 1 UPTO v.lng
+ REP result INCR ((v.elem RSUB i)**2) PER;
+ sqrt (result) .
+
+END PROC norm;
+
+PROC replace (VECTOR VAR v, INT CONST i, REAL CONST r) :
+ test ("PROC replace : ", v, i);
+ replace (v.elem, i, r)
+
+END PROC replace;
+
+BOOL OP = (VECTOR CONST l, r) :
+ l.elem = r.elem
+END OP =;
+
+BOOL OP <> (VECTOR CONST l, r) :
+ l.elem <> r.elem
+END OP <>;
+
+VECTOR OP + (VECTOR CONST v) :
+ v
+END OP +;
+
+VECTOR OP + (VECTOR CONST l, r) :
+ test ("VECTOR OP + : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) + (r.elem RSUB i)) PER;
+ v
+
+END OP +;
+
+VECTOR OP - (VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, - (a.elem RSUB i)) PER;
+ v
+
+END OP -;
+
+VECTOR OP - (VECTOR CONST l, r) :
+ test ("VECTOR OP - : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) - (r.elem RSUB i)) PER;
+ v
+END OP -;
+
+REAL OP * (VECTOR CONST l, r) :
+ test ("REAL OP * : ", l, r);
+ REAL VAR x :: 0.0;
+ FOR i FROM 1 UPTO l.lng
+ REP x INCR ((l.elem RSUB i) * (r.elem RSUB i)) PER;
+ x
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, REAL CONST r) :
+ r*v
+
+END OP *;
+
+VECTOR OP * (REAL CONST r, VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, r*(a.elem RSUB i)) PER;
+ v
+
+END OP *;
+
+VECTOR OP / (VECTOR CONST a, REAL CONST r) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (a.elem RSUB i)/r) PER;
+ v
+
+END OP /;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, VECTOR CONST v, INT CONST i) :
+ IF i > v.lng
+ THEN error := proc;
+ error CAT "subscript overflow (LENGTH v=";
+ error CAT text (v.lng);
+ error CAT ", i=";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (i = ";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, VECTOR CONST a, b) :
+ IF a.lng <> b.lng
+ THEN error := proc;
+ error CAT "LENGTH a (";
+ IF a.lng <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (a.lng) FI;
+ error CAT ") <> LENGTH b (";
+ error CAT text (b.lng);
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+PROC get (VECTOR VAR v, INT CONST lng) :
+ v.lng := lng;
+ v.elem := lng * "12345678";
+ REAL VAR x;
+ FOR i FROM 1 UPTO lng
+ REP get (x);
+ replace (v.elem, i, x)
+ PER .
+
+END PROC get;
+
+PROC put (VECTOR CONST v, INT CONST length, fracs) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i, length, fracs)) PER
+
+END PROC put;
+
+PROC put (VECTOR CONST v) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i)) PER
+
+END PROC put;
+
+END PACKET vector;
+