summaryrefslogtreecommitdiff
path: root/system
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
committerLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
commit04e68443040c7abad84d66477e98f93bed701760 (patch)
tree2b6202afae659e773bf6916157d23e83edfa44e3 /system
downloadeumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.gz
eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.bz2
eumel-src-04e68443040c7abad84d66477e98f93bed701760.zip
Initial import
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