summaryrefslogtreecommitdiff
path: root/system
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2019-02-11 11:49:19 +0100
committerLars-Dominik Braun <lars@6xq.net>2019-02-11 11:49:39 +0100
commit98cab31fc3659e33aef260efca55bf9f1753164c (patch)
treef1affa84049ef9b268e6c4f521f000478b0f3a8e /system
parent71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff)
downloadeumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz
eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2
eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip
Add source files from Michael
Diffstat (limited to 'system')
-rw-r--r--system/at/unknown/src/AT Generator134
-rw-r--r--system/at/unknown/src/AT Utilities601
-rw-r--r--system/at/unknown/src/AT install92
-rw-r--r--system/base/unknown/src/SPOLMAN5.ELA1003
-rw-r--r--system/base/unknown/src/STD.ELA220
-rw-r--r--system/base/unknown/src/STDPLOT.ELA365
-rw-r--r--system/base/unknown/src/bildeditor722
-rw-r--r--system/base/unknown/src/command handler239
-rw-r--r--system/base/unknown/src/dateieditorpaket743
-rw-r--r--system/base/unknown/src/editor210
-rw-r--r--system/base/unknown/src/elan245
-rw-r--r--system/base/unknown/src/feldeditor747
-rw-r--r--system/base/unknown/src/file810
-rw-r--r--system/base/unknown/src/init250
-rw-r--r--system/base/unknown/src/integer134
-rw-r--r--system/base/unknown/src/mathlib359
-rw-r--r--system/base/unknown/src/real378
-rw-r--r--system/base/unknown/src/scanner255
-rw-r--r--system/base/unknown/src/stdescapeset31
-rw-r--r--system/dos/1986/doc/DSKDOS.ELA967
-rw-r--r--system/dos/1986/src/252bin0 -> 1024 bytes
-rw-r--r--system/dos/1986/src/253bin0 -> 1024 bytes
-rw-r--r--system/dos/1986/src/254bin0 -> 1024 bytes
-rw-r--r--system/dos/1986/src/255bin0 -> 1024 bytes
-rw-r--r--system/dos/1986/src/COND.TXT5
-rw-r--r--system/dos/1986/src/block i-o104
-rw-r--r--system/dos/1986/src/cluster109
-rw-r--r--system/dos/1986/src/disk descriptor.dos.fd290
-rw-r--r--system/dos/1986/src/disk descriptor.dos.hd290
-rw-r--r--system/dos/1986/src/disk manager245
-rw-r--r--system/dos/1986/src/eu disk descriptor.fd102
-rw-r--r--system/dos/1986/src/eu disk descriptor.hd102
-rw-r--r--system/dos/1986/src/eumel-ebcdic + sub550
-rw-r--r--system/dos/1986/src/fat and dir.dos.fd1190
-rw-r--r--system/dos/1986/src/fat and dir.dos.hd1190
-rw-r--r--system/dos/1986/src/fetch333
-rw-r--r--system/dos/1986/src/files.dos23
-rw-r--r--system/dos/1986/src/gen.dos99
-rw-r--r--system/dos/1986/src/manager-M.dos.fd198
-rw-r--r--system/dos/1986/src/manager-M.dos.hd198
-rw-r--r--system/dos/1986/src/name conversion77
-rw-r--r--system/dos/1986/src/open51
-rw-r--r--system/dos/1986/src/save273
-rw-r--r--system/dos/1986/src/shard interface19
-rw-r--r--system/dos/1986/src/table thes.dos5
-rw-r--r--system/eumel0-z80/data/EUMEL0.DSbin0 -> 30720 bytes
-rw-r--r--system/eumel0-z80/src/DISEUMEL.ELA607
-rw-r--r--system/eumel0-z80/src/eumel0.prt.13948
-rw-r--r--system/eumel0-z80/src/eumel0.prt.23957
-rw-r--r--system/eumel0-z80/src/eumel0.prt.34004
-rw-r--r--system/eumel0-z80/src/eumel0.prt.44001
-rw-r--r--system/printer-9nadel/1986/doc/readme323
-rw-r--r--system/printer-9nadel/1986/src/CHARED.ELA47
-rw-r--r--system/printer-9nadel/1986/src/EPSONFX.ELA575
-rw-r--r--system/printer-9nadel/1986/src/EPSONRX.ELA171
-rw-r--r--system/printer-9nadel/1986/src/FONTTAB.10Abin0 -> 3072 bytes
-rw-r--r--system/printer-9nadel/1986/src/FONTTAB.12Abin0 -> 3072 bytes
-rw-r--r--system/printer-9nadel/1986/src/FONTTAB.S10bin0 -> 3072 bytes
-rw-r--r--system/printer-9nadel/1986/src/FONTTAB.S12bin0 -> 3072 bytes
-rw-r--r--system/printer-9nadel/1986/src/beschreibungen996
-rw-r--r--system/printer-9nadel/1986/src/fonttab.1bin0 -> 11776 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.10bin0 -> 16384 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.20bin0 -> 37376 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.20.lcbin0 -> 37376 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.20.lxbin0 -> 25088 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.7bin0 -> 46592 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.7.cxpbin0 -> 46592 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.7.fujbin0 -> 57344 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.7.mtbin0 -> 46592 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.epson.fxbin0 -> 25600 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.epson.lqbin0 -> 36352 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.epson.mxbin0 -> 11776 bytes
-rw-r--r--system/printer-9nadel/1986/src/fonttab.epson.rxbin0 -> 20480 bytes
-rw-r--r--system/printer-9nadel/1986/src/module91098
-rw-r--r--system/printer-9nadel/1986/src/printer.epson.fx505
-rw-r--r--system/printer-9nadel/1986/src/printer.epson.lq501
-rw-r--r--system/printer-9nadel/1986/src/printer.epson.mx488
-rw-r--r--system/printer-9nadel/1986/src/printer.epson.rx446
-rw-r--r--system/printer-9nadel/1986/src/printer.std431
-rw-r--r--system/ruc-terminal/unknown/doc/BIOSINT.PRT281
-rw-r--r--system/ruc-terminal/unknown/doc/MACROS.PRT54
-rw-r--r--system/ruc-terminal/unknown/doc/TDOC.PRT3012
-rw-r--r--system/ruc-terminal/unknown/doc/TDOCP.PRT4008
-rw-r--r--system/ruc-terminal/unknown/doc/TINHALT.PRT120
-rw-r--r--system/ruc-terminal/unknown/doc/TINHALTP.PRT157
-rw-r--r--system/ruc-terminal/unknown/doc/TSTICHP.PRT211
-rw-r--r--system/ruc-terminal/unknown/doc/TSTICHWO.PRT161
-rw-r--r--system/ruc-terminal/unknown/doc/TTAB.PRT510
-rw-r--r--system/ruc-terminal/unknown/doc/TTABP.PRT666
-rw-r--r--system/ruc-terminal/unknown/src/SCCPARAM.ELA144
-rw-r--r--system/ruc-terminal/unknown/src/SETUP.ELA257
-rw-r--r--system/ruc-terminal/unknown/src/Terminal108(ascii)121
-rw-r--r--system/ruc-terminal/unknown/src/Terminal108(deutsch)122
-rw-r--r--system/ruc-terminal/unknown/src/ructerm.apl-german125
-rw-r--r--system/ruc-terminal/unknown/src/ructerm.ascii94
-rw-r--r--system/shard-x86-at/7/README.rst5
-rw-r--r--system/shard-x86-at/7/data/EXEMOD.EXEbin0 -> 11034 bytes
-rw-r--r--system/shard-x86-at/7/data/EXEPACK.EXEbin0 -> 10848 bytes
-rw-r--r--system/shard-x86-at/7/data/FSHARD.EXEbin0 -> 9293 bytes
-rw-r--r--system/shard-x86-at/7/data/FSHGET.EXEbin0 -> 1024 bytes
-rw-r--r--system/shard-x86-at/7/data/GENBOOT.EXEbin0 -> 13064 bytes
-rw-r--r--system/shard-x86-at/7/doc/8039.PRT569
-rw-r--r--system/shard-x86-at/7/doc/BIOSINT.TXT305
-rw-r--r--system/shard-x86-at/7/doc/CONTROLS.ELA76
-rw-r--r--system/shard-x86-at/7/doc/PORTS.PRT658
-rw-r--r--system/shard-x86-at/7/src/ATSHARD.ASM156
-rw-r--r--system/shard-x86-at/7/src/BLOCKERR.ASM82
-rw-r--r--system/shard-x86-at/7/src/BOOT.ASM426
-rw-r--r--system/shard-x86-at/7/src/CLOCK.ASM56
-rw-r--r--system/shard-x86-at/7/src/DEVICE.ASM92
-rw-r--r--system/shard-x86-at/7/src/EUCONECT.ASM80
-rw-r--r--system/shard-x86-at/7/src/FDISK.ASM839
-rw-r--r--system/shard-x86-at/7/src/FIXDISK.ASM307
-rw-r--r--system/shard-x86-at/7/src/FLOPPY.ASM454
-rw-r--r--system/shard-x86-at/7/src/FSHARD.ASM223
-rw-r--r--system/shard-x86-at/7/src/HARDWARE.ASM17
-rw-r--r--system/shard-x86-at/7/src/HDISK.ASM482
-rw-r--r--system/shard-x86-at/7/src/HSHARD.ASM242
-rw-r--r--system/shard-x86-at/7/src/I8250.ASM437
-rw-r--r--system/shard-x86-at/7/src/MAC286.ASM23
-rw-r--r--system/shard-x86-at/7/src/MACROS.ASM80
-rw-r--r--system/shard-x86-at/7/src/NILCHAN.ASM54
-rw-r--r--system/shard-x86-at/7/src/PATCH.ELA500
-rw-r--r--system/shard-x86-at/7/src/PATCHARE.ASM17
-rw-r--r--system/shard-x86-at/7/src/PCPAR.ASM226
-rw-r--r--system/shard-x86-at/7/src/PCPLOT.ASM430
-rw-r--r--system/shard-x86-at/7/src/PCSCREEN.ASM438
-rw-r--r--system/shard-x86-at/7/src/PCSYS.ASM131
-rw-r--r--system/shard-x86-at/7/src/SHMAIN.ASM241
-rw-r--r--system/shard-x86-at/7/src/STREAM.ASM290
-rw-r--r--system/shard-x86-at/7/src/WAIT.ASM176
-rw-r--r--system/shard-z80-altos/6/src/ALTOSSHD.ASM1786
-rw-r--r--system/shard-z80-ruc-64180/1.5/doc/SHARD.PRT584
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/65.SUB2
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/BOOT.INC122
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/CONOUT.MAC124
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/CONOUT4.INC467
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/CREF.COMbin0 -> 3968 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/DB.COMbin0 -> 12160 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/DISK.MAC1658
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/DISK80.MAC302
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/DUMP.COMbin0 -> 1024 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/EBOOT.COMbin0 -> 2560 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/EBOOT.MAC339
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/EBOOT.SUB3
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/EINST.COMbin0 -> 17664 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/EINST.PAS509
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/EUMEL.COMbin0 -> 10880 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/FBOOT.COMbin0 -> 2048 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/FBOOT.MAC714
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/FBOOT.SYM2
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/GRAFIK65.MAC1636
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/GRAFIK80.MAC203
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/HD64180.LIB160
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/IINST.COMbin0 -> 8576 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/IINST.PAS21
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/INIMOD.MAC637
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/INT65.MAC412
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/INTMOD.MAC1293
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/L80.COMbin0 -> 10752 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/LOAD.MAC170
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/M80.COMbin0 -> 20480 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/NIBLE.INC113
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/PORTS.MAC38
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SC.COMbin0 -> 10624 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SCSI.MAC1478
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SCSI.PAS272
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SETDEF.COMbin0 -> 4096 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SHARD.AEX15
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SHARD.MAC1434
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SHARD.SUB7
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SLR.COMbin0 -> 24576 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/START.MAC5
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/SUB.COMbin0 -> 5376 bytes
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/TRACK.INC167
-rw-r--r--system/shard-z80-ruc-64180/1.5/src/ZPAGE.INC155
-rw-r--r--system/std.zusatz/1.7.3/src/17CHARS.ELA44
-rw-r--r--system/std.zusatz/1.7.3/src/EMU16.ELA109
-rw-r--r--system/std.zusatz/1.7.3/src/EMU16M.ELA162
-rw-r--r--system/std.zusatz/1.7.3/src/FONTR16.ELA360
-rw-r--r--system/std.zusatz/1.7.3/src/MINPRINT.ELA94
-rw-r--r--system/std.zusatz/1.7.3/src/TO16.ELA102
-rw-r--r--system/std.zusatz/1.7.3/src/complex133
-rw-r--r--system/std.zusatz/1.7.3/src/crypt139
-rw-r--r--system/std.zusatz/1.7.3/src/elan lister263
-rw-r--r--system/std.zusatz/1.7.3/src/eumel printer369
-rw-r--r--system/std.zusatz/1.7.3/src/eumelmeter130
-rw-r--r--system/std.zusatz/1.7.3/src/free channel292
-rw-r--r--system/std.zusatz/1.7.3/src/longint422
-rw-r--r--system/std.zusatz/1.7.3/src/matrix470
-rw-r--r--system/std.zusatz/1.7.3/src/minimal fonts routines9
-rw-r--r--system/std.zusatz/1.7.3/src/printer-M69
-rw-r--r--system/std.zusatz/1.7.3/src/printer-S36
-rw-r--r--system/std.zusatz/1.7.3/src/purge85
-rw-r--r--system/std.zusatz/1.7.3/src/referencer1077
-rw-r--r--system/std.zusatz/1.7.3/src/reporter479
-rw-r--r--system/std.zusatz/1.7.3/src/scheduler419
-rw-r--r--system/std.zusatz/1.7.3/src/spool manager377
-rw-r--r--system/std.zusatz/1.7.3/src/std printer434
-rw-r--r--system/std.zusatz/1.7.3/src/std printer generator-M22
-rw-r--r--system/std.zusatz/1.7.3/src/std printer generator-S15
-rw-r--r--system/std.zusatz/1.7.3/src/vector213
-rw-r--r--system/std.zusatz/1.7.5/src/eumel printer3067
-rw-r--r--system/std.zusatz/1.7.5/src/font convertor 91065
-rw-r--r--system/terminal-codes/1.8.2/src/AT.ascii(SHard>=4.5)74
-rw-r--r--system/terminal-codes/1.8.2/src/GEN182.ELA245
-rw-r--r--system/terminal-codes/unknown/src/A21078
-rw-r--r--system/terminal-codes/unknown/src/A210.german87
-rw-r--r--system/terminal-codes/unknown/src/A230+61
-rw-r--r--system/terminal-codes/unknown/src/DEC.VT220.ascii49
-rw-r--r--system/terminal-codes/unknown/src/DEC.VT220.german66
-rw-r--r--system/terminal-codes/unknown/src/DM553
-rw-r--r--system/terminal-codes/unknown/src/ELBIT.ascii32
-rw-r--r--system/terminal-codes/unknown/src/ELBIT.german47
-rw-r--r--system/terminal-codes/unknown/src/FT10-20.ascii75
-rw-r--r--system/terminal-codes/unknown/src/FT10-20.german94
-rw-r--r--system/terminal-codes/unknown/src/GENGEN.ELA244
-rw-r--r--system/terminal-codes/unknown/src/GT10044
-rw-r--r--system/terminal-codes/unknown/src/IBM.PC.AT63
-rw-r--r--system/terminal-codes/unknown/src/M2010
-rw-r--r--system/terminal-codes/unknown/src/M20.original27
-rw-r--r--system/terminal-codes/unknown/src/M2463
-rw-r--r--system/terminal-codes/unknown/src/M24.keybfr164
-rw-r--r--system/terminal-codes/unknown/src/PC.KB279
-rw-r--r--system/terminal-codes/unknown/src/PC.french68
-rw-r--r--system/terminal-codes/unknown/src/PC.german63
-rw-r--r--system/terminal-codes/unknown/src/Qume.german77
-rw-r--r--system/terminal-codes/unknown/src/REGENT2534
-rw-r--r--system/terminal-codes/unknown/src/REGENT4037
-rw-r--r--system/terminal-codes/unknown/src/RUC.AT.ascii75
-rw-r--r--system/terminal-codes/unknown/src/SIEMENS.PC-D88
-rw-r--r--system/terminal-codes/unknown/src/TAP5060.ELA49
-rw-r--r--system/terminal-codes/unknown/src/TVI.german57
-rw-r--r--system/terminal-codes/unknown/src/TVI914.ascii43
-rw-r--r--system/terminal-codes/unknown/src/VC404.ascii61
-rw-r--r--system/terminal-codes/unknown/src/VC404.german75
-rw-r--r--system/terminal-codes/unknown/src/VC404.hrz67
-rw-r--r--system/terminal-codes/unknown/src/VIDEOSTAR52
-rw-r--r--system/terminal-codes/unknown/src/basis108(ascii)90
-rw-r--r--system/terminal-codes/unknown/src/basis108(deutsch)106
-rw-r--r--system/terminal-codes/unknown/src/basis108(info)107
-rw-r--r--system/terminal-codes/unknown/src/ws58062
242 files changed, 81361 insertions, 0 deletions
diff --git a/system/at/unknown/src/AT Generator b/system/at/unknown/src/AT Generator
new file mode 100644
index 0000000..c78bdb9
--- /dev/null
+++ b/system/at/unknown/src/AT Generator
@@ -0,0 +1,134 @@
+(*************************************************************************)
+(*** Generiert Fr IBM-AT einen neuen SYSUR-Zweig. ***)
+(*** Danach wird die eingebaute Hardwareuhr fr die Systemzeit benutzt ***)
+(*** und andere Partitionen knnen mit neuem 'shutup' gebootet werden. ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+LET ack = 0,
+ nak = 1;
+
+cl eop (1, 4);
+erzeuge collector;
+erzeuge archive manager;
+erzeuge operator;
+erzeuge configurator;
+loesche collector;
+forget ("AT Generator", quiet);
+break.
+
+loesche collector :
+ end (/"colly");
+ put ("Collector gelscht.");
+ line (2).
+
+erzeuge collector :
+ put line ("Generating 'Collector'...");
+ begin ("colly", PROC generate collector, t);
+ warte auf meldung;
+ IF answer = nak THEN end (/"colly");
+ errorstop (meldung)
+ FI.
+ TASK VAR t.
+
+erzeuge archive manager :
+ put line ("Generating 'ARCHIVE'...");
+ end (/"ARCHIVE");
+ begin ("ARCHIVE", PROC archive manager, t).
+
+erzeuge operator :
+ put line ("Generating 'OPERATOR'...");
+ end (/"OPERATOR");
+ begin ("OPERATOR", PROC monitor, t).
+
+erzeuge configurator :
+ put line ("Generating 'configurator'...");
+ end (/"configurator");
+ begin ("configurator", PROC generate configurator, t);
+ warte auf meldung;
+ IF answer = nak THEN errorstop (meldung) FI.
+
+warte auf meldung :
+ DATASPACE VAR ds; INT VAR answer;
+ wait (ds, answer, t);
+ BOUND TEXT VAR m := ds;
+ TEXT VAR meldung := m;
+ forget (ds).
+
+PROC generate collector :
+
+ disable stop;
+ fetch all (/"configurator");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ free global manager.
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate collector;
+
+PROC generate configurator :
+
+ disable stop;
+ fetch all (/"colly");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ enable stop;
+ new configuration;
+ setup;
+ global manager (PROC ( DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time).
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate configurator;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
diff --git a/system/at/unknown/src/AT Utilities b/system/at/unknown/src/AT Utilities
new file mode 100644
index 0000000..d1c87d5
--- /dev/null
+++ b/system/at/unknown/src/AT Utilities
@@ -0,0 +1,601 @@
+(*************************************************************************)
+(*** AT-spezifische Software, die zum Lesen der Hardwareuhr und ***)
+(*** Booten in anderen Partitionen bentigt wird. ***)
+(*** ***)
+(*** Zusammengestellt und gendert : Werner Sauerwein, GMD ***)
+(*** Stand : 17.07.86 ***)
+(*************************************************************************)
+
+PACKET splitting DEFINES low byte, (* Copyright (C) 1985 *)
+ high byte, (* Martin Schnbeck, Spenge *)
+ low word, (* Stand: 13.09.85 *)
+ high word:
+
+INT PROC high byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 2)
+
+END PROC high byte;
+
+INT PROC low byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 1)
+
+END PROC low byte;
+
+INT PROC high word (REAL CONST double precission int):
+
+ int (double precission int / 65536.0)
+
+END PROC high word;
+
+INT PROC low word (REAL CONST double precission int):
+
+ string of low bytes ISUB 1.
+
+string of low bytes:
+ code (int (double precission int MOD 256.0)) +
+ code (int ((double precission int MOD 65536.0) / 256.0)).
+
+END PROC low word;
+END PACKET splitting;
+
+PACKET basic block io DEFINES
+
+ read block,
+ write block:
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, 0, block no, return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, 0, block no, return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, high word (block no),
+ low word (block no), return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, high word (block no),
+ low word (block no), return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+END PACKET basic block io;
+
+(**************************************************************************)
+
+PACKET part DEFINES activate : (* Copyright (C) 1985 *)
+ (* Martin Schnbeck, Spenge *)
+ (* Stand : 02.02.86 *)
+ (* Changed by : W.Sauerwein *)
+ (* Stand : 04.07.86 *)
+ LET fd channel = 28;
+
+ROW 256 INT VAR boot block;
+INT VAR boot block session := session - 1;
+
+PROC get boot block:
+
+ IF boot block session <> session
+ THEN hole aktuellen boot block
+ FI.
+
+hole aktuellen boot block:
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ get external block (dummy ds, 2, 0, fd channel);
+ IF NOT is error
+ THEN transfer data to boot block
+ FI;
+ forget (dummy ds).
+
+transfer data to boot block:
+ IF not valid boot block
+ THEN try to get valid boot block from file
+ FI;
+ boot block := partition table. block;
+ boot block session := session.
+
+not valid boot block:
+ partition table. block [256] <> boot indicator OR
+ it is an old boot block of eumel.
+
+boot indicator: -21931.
+
+it is an old boot block of eumel:
+ partition table. block [1] = 1514.
+
+try to get valid boot block from file:
+ forget (dummy ds);
+ partition table := old ("bootblock");
+ IF is error THEN LEAVE transfer data to boot block FI.
+
+END PROC get boot block;
+
+PROC put boot block:
+
+ IF boot block ist uptodate
+ THEN schreibe block auf platte
+ ELSE errorstop ("boot block nicht uptodate")
+ FI.
+
+boot block ist uptodate:
+ boot block session = session.
+
+schreibe block auf platte:
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ transfer data to dataspace;
+ put external block (dummy ds, 2, 0, fd channel);
+ forget (dummy ds).
+
+transfer data to dataspace:
+ partition table. block := boot block.
+
+END PROC put boot block;
+
+INT PROC partition type (INT CONST partition):
+
+ low byte (boot block [entry (partition) + 2])
+
+END PROC partition type;
+
+PROC activate (INT CONST part type):
+
+ IF partition type exists AND is possible type
+ THEN deactivate all partitions and
+ activate desired partition
+ ELSE errorstop ("Gewnschte Partitionart gibt es nicht")
+ FI.
+
+is possible type:
+ part type > 0 AND
+ part type < 256.
+
+partition type exists:
+ INT VAR partition;
+ FOR partition FROM 1 UPTO 4 REP
+ IF partition type (partition) = part type
+ THEN LEAVE partition type exists WITH TRUE
+ FI;
+ PER;
+ FALSE.
+
+deactivate all partitions and activate desired partition:
+ FOR partition FROM 1 UPTO 4 REP
+ deactivate this partition;
+ IF partition type (partition) = part type
+ THEN activate partition
+ FI
+ PER;
+ put boot block.
+
+deactivate this partition:
+ set bit (boot block [entry (partition)], 7);
+ (* first setting needed, because reset bit does xor *)
+ reset bit (boot block [entry (partition)], 7).
+
+activate partition:
+ set bit (boot block [entry (partition)], 7)
+
+END PROC activate;
+
+INT PROC entry (INT CONST partition):
+
+ get boot block;
+ 256 - 5 * 8 + (partition * 8)
+
+END PROC entry;
+
+PROC get external block (DATASPACE VAR ds, INT CONST ds page,
+ archive block, get channel):
+
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+
+END PROC get external block;
+
+PROC put external block (DATASPACE CONST ds, INT CONST ds page,
+ archive block, get channel):
+
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+
+END PROC put external block;
+END PACKET part;
+
+(**************************************************************************)
+
+PACKET hw clock DEFINES hw clock: (* Copyright (C) 1985 *)
+ (* Martin Schnbeck, Spenge *)
+LET clock length = 7, (* Stand: 06.11.85 *)
+ clock command = 4;
+
+BOUND STRUCT (ALIGN dummy,
+ ROW clock length INT clock field) VAR clock data;
+
+REAL PROC hw clock:
+
+ disable stop;
+ get clock;
+ hw date + hw time.
+
+get clock:
+ DATASPACE VAR ds := nilspace;
+ clock data := ds;
+ INT VAR return code, actual channel := channel;
+ go to shard channel;
+ blockin (ds, 2, -clock command, 0, return code);
+ IF actual channel = 0 THEN break (quiet)
+ ELSE continue (actual channel)
+ FI;
+ IF return code <> 0
+ THEN errorstop ("Keine Hardware Uhr vorhanden");
+ FI;
+ put clock into text;
+ forget (ds).
+
+put clock into text:
+ TEXT VAR clock text := clock length * " ";
+ INT VAR i;
+ FOR i FROM 1 UPTO clock length REP
+ replace (clock text, i, clock data. clock field [i]);
+ PER.
+
+go to shard channel:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 20 REP
+ continue (32);
+ IF is error
+ THEN clear error;
+ pause (30)
+ FI;
+ UNTIL channel = 32 PER.
+
+hw date:
+ date (day + "." + month + "." + year).
+
+day: subtext (clock text, 7, 8).
+
+month: subtext (clock text, 5, 6).
+
+year: subtext (clock text, 1, 4).
+
+hw time:
+ time (hour + ":" + minute + ":" + second).
+
+hour: subtext (clock text, 9, 10).
+
+minute: subtext (clock text, 11, 12).
+
+second: subtext (clock text, 13, 14).
+
+END PROC hw clock;
+END PACKET hw clock
+
+(**************************************************************************)
+
+PACKET old shutup DEFINES old shutup, (* Copyright (C) 1985 *)
+ old save system: (* Martin Schnbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC old shutup : shutup END PROC old shutup;
+
+PROC old save system : save system END PROC old save system;
+END PACKET old shutup;
+
+PACKET new shutup DEFINES shutup,
+ ms dos,
+ save system,
+ generate ms dos manager,
+ generate shutup manager:
+
+LET ack = 0;
+
+PROC shutup:
+
+ system down (PROC old shutup)
+
+END PROC shutup;
+
+PROC shutup (INT CONST new system):
+
+ IF new system <> 0
+ THEN prepare for new system
+ FI;
+ system down (PROC old shutup).
+
+prepare for new system:
+ activate (new system);
+ prepare for rebooting.
+
+prepare for rebooting:
+ INT VAR old channel := channel;
+ continue (32);
+ INT VAR dummy;
+ control (-5, 0, 0, dummy);
+ break (quiet);
+ continue (old channel).
+
+END PROC shutup;
+
+PROC ms dos:
+
+ shutup (1)
+
+END PROC ms dos;
+
+PROC save system:
+
+ IF yes ("Leere Floppy eingelegt")
+ THEN system down (PROC old save system)
+ FI
+
+END PROC save system;
+
+PROC system down (PROC operation):
+
+ BOOL VAR dialogue :: command dialogue;
+ command dialogue (FALSE);
+ operation;
+ command dialogue (dialogue);
+ IF command dialogue
+ THEN wait for configurator;
+ show date;
+ FI.
+
+show date:
+ page;
+ line (2);
+ put (" Heute ist der"); putline (date);
+ put (" Es ist"); put (time of day); putline ("Uhr");
+ line (2).
+
+END PROC system down;
+
+DATASPACE VAR ds := nilspace;
+
+PROC wait for configurator:
+
+ INT VAR i, receipt;
+ FOR i FROM 1 UPTO 20 WHILE configurator exists REP
+ pause (30);
+ forget (ds);
+ ds := nilspace;
+ ping pong (configurator, ack, ds, receipt)
+ UNTIL receipt >= 0 PER.
+
+configurator exists:
+ disable stop;
+ TASK VAR configurator := task ("configurator");
+ clear error;
+ NOT is niltask (configurator).
+
+END PROC wait for configurator;
+
+PROC generate shutup manager:
+
+ generate shutup manager ("shutup", 0);
+
+END PROC generate shutup manager;
+
+PROC generate ms dos manager:
+
+ generate shutup manager ("ms dos", 1);
+
+END PROC generate ms dos manager;
+
+PROC generate shutup manager (TEXT CONST name, INT CONST new system):
+
+ TASK VAR son;
+ shutup question := name;
+ new system for manager := new system;
+ begin (name, PROC shutup manager, son)
+
+END PROC generate shutup manager;
+
+INT VAR new system for manager;
+TEXT VAR shutup question;
+
+PROC shutup manager:
+
+ disable stop;
+ command dialogue (TRUE);
+ REP
+ break;
+ line ;
+ IF yes (shutup question)
+ THEN clear error;
+ shutup (new system for manager);
+ pause (300);
+ FI;
+ PER
+
+END PROC shutup manager;
+END PACKET new shutup
+
+(**************************************************************************)
+
+PACKET config manager with time DEFINES configuration manager ,
+ configuration manager with time :
+ (* Copyright (C) 1985 *)
+INT VAR old session := 0; (* Martin Schnbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC configuration manager:
+
+ configurate;
+ break;
+ global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time)
+
+END PROC configuration manager;
+
+PROC configuration manager with time (DATASPACE VAR ds, INT CONST order,
+ phase, TASK CONST order task):
+
+ IF old session <> session
+ THEN
+ disable stop;
+ set clock (hw clock);
+ set clock (hw clock); (* twice, to avoid all paging delay *)
+ IF is error THEN IF online THEN put error; clear error; pause (100)
+ ELSE errorstop (error message)
+ FI FI;
+ old session := session;
+ set autonom;
+ FI;
+ configuration manager (ds, order, phase, order task);
+
+END PROC configuration manager with time;
+END PACKET config manager with time;
diff --git a/system/at/unknown/src/AT install b/system/at/unknown/src/AT install
new file mode 100644
index 0000000..1fedf70
--- /dev/null
+++ b/system/at/unknown/src/AT install
@@ -0,0 +1,92 @@
+(*************************************************************************)
+(*** Insertiert alle notwendigen Pakete, damit ein AT-System generiert ***)
+(*** werden kann, das die Hardwareuhr lesen und Partitionen bedienen ***)
+(*** kann. Startet den "AT Generator". ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+erste bildschirmmeldung;
+IF ich bin single THEN putline ("Die AT-spezifische Software ist nur auf Multi-User-Systemen benutzbar !")
+ ELSE hole dateien vom archiv;
+ insertiere alle pakete;
+ put line ("Running ""AT Generator""...");
+ run ("AT Generator")
+FI;
+forget ("AT install", quiet).
+
+ich bin single : (pcb (9) AND 255) <= 1.
+
+insertiere alle pakete :
+ insert and say ("AT Utilities").
+
+erste bildschirmmeldung :
+ page;
+ put center (" Generator fr AT-spezifische Software gestartet."); line;
+ put center ("--------------------------------------------------");
+ line (2).
+
+hole dateien vom archiv :
+ TEXT VAR datei;
+ datei := "AT Utilities"; hole wenn noetig;
+ datei := "AT Generator"; hole wenn noetig;
+ release (archive);
+ line.
+
+hole wenn noetig :
+ IF NOT exists (datei) THEN
+ put line ("Loading """ + datei + """...");
+ fetch (datei, archive)
+ FI.
+
+PROC insert and say (TEXT CONST datei) :
+
+ INT VAR cx, cy;
+ put line ("Inserting """ + datei + """...");
+ get cursor (cx, cy);
+ insert (datei);
+ cl eop (cx, cy); line;
+ forget (datei, quiet).
+
+END PROC insert and say;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
diff --git a/system/base/unknown/src/SPOLMAN5.ELA b/system/base/unknown/src/SPOLMAN5.ELA
new file mode 100644
index 0000000..99d4ec2
--- /dev/null
+++ b/system/base/unknown/src/SPOLMAN5.ELA
@@ -0,0 +1,1003 @@
+PACKET queue handler DEFINES enter into que,
+ exists in que,
+ all in que,
+ erase from que,
+ erase last top of que,
+ get top of que,
+ restore ,
+ list que,
+ info, killer,first,
+ que status,
+ que empty,
+ set entry types,
+ change entry types,
+ initialize que:
+
+
+LET que size = 100,
+
+ empty = 0,
+ used = 1,
+ blocked = 2,
+ nil = 0,
+ user error = 99,
+ unused char = ""0"",
+ used char = ""1"",
+ blocked char= ""2"",
+ ENTRY = STRUCT(TEXT title, TASK origin, TEXT origin name,
+ DATASPACE space, INT storage, acc code ) ;
+
+ROW que size ENTRY VAR que ;
+
+TEXT VAR status list;
+BOOL VAR n ok := FALSE;
+INT VAR top of que,
+ first que entry,
+ last que entry,
+ index ;
+
+.entry: que[index]. ;
+
+PROC initialize que :
+ FOR index FROM 1 UPTO que size REP
+ forget( entry.space );
+ entry.acc code := empty
+ END REP ;
+ first que entry := nil;
+ last que entry := nil;
+ top of que := nil;
+ index := nil;
+ status list := que size * unused char;
+END PROC initialize que ;
+
+initialize que ;
+
+(****************** Interne Queue-Zugriffsoperationen **********************)
+
+INT PROC next (INT CONST pre) :
+ pre MOD que size + 1
+END PROC next ;
+
+PROC block (INT CONST entry number) :
+ que [entry number].acc code := blocked;
+ replace (status list,entry number,blocked char);
+ENDPROC block;
+
+PROC unblock (INT CONST entry number) :
+ que [entry number].acc code := used;
+ replace (status list,entry number,used char);
+ENDPROC unblock;
+
+PROC to next que entry:
+ REP
+ IF index = last que entry OR index = nil
+ THEN index := nil ; LEAVE to next que entry
+ FI ;
+ index := next(index)
+ UNTIL entry.acc code <> empty PER
+END PROC to next que entry ;
+
+PROC to first que entry :
+ index := first que entry
+END PROC to first que entry ;
+
+PROC search que entry (TEXT CONST title, TASK CONST origin) :
+
+ check if index identifies entry ;
+ IF last que entry = nil
+ THEN index := nil
+ ELSE index := last que entry ;
+ REPEAT
+ IF is wanted entry
+ THEN LEAVE search que entry
+ FI ;
+ IF index = first que entry
+ THEN index := nil
+ ELSE index DECR 1 ;
+ IF index = 0
+ THEN index := que size
+ FI
+ FI
+ UNTIL index = nil PER
+ FI.
+
+is wanted entry:
+
+ entry.acc code <> empty CAND
+ entry.title = title CAND
+ (entry.origin = origin OR
+ origin = niltask ).
+
+check if index identifies entry:
+
+ IF index <> nil CAND is wanted entry
+ THEN LEAVE search que entry
+ FI
+
+END PROC search que entry ;
+
+PROC exec erase :
+
+ forget (entry.space) ; entry.acc code := empty ;
+ replace (status list,index,unused char);
+ try to cut off queue ends.
+
+try to cut off queue ends:
+
+ WHILE first entry is not valid REP
+ check if que empty ;
+ first que entry := next(first que entry)
+ END REP ;
+ WHILE last entry is not valid REP
+ make index invalid if necessary ;
+ last que entry DECR 1 ;
+ IF last que entry = 0
+ THEN last que entry := que size
+ FI
+ END REP .
+
+first entry is not valid:
+ que [first que entry].acc code = empty.
+
+last entry is not valid:
+ que [last que entry].acc code = empty.
+
+check if que empty:
+ IF first que entry = last que entry
+ THEN first que entry := nil ;
+ last que entry := nil ;
+ index := nil ;
+ LEAVE try to cut off queue ends
+ FI.
+
+make index invalid if necessary:
+ IF index = last que entry
+ THEN index := nil
+ FI.
+
+END PROC exec erase ;
+
+PROC exec first:
+ IF next (last que entry) = first que entry
+ THEN errorstop ("Queue ist voll - vorziehen unmoeglich")
+ ELIF index = top of que
+ THEN errorstop ("Auftrag wird bereits bearbeitet")
+ ELIF entry.acc code = empty
+ THEN errorstop ("undefinierter Queue-Eintrag. /exec first")
+ ELSE first que entry DECR 1 ;
+ IF first que entry = 0
+ THEN first que entry := que size
+ FI ;
+ que[first que entry] := que[index] ;
+ replace (status list,first que entry,code (entry.acc code));
+ exec erase
+ FI
+END PROC exec first ;
+
+PROC erase last top of que:
+ IF top of que <> nil
+ THEN index := top of que; exec erase;
+ top of que := nil
+ FI
+END PROC erase last top of que;
+
+
+(****************** Behandlung von DATASPACE-typen ***********************)
+
+LET semicolon = ";" ,
+ colon = ":" ,
+ quote = """";
+TEXT VAR entry types :: "" ;
+
+BOOL PROC no permitted type (DATASPACE CONST ds) :
+ TEXT CONST type nr :: semicolon + text(type(ds)) + colon;
+ INT CONST t pos :: pos (entry types,type nr) ;
+ entry types <> "" CAND t pos = 0
+END PROC no permitted type ;
+
+TEXT PROC record of que entry:
+ IF entry.acc code = empty
+ THEN errorstop ("undefinierter Queue-Eintrag. /record");""
+ ELSE TEXT VAR record :: "" ;
+ record CAT storage in k ;
+ record CAT type of entry ;
+ record CAT name of entry ;
+ record CAT origin of entry ;
+ IF entry.acc code = blocked THEN record CAT "- blocked -" FI;
+ record
+ FI.
+
+storage in k:
+
+ text (entry.storage,3) + " K ".
+
+type of entry:
+
+ IF entry types = ""
+ THEN 12 * "?"
+ ELSE TEXT CONST type nr :: semicolon + text(type(entry.space)) + colon ;
+ INT CONST semi colon pos :: pos (entry types, type nr),
+ start type :: semi colon pos + LENGTH type nr ,
+ end type :: pos(entrytypes,semicolon,starttype)-1;
+ IF semi colon pos = 0
+ THEN 12 * "?"
+ ELSE text( subtext(entry types, starttype, endtype),12)
+ FI
+ FI.
+
+name of entry:
+
+ text (quote+ entry.title +quote, 20) .
+
+origin of entry:
+
+ IF entry.origin = niltask
+ THEN 20 * " "
+ ELSE text (" TASK: "+entry.origin name,20)
+ FI
+
+END PROC record of que entry ;
+
+PROC set entry types (TEXT CONST t) :
+ check if void ;
+ IF first char is no semicolon
+ THEN entry types := semicolon
+ ELSE entry types := ""
+ FI;
+ entry types CAT t ;
+ IF last char is no semicolon
+ THEN entry types CAT semicolon
+ FI.
+
+check if void:
+ IF t = ""
+ THEN entry types := "";
+ LEAVE set entry types
+ FI.
+
+first char is no semicolon:
+ (t SUB 1) <> semicolon.
+
+last char is no semicolon:
+ (t SUB length(t)) <> semicolon
+
+END PROC set entry types ;
+
+PROC change entry types:
+ TEXT VAR t :: entry types;
+ line;putline("Entrytypes :");
+ editget(t);
+ set entry types (t)
+END PROC change entry types;
+
+
+(************************ Std Zugriffe auf Queue ***************************)
+
+
+PROC erase from que (TEXT CONST title, TASK CONST origin) :
+ search que entry (title, origin) ;
+ IF index = nil
+ THEN errorstop ("Auftrag existiert nicht. /erase")
+ ELIF index = top of que
+ THEN errorstop (user error, "Dieser Auftrag wird bereits bearbeitet")
+ ELSE exec erase
+ FI
+END PROC erase from que ;
+
+BOOL PROC exists in que (TEXT CONST title, TASK CONST origin) :
+ search que entry (title, origin) ;
+ index <> nil
+END PROC exists in que ;
+
+PROC info (BOOL CONST b) : n ok := b ENDPROC info;
+
+THESAURUS PROC all in que (TASK CONST origin) :
+
+ THESAURUS VAR result := empty thesaurus ;
+ to first que entry ;
+ WHILE index <> 0 REP
+ IF entry.origin = origin OR origin = niltask
+ THEN insert (result, entry.title)
+ FI ;
+ to next que entry
+ END REP ;
+ result
+
+END PROC all in que ;
+
+PROC enter into que (TEXT CONST title, TASK CONST origin,
+ DATASPACE CONST space ):
+
+ IF next(last que entry) = first que entry
+ THEN errorstop ("Queue zu voll")
+ ELIF no permitted type (space) OR title = ""
+ THEN errorstop (user error, "Auftrag wird nicht angenommen")
+ ELSE last que entry := next(last que entry);
+ index := last que entry;
+ entry := ENTRY:
+ ( title, origin,task name, space, storage(space), used ) ;
+ IF first que entry = nil
+ THEN first que entry := 1
+ FI ;
+ replace (status list,last que entry,used char);
+ FI.
+
+task name :
+ TEXT VAR name of task :: name (origin);
+ IF name of task = "stemmer" AND n ok THEN "stemmi" ELSE name of task FI.
+
+END PROC enter into que ;
+
+PROC get top of que (DATASPACE VAR top space) :
+ forget (top space) ;
+ IF que empty
+ THEN errorstop ("kein Auftrag vorhanden. /get")
+ ELSE erase last top of que;
+ top of que := first que entry;
+ IF que [top of que].acc code = blocked THEN
+ wrap around if necessary
+ ELSE top space := que [first que entry].space ; FI;
+ FI .
+
+wrap around if necessary :
+
+ IF entry is allowed to be printed THEN
+ give it to spool manager
+ ELSE enter into end of queue FI.
+
+entry is allowed to be printed :
+ pos (status list,used char) = nil.
+
+give it to spool manager :
+ top space := que [first que entry].space;
+ que [first que entry].acc code := used.
+
+enter into end of queue :
+ top space := que [first que entry].space;
+ enter into que (que [first que entry].title,que [first que entry].origin
+ ,top space);
+ index := first que entry;
+ IF entry.acc code = blocked THEN block (index) FI;
+ get top of que (top space).
+
+END PROC get top of que ;
+
+PROC restore:
+ top of que := nil
+END PROC restore ;
+
+BOOL PROC que empty: (* 'top of que' gilt nicht *)
+ first que entry = last que entry AND
+ top of que = last que entry.
+END PROC que empty ;
+
+PROC que status (INT VAR size, TEXT VAR top title,
+ TASK VAR top origin, TEXT VAR top origin name ):
+
+ size := last que entry - first que entry ; (* geloeschte Eintraege *)
+ IF size < 0 (* zaehlen mit !! *)
+ THEN size INCR que size (* (aber nicht 'top' ) *)
+ FI ;
+ IF top of que <> nil
+ THEN top title := que [top of que].title ;
+ top origin := que [top of que].origin ;
+ top origin name := que [top of que].origin name
+ ELSE size INCR 1 ;
+ top title := "" ;
+ top origin := niltask ;
+ top origin name := ""
+ FI
+END PROC que status ;
+
+TEXT VAR sep :: 79 * "_", record :: "",
+ ask :: "editieren (e),kopieren (k),loeschen (l)," +
+ "vorziehen (v),duplizieren (d),"13""10"" +
+ "print --> quickprint (q),blockieren (b),freigeben (f)," +
+ "weiter (w) ? ";
+
+PROC info :
+
+ to first que entry;
+ WHILE index <> nil REP
+ record := record of que entry;
+ WHILE index <> top of que REPEAT
+ ask user what to do;
+ out (input char);
+ exec command
+ UNTIL command index = 1 PER;
+ to next que entry;
+ PER.
+
+ask user what to do :
+
+ out (""13""10"");out (sep);out (""13""10""13""10"");
+ out (record);
+ out (""13""10""10"");out (ask);
+ INT VAR command index; TEXT VAR input char;
+ REPEAT
+ inchar (input char);
+ command index := pos ("w eklvdqbf",input char);
+ UNTIL command index > 0 PER.
+
+exec command :
+
+ SELECT command index OF
+ CASE 3 : INT VAR old dataspace type := type (entry.space);
+ type (entry.space,1003);
+ FILE VAR f :: sequentialfile (modify,entry.space);
+ edit (f); line (2);
+ type (entry.space,old dataspace type)
+ CASE 4 : forget (entry.title,quiet);
+ copy (entry.space,entry.title);
+ type (old (entry.title),1003)
+ CASE 5 : exec erase ;command index := 1
+ CASE 6 : exec first ;command index := 1
+ CASE 7 : INT VAR dummy no := index;
+ enter into que (que [dummy no].title,que [dummy no].origin,
+ que [dummy no].space)
+ CASE 8 : type (entry.space,1103) ;record := record of que entry;
+ CASE 9 : block (index) ;record := record of que entry;
+ CASE 10: unblock (index); record := record of que entry;
+ ENDSELECT.
+
+ENDPROC info;
+
+PROC list que (FILE VAR f, DATASPACE VAR ds) :
+ open listfile ;
+ to first que entry ;
+ WHILE index <> nil REP
+ TEXT VAR record :: record of que entry ;
+ IF index = top of que
+ THEN record := text(record,60) ;
+ record CAT ""15"wird bearbeitet"14""
+ FI ;
+ putline (f,record) ;
+ to next que entry
+ END REP.
+
+open listfile:
+
+ forget (ds) ;
+ ds := nilspace ;
+ f := sequentialfile (output,ds) ;
+ headline (f, name(myself) + " - Queue") ;
+ line (f)
+
+END PROC list que ;
+
+PROC killer : info ENDPROC killer;
+PROC first : info ENDPROC first;
+
+END PACKET queue handler ;
+
+(***************************************************************************)
+(* Programm zur Verwaltung einer Servertask *)
+(* (benutzt 'queue handler') *)
+(* Autor: A.Vox *)
+(* Stand: 3.6.85 *)
+(* *)
+(***************************************************************************)
+PACKET spool manager DEFINES server status,
+ server modus,
+ server task,
+ server channel,
+ server routine,
+ server fail msg,
+
+ log edit,
+ logline,
+ logfilename,
+ check,
+ feed server if hungry,
+ check if server vanished,
+
+ spool manager,
+ get title and origin,
+
+ start,
+ stop,
+ pause,
+ spool info,
+ list,
+ spool maintenance:
+
+
+ LET user error = 99;
+
+ LET { Status: } { Modus: }
+ init = 0, active = 0,
+ work = 1, paused = 1,
+ wait = 2, stopped = 2,
+ dead = 3;
+
+ LET cmd form feed = ""12"";
+
+INT VAR status :: init,
+ modus :: stopped;
+
+TASK VAR server :: niltask;
+TEXT VAR routine :: "",
+ fail msg:: "";
+INT VAR channel :: 0;
+(************ Globale Variablen fuer alle 'que status'-Aufrufe ************)
+
+INT VAR que size;
+TEXT VAR actual title,
+ actual origin name;
+TASK VAR actual origin;
+
+
+(*********** Zugriffsoperationen auf wichtige Paketvariablen **************)
+
+TASK PROC servertask : server END PROC servertask;
+INT PROC serverstatus : status END PROC serverstatus;
+INT PROC servermodus : modus END PROC servermodus;
+TEXT PROC serverroutine : routine END PROC serverroutine;
+TEXT PROC serverfailmsg : fail msg END PROC serverfailmsg;
+INT PROC serverchannel : channel END PROC serverchannel;
+
+PROC serverroutine (TEXT CONST neu):
+ routine := neu
+END PROC serverroutine;
+
+PROC serverfailmsg (TEXT CONST neu):
+ failmsg := neu
+END PROC serverfailmsg;
+
+PROC serverchannel (INT CONST neu):
+ channel := neu
+END PROC serverchannel;
+
+(************************* Basic Spool Routines ***************************)
+
+TEXT CONST logfilename :: "Vorkommnisse";
+FILE VAR logfile;
+
+TEXT VAR fail title :: "" ;
+TASK VAR fail origin :: niltask ;
+REAL VAR fail time :: 0.0 ;
+
+PROC logline (TEXT CONST mess):
+ logfile := sequential file(output, logfilename) ;
+ clear file if too large ;
+ put(logfile, date);
+ put(logfile, time of day);
+ put(logfile, " : ");
+ putline(logfile, mess)
+END PROC logline ;
+
+PROC log edit:
+ enable stop ;
+ IF NOT exists(logfilename)
+ THEN errorstop ("keine Eintragungen vorhanden")
+ ELSE logfile := sequentialfile(modify,logfilename) ;
+ position to actual page;
+ edit(logfile);
+ line (2);
+ forget (logfilename);
+ FI.
+
+position to actual page:
+
+ INT CONST begin of last page :: lines(logfile)-22 ;
+ logfile := sequential file(modify,logfilename);
+ IF begin of last page < 1
+ THEN toline(logfile,1)
+ ELSE toline(logfile,begin of last page)
+ FI
+
+END PROC logedit;
+
+PROC clear file if too large:
+ IF lines(logfile) > 1000
+ THEN modify (logfile) ;
+ toline (logfile, 900) ;
+ remove (logfile, 900) ;
+ clear removed (logfile) ;
+ output (logfile)
+ FI
+END PROC clear file if too large ;
+
+PROC end server (TEXT CONST mess):
+ access catalogue;
+ IF exists (server) CAND son(myself) = server
+ THEN end(server)
+ FI;
+ failtime := clock(1);
+ que status (que size, fail title, fail origin, actual origin name) ;
+ logline (mess) ;
+ IF fail title <> ""
+ THEN logline(""""+fail title+""" von Task: "+actual origin name)
+ ELSE logline("kein Auftrag betroffen")
+ FI ;
+ status := dead ;
+ server := niltask
+END PROC end server;
+
+PROC check (TEXT CONST title, TASK CONST origin):
+ check if server vanished ;
+ IF less than 3 days ago AND
+ was failure AND
+ title matches AND
+ origin matches
+ THEN fail origin := myself ;
+ errorstop (user error, """"+fail title+""" abgebrochen")
+ FI.
+
+less than 3 days ago:
+ clock(1) < fail time + 3.0 * day.
+
+origin matches:
+ (origin = fail origin OR origin = niltask).
+
+title matches:
+ (title = fail title OR title = "").
+
+was failure:
+ fail title <> ""
+
+END PROC check ;
+
+PROC start server:
+ begin (PROC server start,server) ;
+ status := init
+END PROC start server;
+
+PROC server start:
+ disable stop ;
+ IF channel <> 0
+ THEN continue (channel) ;
+ FI ;
+ command dialogue (FALSE) ;
+ out (cmd form feed);
+ do (routine) ;
+ IF is error
+ THEN call(logline code, "Server-Fehler :",father);
+ call(logline code, error message, father) ;
+ call(logline code, "Zeile: " + text(errorline) +
+ " Code: " + text(errorcode) ,father)
+ ELSE call(logline code, "Ende des Server-Programms erreicht",father)
+ FI ;
+ IF online
+ THEN out (fail msg)
+ FI ;
+ call (terminate code,fail msg, father) ;
+ end (myself)
+END PROC server start ;
+
+PROC check if server vanished:
+ IF NOT (server = nil task) CAND NOT exists (server)
+ THEN end server ("Server gestorben :") ;
+ start server
+ FI
+END PROC check if server vanished;
+
+
+(*************************** Manager Routines *****************************)
+
+ LET ack = 0,
+ second phase ack = 5,
+ not existing nak = 6,
+
+ begin code = 4,
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ clear code = 18,
+ release code = 20,
+ check code = 22,
+
+ terminate code = 25,
+ logline code = 26,
+ get title code = 27,
+
+ continue code = 100;
+
+
+DATASPACE VAR packet space ;
+INT VAR reply ;
+BOUND STRUCT(TEXT f name,a,b) VAR msg ;
+.f name: msg.f name. ;
+
+TEXT VAR save title :: "";
+FILE VAR listfile;
+
+PROC get title and origin (TEXT VAR title, origin):
+ forget (packet space) ;
+ packet space := nilspace ;
+ call (father, get title code, packet space, reply) ;
+ IF reply = ack
+ THEN msg := packet space ;
+ title := msg.f name ;
+ origin := msg.a ;
+ forget (packet space)
+ ELSE forget (packet space) ;
+ errorstop ("'get title' nicht erfolgreich. Antwort="+text(reply))
+ FI
+END PROC get title and origin;
+
+PROC feed server if hungry:
+ check if server vanished ;
+ IF status = wait AND NOT que empty
+ THEN get top of que (packet space) ;
+ send (server, ack, packet space, reply) ;
+ forget (packet space) ;
+ IF reply = ack
+ THEN status := work
+ ELSE restore ;
+ end server ("Server nimmt keinen Auftrag an") ;
+ start server
+ FI
+ FI
+ENDPROC feed server if hungry;
+
+PROC server request (DATASPACE VAR ds, INT CONST order, phase) :
+
+ enable stop ;
+ msg := ds ;
+ SELECT order OF
+ CASE terminate code: terminate
+ CASE logline code: logline (f name) ;send(server, ack, ds)
+ CASE get title code: send title
+ OTHERWISE
+ IF order = fetch code CAND f name = "-"
+ THEN send top of que
+ ELSE freemanager (ds,order,phase,server)
+ FI
+ END SELECT ;
+ forget(ds).
+
+terminate:
+ end server ("Server terminiert :") ;
+ start server.
+
+send title:
+ forget (ds) ;
+ ds := nilspace ;
+ msg := ds ;
+ que status (que size, msg.f name, actual origin, msg.a) ;
+ send (server, ack, ds).
+
+send top of que:
+ status := wait ;
+ erase last top of que ;
+ IF modus = active
+ THEN feed server if hungry
+ FI
+
+END PROC server request;
+
+PROC spool manager(DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+
+ IF ordertask < myself
+ THEN server request (ds,order,phase)
+ ELIF ordertask = supervisor
+ THEN system request
+ ELSE spool command (ds,order,phase,order task)
+ FI;
+ check storage;
+ error protocol.
+
+check storage:
+ INT VAR size, used;
+ storage(size,used);
+ IF used > size
+ THEN logline("Speicher-Engpass :");
+ initialize que;
+ logline("Queue geloescht !!");
+ stop
+ FI.
+
+error protocol:
+ IF is error AND error code <> user error
+ THEN logline ("Spool-Fehler :") ;
+ logline (errormessage) ;
+ logline (" Zeile: " + text(errorline) +
+ " Code: " + text(errorcode) )
+ FI.
+
+system request:
+ IF order > continue code
+ THEN call (supervisor,order,ds,reply) ;
+ forget(ds) ;
+ IF reply = ack
+ THEN spool maintenance
+ FI
+ FI
+
+END PROC spool manager;
+
+PROC spool command (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task):
+
+ enable stop ;
+ check if server vanished ;
+ msg := ds ;
+ SELECT order OF
+ CASE begin code : special begin
+ CASE fetch code: y get logfile
+ CASE save code : y save
+ CASE exists code: y exists
+ CASE erase code: y erase
+ CASE list code: y list
+ CASE all code: y all
+ CASE release code,
+ clear code: y restart
+ CASE check code: y check
+ OTHERWISE errorstop (user error, "Kein Kommando fuer SPOOLER")
+ END SELECT.
+
+special begin :
+ INT VAR dummy;
+ call (public,begin code,ds,dummy);
+ send (order task,ack,ds).
+
+y get logfile:
+ forget(ds) ;
+ ds := old(logfilename) ;
+ send (ordertask, ack, ds).
+
+y erase:
+ IF NOT exists in que (f name,ordertask)
+ THEN manager message(""""+f name+""" steht nicht in der Queue")
+ ELIF phase = 1
+ THEN manager question (""""+f name+""" aus der Queue loeschen")
+ ELSE erase from que (f name,ordertask) ;
+ send (ordertask, ack, ds)
+ FI.
+
+y save:
+ IF phase = 1
+ THEN save title := f name ;
+ send (order task,second phase ack,ds);
+ ELSE enter into que (save title, ordertask, ds) ;
+ IF modus = active
+ THEN feed server if hungry
+ FI ;
+ send (order task,ack,ds);
+ FI.
+
+y list:
+ list que (listfile,ds) ;
+ send (ordertask, ack, ds).
+
+y all:
+ forget(ds) ;
+ ds := nilspace ;
+ BOUND THESAURUS VAR all names := ds ;
+ all names := all in que (ordertask) ;
+ send (ordertask, ack, ds).
+
+y exists:
+ IF exists in que (f name,ordertask)
+ THEN send (ordertask, ack, ds)
+ ELSE send (ordertask, not existing nak, ds)
+ FI.
+
+y check:
+ check (f name,ordertask) ;
+ questatus (que size, actual title, actual origin, actual origin name) ;
+ IF there is a title AND
+ is actual origin AND
+ is actual title
+ THEN manager message (""""+f name+""" wird soeben bearbeitet")
+ ELIF exists in que (f name,ordertask)
+ THEN manager message (""""+f name+""" steht noch in der Queue")
+ ELSE errorstop (usererror, """"+f name+""" steht nicht in der Queue")
+ FI.
+
+ there is a title: actual title <> "" .
+ is actual origin: ordertask = actual origin .
+ is actual title : (f name = "" OR f name = actual title) .
+
+y restart:
+ questatus (que size, actual title, actual origin, actual origin name) ;
+ IF actual origin = ordertask
+ THEN IF phase = 1
+ THEN manager question (""""+actual title+""" unterbrechen")
+ ELSE end server ("unterbrochen durch Auftraggeber :") ;
+ start server ;
+ IF order = clear code
+ THEN restore
+ ELSE erase last top of que
+ FI ;
+ manager message ("Auftrag unterbrochen")
+ FI
+ ELSE errorstop (usererror, "kein eigener Auftrag")
+ FI
+
+END PROC spool command ;
+
+PROC start:
+ IF modus = stopped
+ THEN start server ;
+ modus := active;
+ message ("Server aktiviert")
+ ELIF modus = paused
+ THEN modus := active ;
+ message ("'Pause'-Modus zurueckgesetzt") ;
+ feed server if hungry
+ ELSE message ("Server bereits aktiv")
+ FI
+END PROC start;
+
+PROC stop:
+ IF modus <> stopped
+ THEN end server ("Gestoppt :");
+ modus := stopped ;
+ status := init ;
+ message ("Server gestoppt")
+ ELSE message ("Server bereits gestoppt")
+ FI
+END PROC stop;
+
+PROC pause:
+ IF modus = active
+ THEN modus := paused ;
+ message ("'Pause'-Modus gesetzt")
+ ELIF modus = paused
+ THEN message ("'Pause'-Modus bereits gesetzt")
+ ELSE errorstop ("Server ist gestoppt")
+ FI
+END PROC pause;
+
+PROC message (TEXT CONST mess):
+ say(""13""10"") ;
+ say(mess) ;
+ say(""13""10"")
+END PROC message ;
+
+PROC list:
+ list que(listfile,packet space) ;
+ show(listfile)
+END PROC list;
+
+PROC spool maintenance:
+ command dialogue (TRUE);
+ IF exists(logfilename)
+ THEN logedit
+ FI;
+ WHILE online REP
+ get command ("gib spool kommando :") ;
+ do command
+ END REP ;
+ command dialogue (FALSE) ;
+ break ;
+ set autonom
+END PROC spool maintenance ;
+
+PROC spoolinfo:
+ check if server vanished ;
+ que status (que size, actual title, actual origin, actual origin name) ;
+ line(2) ;
+ putline("Queue :") ;
+ put("Auslastung :");put(que size); line;
+ IF actual title <> ""
+ THEN put("Aktueller Auftrag :");putline(actual title);
+ put(" von Task :");putline(actual origin name)
+ FI ;
+ line ;
+ putline("Server :");
+ put("Status :");
+ SELECT status OF
+ CASE init : putline("initialisiert")
+ CASE work : putline("arbeitet")
+ CASE wait : putline("wartet")
+ OTHERWISE putline("gestorben")
+ END SELECT ;
+ put("Modus :");
+ SELECT modus OF
+ CASE active : putline("aktiv")
+ CASE paused : putline("pausierend")
+ OTHERWISE putline("gestoppt")
+ END SELECT ;
+ put("Kanal :");put(pcb(server,4));
+ line(2)
+END PROC spool info
+
+END PACKET spool manager;
+
diff --git a/system/base/unknown/src/STD.ELA b/system/base/unknown/src/STD.ELA
new file mode 100644
index 0000000..047db9a
--- /dev/null
+++ b/system/base/unknown/src/STD.ELA
@@ -0,0 +1,220 @@
+PACKET command dialogue DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 26.04.82 *)
+ command dialogue ,
+ say ,
+ yes ,
+ no ,
+ param position ,
+ last param :
+
+
+LET up = ""3"" ,
+ right = ""2"" ,
+ param pre = " (""" ,
+ param post = """)"13""10"" ;
+
+TEXT VAR std param := "" ;
+
+BOOL VAR dialogue flag := TRUE ;
+
+INT VAR param x := 0 ;
+
+
+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 :
+ put (question) ;
+ skip previous input chars ;
+ put ("(j/n) ?") ;
+ get answer ;
+ IF correct answer
+ THEN putline (answer) ;
+ 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
+ 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 ;
+
+ENDPACKET command dialogue ;
+
+
+PACKET input DEFINES (* Stand: 01.05.81 *)
+
+ get ,
+ getline ,
+ get secret line :
+
+
+LET cr = ""13"" ,
+ esc = ""27"" ,
+ rubout = ""12"" ,
+ bell = ""7"" ,
+ back blank back = ""8" "8"" ,
+ del line cr lf = ""5""13""10"" ;
+
+PROC get (TEXT VAR word) :
+
+ REP
+ get (word, " ")
+ 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) :
+
+ word := "" ;
+ feldseparator (separator) ;
+ editget (word) ;
+ feldseparator ("") ;
+ echoe last char
+
+ENDPROC get ;
+
+PROC echoe last char :
+
+ TEXT CONST last char := feldzeichen ;
+ IF last char = ""13""
+ THEN out (""13""10"")
+ ELSE out (last char)
+ FI
+
+ENDPROC echoe last char ;
+
+PROC get (TEXT VAR word, INT CONST length) :
+
+ word := "" ;
+ feldseparator ("") ;
+ editget (word, length, length) ;
+ echoe last char
+
+ENDPROC get ;
+
+PROC getline (TEXT VAR line ) :
+
+ line := "" ;
+ feldseparator ("") ;
+ editget (line) ;
+ echoe last char
+
+ENDPROC getline ;
+
+PROC get secret line (TEXT VAR line) :
+
+ TEXT VAR char ;
+ line := "" ;
+ 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 line CAT char ;
+ out (".")
+ ELSE out (bell)
+ FI
+ PER .
+
+delete last char :
+ IF LENGTH line = 0
+ THEN out (bell)
+ ELSE out (back blank back) ;
+ delete char (line, LENGTH line)
+ FI .
+
+get line little secret :
+ feldseparator ("") ;
+ cursor to start position ;
+ editget (line) .
+
+get start cursor position :
+ INT VAR x, y;
+ get cursor (x, y) .
+
+cursor to start position :
+ cursor (x, y) .
+
+ENDPROC get secret line ;
+
+ENDPACKET input ;
diff --git a/system/base/unknown/src/STDPLOT.ELA b/system/base/unknown/src/STDPLOT.ELA
new file mode 100644
index 0000000..be55e33
--- /dev/null
+++ b/system/base/unknown/src/STDPLOT.ELA
@@ -0,0 +1,365 @@
+PACKET std plot DEFINES (* J. Liedtke 06.02.81 *)
+ (* H.Indenbirken, 19.08.82 *)
+ transform,
+ set values,
+
+ clear ,
+ begin plot ,
+ end plot ,
+ dir move,
+ dir draw ,
+ pen,
+ pen info :
+
+LET pen down = "*"8"" ,
+ y raster = 43,
+ display hor = 78.0,
+ display vert = 43.0;
+
+INT CONST up := 1 ,
+ right := 1 ,
+ down := -1 ,
+ left := -1 ;
+
+REAL VAR h min limit :: 0.0, h max limit :: display hor,
+ v min limit :: 0.0, v max limit :: display vert,
+ h :: display hor/2.0, v :: display vert/2.0,
+ size hor :: 23.5, size vert :: 15.5;
+
+ROW 5 ROW 5 REAL VAR p :: ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (1.0, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 1.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0));
+ROW 5 ROW 5 REAL VAR result;
+INT VAR i, j;
+
+ROW 5 ROW 5 REAL OP * (ROW 5 ROW 5 REAL CONST l, r) :
+ ROW 5 ROW 5 REAL VAR erg;
+ FOR i FROM 1 UPTO 5
+ REP FOR j FROM 1 UPTO 5
+ REP erg [i] [j] := zeile i mal spalte j
+ PER
+ PER;
+ erg .
+
+zeile i mal spalte j :
+ INT VAR k;
+ REAL VAR summe :: 0.0;
+ FOR k FROM 1 UPTO 5
+ REP summe INCR zeile i * spalte j PER;
+ summe .
+
+zeile i : l [i] [k] .
+
+spalte j : r [k] [j] .
+
+END OP *;
+
+PROC set values (ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 3 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ norm p;
+ set views;
+ calc two dim extrema;
+ calc limits;
+ calc result values .
+
+norm p :
+ p := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (1.0/dx, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 1.0/dy, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 1.0/dz, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : (size [1][1]/dx, size [2][1]/dy,
+ size [3][1]/dz, 0.0, 1.0)) .
+
+dx : size [1][2] - size [1][1] .
+dy : size [2][2] - size [2][1] .
+dz : size [3][2] - size [3][1] .
+
+set views :
+ REAL VAR sin a := sind (angles [1]), cos a := cosd (angles [1]),
+ sin p := sind (angles [2]), cos p := cosd (angles [2]),
+ sin t := sind (angles [3]), cos t := cosd (angles [3]),
+ norm a :: oblique [1] * p [1][1],
+ norm b :: oblique [2] * p [2][2],
+ norm cx :: perspective [1] * p [1][1],
+ norm cy :: perspective [2] * p [2][2],
+ norm cz :: perspective [3] * p [3][3];
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (cos p*cos t, -sin p, cos p*sin t, 0.0, 0.0),
+ ROW 5 REAL : (sin p*cos t, cos p, sin p*sin t, 0.0, 0.0),
+ ROW 5 REAL : ( -sin t, 0.0, cos t, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p*result;
+
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( 1.0, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 1.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( norm a, norm b, 0.0, norm cz, 0.0),
+ ROW 5 REAL : (-norm cx, -norm cy, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p * result;
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (cos a,-sin a, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (sin a, cos a, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p * result .
+
+calc two dim extrema :
+ REAL VAR max x :: - max real, min x :: max real,
+ max y :: - max real, min y :: max real, x, y;
+
+ transform (size [1][1], size [2][1], size [3][1], x, y);
+ extrema;
+ transform (size [1][2], size [2][1], size [3][1], x, y);
+ extrema;
+ transform (size [1][2], size [2][2], size [3][1], x, y);
+ extrema;
+ transform (size [1][1], size [2][2], size [3][1], x, y);
+ extrema;
+ transform (size [1][1], size [2][1], size [3][2], x, y);
+ extrema;
+ transform (size [1][2], size [2][1], size [3][2], x, y);
+ extrema;
+ transform (size [1][2], size [2][2], size [3][2], x, y);
+ extrema;
+ transform (size [1][1], size [2][2], size [3][2], x, y);
+ extrema .
+
+extrema :
+ min x := min (min x, x);
+ max x := max (max x, x);
+
+ min y := min (min y, y);
+ max y := max (max y, y) .
+
+calc limits :
+ IF all limits smaller than 2
+ THEN prozente
+ ELSE zentimeter FI .
+
+all limits smaller than 2 :
+ limits [1][2] < 2.0 AND limits [2][2] < 2.0 .
+
+prozente :
+ h min limit := limits [1][1] * display hor * (size vert/size hor);
+ h max limit := limits [1][2] * display hor * (size vert/size hor);
+
+ v min limit := limits [2][1] * display vert;
+ v max limit := limits [2][2] * display vert .
+
+zentimeter :
+ h min limit := display hor * (limits [1][1]/size hor);
+ h max limit := display hor * (limits [1][2]/size hor);
+
+ v min limit := display vert * (limits [2][1]/size vert);
+ v max limit := display vert * (limits [2][2]/size vert) .
+
+calc result values :
+ REAL VAR sh := (h max limit - h min limit) / (max x - min x),
+ sv := (v max limit - v min limit) / (max y - min y),
+ dh := h min limit - min x*sh,
+ dv := v min limit - min y*sv;
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( sh, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, sv, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( dh, dv, 0.0, 0.0, 1.0));
+ p := p * result .
+
+END PROC set values;
+
+PROC transform (REAL CONST x, y, z, REAL VAR h, v) :
+ REAL CONST w :: 1.0/(x*p [1][4] + y*p [2][4] + z*p [3][4] + p [4][4]);
+
+ h := (x*p [1][1]+y*p [2][1]+z*p [3][1]+p [4][1])*w + p [5][1];
+ v := (x*p [1][2]+y*p [2][2]+z*p [3][2]+p [4][2])*w + p [5][2];
+END PROC transform;
+
+(************************** Eigentliches plot *************************)
+INT VAR x pos := 0 ,
+ y pos := 0 ,
+ new x pos ,
+ new y pos ;
+
+ROW 24 TEXT VAR display;
+clear ;
+
+PROC clear :
+
+ INT VAR i;
+ display (1) := 79 * " " ;
+ FOR i FROM 2 UPTO 24
+ REP display [i] := display [1]
+ PER;
+ out (""6""2""0""4"")
+
+END PROC clear ;
+
+PROC begin plot :
+
+ cursor (x pos + 1, 24 - (y pos) DIV 2 )
+
+ENDPROC begin plot ;
+
+PROC end plot :
+
+ENDPROC end plot ;
+
+PROC dir move (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ move (round (h), round (v))
+
+END PROC dir move;
+
+PROC move (INT CONST x val, y val) :
+
+ x pos := x val;
+ y pos := y val
+
+ENDPROC move ;
+
+PROC dir draw (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ draw (round (h), round (v))
+
+END PROC dir draw;
+
+PROC draw (INT CONST x val, y val) :
+
+ new x pos := x val;
+ new y pos := y val;
+
+ plot vector (new x pos - x pos, new y pos - y pos) ;
+
+END PROC draw ;
+
+PROC dir draw (TEXT CONST text, REAL CONST angle, height) :
+ out (""6"");
+ out (code (23 - (y pos DIV 2)));
+ out (code (x pos));
+
+ out (text)
+
+END PROC dir draw;
+
+INT VAR act no :: 1, act thickness :: 1, act line type :: 1;
+
+PROC pen (INT CONST no, thickness, line type) :
+ act no := no;
+ act thickness := thickness;
+ act line type := line type
+
+ENDPROC pen ;
+
+PROC pen info (INT VAR no, thickness, line type) :
+ no := act no;
+ thickness := act thickness;
+ line type := act line type
+
+END PROC pen info;
+
+PROC plot vector (INT CONST dx , dy) :
+
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (y pos, x pos, dy, dx, up, right)
+ ELIF dy > 0 THEN vector (x pos, y pos, dx, dy, right, up)
+
+ ELIF dy > -dx THEN vector (x pos, y pos, dx, -dy, right, down)
+ ELSE vector (y pos, x pos, -dy, dx, down, right)
+ FI
+ ELSE IF dy > -dx THEN vector (y pos, x pos, dy, -dx, up, left)
+ ELIF dy > 0 THEN vector (x pos, y pos, -dx, dy, left, up)
+
+ ELIF dy > dx THEN vector (x pos, y pos, -dx, -dy, left, down)
+ ELSE vector (y pos, x pos, -dy, -dx, down, left)
+ FI
+ FI .
+
+ENDPROC plot vector ;
+
+PROC vector (INT VAR x pos, y pos; INT CONST dx, dy, right, up) :
+
+ prepare first step ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO dx REP
+ do one step
+ PER .
+
+prepare first step :
+ point;
+ INT VAR old error := 0 ,
+ up right error := dy - dx ,
+ right error := dy .
+
+do one step :
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ point ;
+ old error INCR right error .
+
+ENDPROC vector ;
+
+
+PROC point :
+ INT CONST line :: y pos DIV 2;
+ BOOL CONST above :: (y pos MOD 2) = 1;
+ TEXT CONST point :: display [line+1] SUB (x pos+1),
+ new point :: calculated point;
+
+ replace (display [line+1], x pos+1, new point);
+ out (""6"") ;
+ out (code (23-line)) ;
+ out (code (x pos)) ;
+ out (new point) .
+
+calculated point :
+ IF above
+ THEN IF point = "," OR point = "|"
+ THEN "|"
+ ELSE "'" FI
+ ELSE IF point = "'" OR point = "|"
+ THEN "|"
+ ELSE "," FI
+ FI
+
+END PROC point;
+
+REAL CONST real max int := real (max int);
+INT PROC round (REAL CONST x) :
+ IF x > real max int
+ THEN max int
+ ELIF x < 0.0
+ THEN 0
+ ELSE int (x + 0.5) FI
+
+END PROC round;
+
+ENDPACKET std plot ;
diff --git a/system/base/unknown/src/bildeditor b/system/base/unknown/src/bildeditor
new file mode 100644
index 0000000..c84a300
--- /dev/null
+++ b/system/base/unknown/src/bildeditor
@@ -0,0 +1,722 @@
+
+PACKET b i l d e d i t o r DEFINES (* Autor: P.Heyderhoff *)
+ (*****************) (* Stand: 06.02.82 *)
+ (* Vers.: 1.6.0 *)
+ bildeditor, (* test des bildeditors, *)
+ schreiberlaubnis,
+ zeile unveraendert,
+ feldanfangsmarke,
+ bildmarksatz,
+ bildeinfuegen,
+ bildneu,
+ bildzeile,
+ bildmarke,
+ bildstelle,
+ bildlaenge,
+ bildmaxlaenge,
+ bildsatz,
+ bildrand :
+
+
+LET anker = 2, freianker = 1, satzmax = 4075,
+ DATEI = ROW satzmax STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt);
+
+INT VAR stelle :: anker, marke :: 0, satz :: 1, zeile :: 1,
+ zeilen :: 0, maxlaenge :: 23, laenge :: maxlaenge, rand :: 0,
+ marksatz :: 0, alte feldstelle :: 1, alte feldmarke :: 0;
+
+TEXT VAR kommando :: "", teil :: "", zeichen :: "";
+
+BOOL VAR neu :: TRUE, zeileneu :: TRUE, ueberschriftneu :: FALSE,
+ einfuegen :: FALSE, schreiben erlaubt :: TRUE;
+
+LET hop mark rubout up down cr = ""1""16""12""3""10""13"",
+ hop cr mark down up right rubin = ""1""13""16""10""3""2""11"",
+ hop rubin rubout down up cr tab esc = ""1""11""12""10""3""13""9""27"",
+ blank = " ", hop = ""1"", clear eop = ""4"", clear eol = ""5"",
+ left = ""8"", right = ""2"", up = ""3"", down = ""10"", bell = ""7"",
+ tab = ""9"", cr = ""13"", escape = ""27"", begin mark = ""15"",
+ end mark = ""14"", hoechstes steuerzeichen = ""31"", escape q = ""27"q",
+ rubin = ""11"", mark = ""16"", down clear eol = ""10""5"";
+
+(****************** z u g r i f f s p r o z e d u r e n ******************)
+
+BOOL PROC schreiberlaubnis :
+ schreiben erlaubt
+END PROC schreiberlaubnis;
+
+PROC schreiberlaubnis (BOOL CONST b) :
+ schreiben erlaubt := b
+END PROC schreiberlaubnis;
+
+BOOL PROC bildneu :
+ neu
+END PROC bildneu;
+
+PROC bildneu (BOOL CONST b) :
+ neu := b
+END PROC bildneu;
+
+PROC bildeinfuegen (BOOL CONST b):
+ einfuegen := b
+END PROC bildeinfuegen;
+
+INT PROC bildmarke :
+ marke
+END PROC bildmarke;
+
+PROC bildmarke (INT CONST i) :
+ marke := i
+END PROC bildmarke;
+
+INT PROC feldanfangsmarke :
+ alte feldmarke
+END PROC feldanfangsmarke;
+
+PROC feldanfangsmarke (INT CONST i) :
+ alte feldmarke := i
+END PROC feldanfangsmarke;
+
+INT PROC bildstelle :
+ stelle
+END PROC bildstelle;
+
+PROC bildstelle (INT CONST i) :
+ stelle := i
+END PROC bildstelle;
+
+INT PROC bildmarksatz :
+ marksatz
+END PROC bildmarksatz;
+
+PROC bildmarksatz (INT CONST i) :
+ marksatz := i
+END PROC bildmarksatz;
+
+INT PROC bildsatz :
+ satz
+END PROC bildsatz;
+
+PROC bildsatz (INT CONST i) :
+ satz := i
+END PROC bildsatz;
+
+INT PROC bildzeile :
+ zeile
+END PROC bildzeile;
+
+PROC bildzeile (INT CONST i) :
+ zeile := min (i, laenge)
+END PROC bildzeile;
+
+INT PROC bildlaenge :
+ laenge
+END PROC bildlaenge;
+
+PROC bildlaenge (INT CONST i) :
+ laenge := i
+END PROC bildlaenge;
+
+PROC bildmaxlaenge (INT CONST i) :
+ maxlaenge := i
+END PROC bildmaxlaenge;
+
+INT PROC bildrand :
+ rand
+END PROC bildrand;
+
+PROC bildrand (INT CONST i) :
+ rand := i
+END PROC bildrand;
+
+INT PROC max (INT CONST a, b) :
+ IF a > b THEN a ELSE b FI
+END PROC max;
+
+PROC zeile unveraendert :
+ zeileneu := FALSE
+END PROC zeile unveraendert;
+
+
+(************************** b i l d e d i t o r **************************)
+
+PROC bildeditor (DATEI VAR datei) :
+
+ INTERNAL 293 ;
+
+ INT VAR j;
+
+ kommando := feldkommando;
+ IF neu
+ THEN bild ausgeben (datei)
+ ELIF zeileneu
+ THEN satz ausgeben (datei); ueberschriftneu := TRUE
+ ELSE feldposition; zeileneu := TRUE
+ FI;
+ REPEAT
+ IF neu THEN bild ausgeben (datei)
+ ELIF ueberschriftneu THEN ueberschrift (datei)
+ FI ;
+ IF stelle = anker
+ THEN IF schreiben erlaubt
+ THEN satz erzeugen (datei, stelle); (* gestrichen z:=z *)
+ satz ausgeben (datei)
+ ELSE feldkommando (escape q); out(bell); LEAVE bildeditor
+ FI
+ FI ;
+ feldbearbeitung;
+ IF zeichen <> escape THEN kommandoausfuehrung FI
+ UNTIL zeichen = escape
+ END REPEAT;
+ feldkommando (kommando) .
+
+feldbearbeitung :
+ feldkommando (kommando);
+ IF schreiben erlaubt
+ THEN feldeditor (inhalt); kommando := feldkommando
+ ELSE teil := inhalt; feldeditor (teil);
+ IF teil <> inhalt
+ THEN kommando := escape q; kommando CAT teil
+ ELSE kommando := feldkommando
+ FI
+ FI;
+ zeichen := kommando SUB 1;
+ feldnachbehandlung .
+
+
+feldnachbehandlung :
+ IF inhalt = ""
+ THEN IF schreiben erlaubt
+ THEN IF zeichen > hoechstes steuerzeichen
+ THEN inhalt := subtext (kommando, 1, feldlimit);
+ kommando := subtext (kommando, feldlimit+1);
+ feldout (inhalt); zeichen := cr
+ FI FI FI .
+
+kommandoausfuehrung :
+ delete char (kommando, 1);
+ IF marke > 0
+ THEN bildmarkeditor (datei)
+ ELSE
+ SELECT pos (hop cr mark down up right rubin, zeichen) OF
+ CASE 1:
+ zeichen := kommando SUB 1; delete char (kommando, 1);
+ SELECT pos (hop rubin rubout down up cr tab esc, zeichen) OF
+ CASE 1: oben links
+ CASE 2: IF schreiben erlaubt
+ THEN zeilen einfuegen ELSE out (bell) FI
+ CASE 3: IF schreiben erlaubt
+ THEN zeile ausfuegen ELSE out (bell) FI
+ CASE 4: weiterblaettern
+ CASE 5: zurueckblaettern
+ CASE 6: neue seite
+ CASE 7: ueberschriftneu := TRUE
+ CASE 8: lernmodus umschalten
+ OTHERWISE zeichen := ""; out (bell)
+ END SELECT
+ CASE 2: neue zeile
+ CASE 3: markieren beginnen
+ CASE 4: naechster satz
+ CASE 5: vorgaenger (datei)
+ CASE 6: feldposition (feldanfang); naechster satz
+ CASE 7: ueberschriftneu := TRUE;
+ OTHERWISE
+ IF zeichen > hoechstes steuerzeichen
+ THEN IF schreiben erlaubt THEN ueberlauf FI
+ ELSE insert char (kommando, zeichen, 1);
+ insert char (kommando, escape, 1)
+ FI
+ END SELECT
+ FI .
+
+oben links :
+ ueberschriftneu := TRUE;
+ WHILE zeile > 1 REP vorgaenger (datei) PER;
+ feldposition (feldanfang) .
+
+zeile ausfuegen :
+ IF feldstelle = 1
+ THEN satz loeschen (datei);
+ IF stelle = anker THEN vorgaenger (datei) FI
+ ELSE zeilen rekombinieren
+ FI .
+
+zeilen einfuegen :
+ ueberschriftneu := TRUE;
+ IF einfuegen
+ THEN einfuegen := FALSE;
+ IF inhalt = "" THEN satz loeschen (datei) FI;
+ IF zeilen < laenge THEN bild ausgeben (datei) FI
+ ELSE einfuegen := TRUE;
+ IF logischer satzanfang
+ THEN satz erzeugen (datei, stelle);
+ IF zeilen >= zeile THEN bildrest loeschen FI;
+ zeilen := zeile; satz ausgeben (datei)
+ ELSE IF feldstelle <= LENGTH inhalt
+ THEN zeile auftrennen
+ FI;
+ IF zeile < zeilen
+ THEN nachfolger (datei); bildrest loeschen;
+ vorgaenger (datei); zeilen := zeile
+ FI ; feldposition
+ FI
+ FI .
+
+logischer satzanfang :
+ FOR j FROM feldanfang UPTO feldstelle - 1
+ REP IF (inhalt SUB j) = ""
+ THEN LEAVE logischer satzanfang WITH TRUE
+ ELIF (inhalt SUB j) <> " "
+ THEN LEAVE logischer satzanfang WITH FALSE
+ FI
+ END REP; TRUE .
+
+zeilen rekombinieren :
+ IF eof (datei) THEN
+ ELSE inhalt CAT (feldstelle-1-LENGTH inhalt) * " ";
+ inhalt CAT datei (datei (stelle).nachfolger).inhalt;
+ stelle := datei (stelle).nachfolger;
+ satz loeschen (datei, stelle);
+ stelle := datei (stelle).vorgaenger;
+ bildausgeben (datei)
+ FI .
+
+zeile auftrennen :
+ marke := stelle; (feldende-feldstelle+1) TIMESOUT " ";
+ stelle := datei (stelle).nachfolger;
+ satz erzeugen (datei, stelle);
+ inhalt := subtext (datei (datei (stelle).vorgaenger).inhalt, feldstelle);
+ stelle := marke; marke := 0;
+ inhalt := subtext (inhalt, 1, feldstelle-1) .
+
+weiterblaettern :
+ ueberschriftneu := TRUE;
+ IF eof (datei)
+ THEN out (bell)
+ ELSE IF zeile = laenge
+ THEN nachfolger (datei); zeile := 1; bild ausgeben (datei)
+ ELIF einfuegen
+ THEN IF zeile = zeilen THEN bild ausgeben (datei) FI
+ FI;
+ WHILE zeile < zeilen AND stelle <> anker
+ REP nachfolger (datei) END REP;
+ IF stelle = anker
+ THEN vorgaenger (datei)
+ FI FI .
+
+zurueckblaettern :
+ ueberschriftneu := TRUE;
+ IF satz > 1
+ THEN IF zeile = 1
+ THEN vorgaenger (datei); zeile := laenge
+ FI;
+ WHILE zeile > 1 AND satz > 1
+ REP vorgaenger (datei) PER;
+ zeile := 1
+ FI .
+
+ueberlauf :
+ insert char (kommando, zeichen, 1);
+ feldposition (feldanfang); feld einruecken (inhalt); nachfolger (datei);
+ satz erzeugen (datei, stelle);
+ inhalt := ""0"" ; (* 12.01.81 *)
+ IF zeile <= zeilen OR neu
+ THEN bild ausgeben (datei) ELSE satz ausgeben (datei)
+ FI ;
+ inhalt := "" .
+
+lernmodus umschalten :
+ feldlernmodus (NOT feldlernmodus);
+ ueberschriftneu := TRUE;
+ IF feldlernmodus
+ THEN feldaudit (""); zeichen := ""
+ ELSE insert char (kommando, escape, 1);
+ insert char (kommando, hop, 1)
+ FI.
+
+neue seite :
+ feldstelle (feldanfang); zeile := 1; neu := TRUE .
+
+neue zeile :
+ BOOL VAR wirklich einfuegen := einfuegen;
+ IF feldstelle > LENGTH inhalt OR feldstelle >= feldende
+ THEN feldposition (feldanfang); feld einruecken (inhalt); nachfolger(datei)
+ ELIF einfuegen AND logischer satzanfang
+ THEN feldposition (feldanfang); feldeinruecken (inhalt)
+ ELSE feldposition (feldanfang); nachfolger (datei);
+ wirklich einfuegen := FALSE
+ FI;
+ IF stelle = anker THEN
+ ELIF wirklich einfuegen
+ THEN satz erzeugen (datei, stelle);
+ IF zeile <= zeilen OR neu
+ THEN bild ausgeben (datei)
+ ELSE satz ausgeben (datei)
+ FI
+ ELIF neu THEN
+ ELSE IF zeile > zeilen
+ THEN satz ausgeben (datei)
+ FI;
+ FOR j FROM feldanfang UPTO min (feldstelle, LENGTH inhalt)
+ REP IF (inhalt SUB j) <> blank
+ THEN feldposition (j); LEAVE neue zeile FI
+ PER
+ FI .
+
+naechster satz :
+ nachfolger (datei);
+ IF neu
+ THEN IF stelle = anker
+ THEN IF datei (datei (stelle).vorgaenger).inhalt = ""
+ THEN stelle := datei (stelle).vorgaenger; satz DECR 1;
+ neu := FALSE
+ FI FI
+ ELIF zeile <= zeilen THEN
+ ELIF stelle = anker THEN
+ ELSE satz ausgeben (datei)
+ FI .
+
+markieren beginnen :
+ IF feldstelle <= min (LENGTH inhalt, feldende)
+ THEN feldmarke (feldstelle); marke := stelle;
+ marksatz := satz; satz ausgeben (datei);
+ alte feldmarke := feldmarke
+ ELSE out (bell)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC bildeditor;
+
+
+(******************** b i l d - m a r k e d i t o r **********************)
+
+PROC bildmarkeditor (DATEI VAR datei) :
+ INT VAR j, k;
+
+ IF zeichen = right OR zeichen = tab
+ THEN zeichen := down;
+ feldposition (feldanfang)
+ FI;
+ SELECT pos (hop mark rubout up down cr, zeichen) OF
+ CASE 1: zeichen := kommando SUB 1; delete char (kommando, 1);
+ IF zeichen = up
+ THEN rueckblaetternd demarkieren
+ ELIF zeichen = down
+ THEN weiterblaetternd markieren
+ ELSE out (bell)
+ FI;
+ zeichen := ""
+ CASE 2: markieren beenden
+ CASE 3: IF schreiben erlaubt
+ THEN markiertes loeschen
+ ELSE out (bell)
+ FI
+ CASE 4: zeile demarkieren
+ CASE 5,6: zeile markieren
+ OTHERWISE insert char (kommando, zeichen, 1);
+ insert char (kommando, escape, 1)
+ END SELECT;
+ IF marke > 0
+ THEN IF stelle = marke
+ THEN feldmarke (alte feldmarke)
+ ELSE feldmarke (feldanfang)
+ FI
+ FI .
+
+markieren beenden :
+ feldmarke (0); alte feldmarke := 0;
+ IF marke = stelle
+ THEN satz ausgeben (datei); ueberschriftneu := TRUE;
+ marke := 0;
+ ELSE marke := 0; neu := TRUE
+ FI .
+
+markiertes loeschen :
+ IF stelle = marke
+ THEN satzausschnitt loeschen
+ ELSE letzten satz bis stelle loeschen;
+ ersten satz ab marke loeschen;
+ alle zwischensaetze loeschen;
+ IF zeile <= 1
+ THEN zeile := 1
+ FI;
+ feldstelle (feldanfang); feldmarke (0);
+ alte feldmarke := 0; marke := 0; neu := TRUE
+ FI .
+
+satzausschnitt loeschen :
+ inhalt := subtext (inhalt, 1, feldmarke-1) + subtext (inhalt, feldstelle);
+ feldstelle (feldmarke); feldmarke (0); marke := 0;
+ IF inhalt = ""
+ THEN satz loeschen (datei)
+ ELSE satz ausgeben (datei)
+ FI .
+
+letzten satz bis stelle loeschen :
+ IF feldstelle > LENGTH inhalt
+ THEN satz loeschen (datei, stelle)
+ ELIF feldstelle > feldanfang
+ THEN inhalt := subtext (inhalt, feldstelle)
+ FI .
+
+ersten satz ab marke loeschen :
+ INT CONST altstelle := stelle;
+ stelle := marke;
+ IF alte feldmarke = 1
+ THEN satz loeschen (datei, stelle);
+ satz DECR 1; zeile DECR 1
+ ELSE IF alte feldmarke <= LENGTH inhalt
+ THEN inhalt := text (inhalt, alte feldmarke-1)
+ FI;
+ stelle := datei (stelle).nachfolger
+ FI .
+
+alle zwischensaetze loeschen :
+ WHILE stelle <> altstelle
+ REP satzloeschen (datei, stelle);
+ satz DECR 1; zeile DECR 1
+ PER .
+
+zeile markieren :
+ IF zeichen = cr
+ THEN feldstelle (feldanfang)
+ FI;
+ IF eof (datei)
+ THEN feldstelle (feldende)
+ ELSE nachfolger (datei)
+ FI;
+ markierung justieren (datei);
+ satz ausgeben (datei) .
+
+zeile demarkieren :
+ IF stelle = marke
+ THEN out (bell); LEAVE zeile demarkieren
+ FI;
+ feldmarke (0); satz ausgeben (datei);
+ vorgaenger (datei);
+ markierung justieren (datei);
+ satz ausgeben (datei) .
+
+weiterblaetternd markieren :
+ IF zeile >= laenge THEN zeile := 0 FI; out (hop);
+ WHILE NOT eof (datei)
+ REP nachfolger (datei) UNTIL zeile = laenge PER;
+ IF eof (datei)
+ THEN feldstelle (feldende);
+ FI;
+ neu := TRUE .
+
+rueckblaetternd demarkieren :
+ IF stelle = marke
+ THEN out (bell); LEAVE rueckblaetternd demarkieren
+ FI;
+ FOR j FROM 1 UPTO laenge
+ WHILE stelle <> marke
+ REP vorgaenger (datei) PER;
+ neu := TRUE .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC bildmarkeditor;
+
+PROC markierung justieren (DATEI CONST datei) :
+ IF feldstelle > LENGTH inhalt
+ THEN feldstelle (min (feldende, LENGTH inhalt) + 1)
+ FI;
+ IF stelle = marke
+ THEN feldmarke (alte feldmarke);
+ IF feldstelle < feldmarke
+ THEN feldstelle (feldmarke)
+ FI
+ ELSE feldmarke (feldanfang)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC markierung justieren;
+
+PROC vorgaenger (DATEI VAR datei) :
+ IF eof (datei)
+ THEN IF inhalt = "" THEN satz loeschen (datei)
+ FI FI ;
+ stelle := datei (stelle).vorgaenger; satz DECR 1;
+ IF stelle = anker
+ THEN out (bell); stelle := datei (anker).nachfolger;
+ satz := 1; zeile := 1
+ ELIF zeile > 1
+ THEN out (up); zeile DECR 1
+ ELSE neu := TRUE
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC vorgaenger;
+
+PROC nachfolger (DATEI CONST datei) :
+ stelle := datei (stelle).nachfolger; satz INCR 1; zeile INCR 1;
+ IF zeile <= laenge
+ THEN out (down)
+ ELIF laenge <> maxlaenge
+ THEN neu := TRUE ; zeile := laenge
+ FI
+END PROC nachfolger;
+
+PROC bild ausgeben (DATEI VAR datei) :
+
+ IF marke > 0 THEN markierung justieren (datei) FI;
+ alte feldstelle := feldstelle; feldstelle (feldende+1);
+ INT VAR altstelle :: stelle, altsatz :: satz,
+ altzeile :: zeile, altmarke :: feldmarke;
+ ueberschrift (datei);
+ IF marke > 0 OR neu
+ THEN zurueck zur ersten zeile;
+ cursor (1, rand+2) FI;
+ IF (rand+laenge) = maxlaenge THEN out (clear eop) FI;
+ WHILE zeile <= laenge AND stelle <> anker
+ REP zeile schreiben PER;
+ feldstelle (alte feldstelle);
+ feldmarke (altmarke);
+ zeilen := zeile - 1;
+ IF zeile > laenge
+ THEN zeile := laenge; feldposition
+ ELSE bildrest loeschen
+ FI;
+ (zeile - altzeile) TIMESOUT up;
+ zeile := altzeile; satz := altsatz; stelle := altstelle;
+ neu := FALSE .
+
+zurueck zur ersten zeile :
+ IF eof (datei)
+ THEN WHILE inhalt = "" AND datei(stelle).vorgaenger <> anker
+ REP vorgaenger (datei) END REP;
+ altstelle := stelle; altsatz := satz; altzeile := zeile;
+ FI;
+ WHILE zeile > 1 AND datei (stelle).vorgaenger <> anker
+ REP IF stelle = marke
+ THEN feldmarke (0)
+ FI;
+ vorgaenger (datei)
+ PER;
+ altzeile DECR (zeile-1); zeile := 1 .
+
+inhalt :
+ datei (stelle).inhalt .
+
+zeile schreiben :
+ IF stelle = marke THEN feldmarke (alte feldmarke) FI;
+ IF stelle = altstelle THEN feldstelle (alte feldstelle) FI;
+ feldout (inhalt);
+ IF stelle = altstelle
+ THEN feldmarke (0)
+ ELIF feldmarke > feldanfang
+ THEN feldmarke (feldanfang)
+ FI;
+ zeile INCR 1;
+ IF zeile <= laenge
+ THEN stelle := datei (stelle).nachfolger;
+ satz INCR 1; out (down)
+ FI .
+
+END PROC bild ausgeben;
+
+PROC ueberschrift (DATEI CONST datei) :
+ cursor (feldrand+1, rand+1); out(begin mark);
+ INT CONST punkte ::
+ (feldende-feldanfang-13-length(datei(anker).inhalt)) DIV 2;
+ punkte TIMESOUT "."; out (" ", datei(anker).inhalt, " .");
+ cursor (feldrand+3, rand+1);
+ IF feldeinfuegen
+ THEN out ("RUBIN"2""2"")
+ ELSE out (""2""2""2""2""2""2""2"") FI;
+ IF einfuegen
+ THEN out ("INS")
+ ELSE out (""2""2""2"") FI;
+ IF feldlernmodus THEN out ("..LEARN.") FI;
+ cursor (feldrand+feldende-feldanfang-9-punkte, rand+1);
+ punkte TIMESOUT ".";
+ out (" zeile ", end mark, " ");
+ cursor (feldrand+feldende-feldanfang-2, rand+1) ;
+ IF satz <= zeile THEN out("1")
+ ELSE out (text (satz-zeile+1)) FI;
+ cursor (feldrand+2, rand+1);
+ feldtab (tabulator);
+ outsubtext (tabulator, feldanfang+1, min (feldende, LENGTH tabulator));
+ cursor (1, rand+zeile+1); feldposition;
+ ueberschriftneu := FALSE
+
+END PROC ueberschrift;
+
+TEXT VAR tabulator;
+
+PROC satz ausgeben (DATEI VAR datei) :
+ IF zeile > laenge
+ THEN roll up
+ ELIF zeile > zeilen
+ THEN zeilen INCR 1
+ FI;
+ feldout (datei (stelle).inhalt); feldposition .
+roll up :
+ out (down); cursor (1, rand + zeile); zeile DECR 1 .
+END PROC satz ausgeben;
+
+PROC satz loeschen (DATEI VAR datei) :
+ satz loeschen (datei, stelle); zeilen DECR 1;
+ IF zeile > zeilen
+ THEN bildrest loeschen;
+ IF stelle <> anker THEN satz ausgeben (datei) FI
+ ELSE bild ausgeben (datei)
+ FI
+END PROC satz loeschen;
+
+PROC bildrest loeschen :
+ out (cr); feldrand TIMESOUT right;
+ IF (rand+laenge) = maxlaenge
+ THEN out (clear eop)
+ ELSE out (up);
+ (laenge-zeile+1) TIMESOUT (down clear eol);
+ (laenge-zeile) TIMESOUT up
+ FI;
+ feldposition
+END PROC bildrest loeschen;
+
+BOOL PROC eof (DATEI CONST datei) :
+ datei (stelle).nachfolger = anker
+END PROC eof;
+
+(*************************** schrott *************************************)
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291 ;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+(************************** testprogramm ***********************************)
+(*
+PROC test des bildeditors :
+
+ IF NOT exists ("test")
+ THEN FILE VAR file 1 := sequential file (modify, "test"); close (file 1)
+ FI ;
+ DATASPACE VAR ds := old ("test");
+ BOUND DATEI VAR datei := ds ;
+ feldwortweise (NOT feldwortweise);
+ bildneu (TRUE); bildmarke (0);
+ bildstelle (CONCR(datei) (anker).nachfolger); bildsatz (1);
+ feldmarke (0); feldseparator (""); feldstelle (1) ;
+ REP b i l d e d i t o r (CONCR (datei));
+ out (""7""); feldkommando ("")
+ UNTIL (feldkommando SUB 1) = ""27""
+ PER;
+
+END PROC test des bildeditors;
+*)
+END PACKET bildeditor;
diff --git a/system/base/unknown/src/command handler b/system/base/unknown/src/command handler
new file mode 100644
index 0000000..3e06280
--- /dev/null
+++ b/system/base/unknown/src/command handler
@@ -0,0 +1,239 @@
+
+PACKET command handler DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 29.02.82 *)
+ command handler ,
+ do command ,
+ command error ,
+ set command :
+
+
+LET esc = ""27"" ,
+ esc k = ""27"k" ,
+ cr lf = ""4""13""10"" ,
+ command pre = ""4""13" " ,
+ command post = ""13""10" " ,
+
+ tag type = 1 ,
+ texttype = 4 ,
+ eof type = 7 ;
+
+
+TEXT VAR command line := "" ,
+ previous command line := "" ,
+ symbol ,
+ procedure ,
+ pattern ,
+ error note := "" ;
+
+INT VAR symbol type ,
+ allowed type := 0 ;
+
+
+PROC set command (TEXT CONST command, INT CONST type) :
+
+ param position (0) ;
+ command line := command ;
+ allowed type := type
+
+ENDPROC set command ;
+
+PROC do command :
+
+ do (command line)
+
+ENDPROC do command ;
+
+
+PROC command handler ( TEXT CONST command list,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2,
+ TEXT CONST command text ) :
+
+prepare and get command ;
+command handler (command list,command index,number of params,param1,param2).
+
+prepare and get command :
+ 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 :
+ INT VAR x, y;
+ out (crlf) ;
+ get cursor (x, y) ;
+ cursor (x, y) ;
+ 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 :
+ feldaudit ("") ;
+ feldlernmodus (FALSE) ;
+ REP
+ feldtabulator ("") ;
+ feldseparator (esc) ;
+ editget (command line) ;
+ ignore halt errors during editget ;
+ IF feldzeichen = esc k
+ THEN command line := previous command line
+ ELSE previous command line := command line ;
+ LEAVE editget command
+ FI
+ PER .
+
+ignore halt errors during editget :
+ IF is error
+ THEN clear error
+ FI .
+
+ENDPROC command handler ;
+
+PROC command handler ( TEXT CONST command list,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2) :
+
+ scan (command line) ;
+ next symbol ;
+ IF 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 :
+ IF symbol type = tag type OR symbol = "?"
+ THEN procedure := symbol ;
+ next symbol
+ ELSE error ("incorrect procedure name")
+ FI .
+
+parameter list pack option :
+ number of params := 0 ;
+ param 1 := "" ;
+ param 2 := "" ;
+ IF symbol = "("
+ THEN next symbol ;
+ parameter list ;
+ IF symbol <> ")"
+ THEN error (") expected")
+ FI
+ ELIF symbol type <> eof type
+ THEN error ("( expected")
+ FI .
+
+parameter list :
+ parameter (param 1, number of params) ;
+ IF symbol = ","
+ THEN next symbol ;
+ parameter (param 2, number of params) ;
+ FI ;
+ IF symbol <> ")"
+ THEN error (") expected")
+ FI .
+
+nothing else in command line :
+ next symbol ;
+ IF symbol <> ""
+ THEN error ("command too complex")
+ FI .
+
+decode command :
+ command index := index (command list, procedure, number of params) .
+
+impossible command :
+ command index := 0 .
+
+ENDPROC command handler ;
+
+PROC parameter (TEXT VAR param, INT VAR number of params) :
+
+ IF symbol type = text type OR symbol type = allowed type
+ THEN param := symbol ;
+ number of params INCR 1 ;
+ next symbol
+ ELSE error ("parameter is no text denoter ("" missing!)")
+ FI
+
+ENDPROC parameter ;
+
+INT PROC index (TEXT CONST list, procedure, INT CONST params) :
+
+ pattern := procedure ;
+ pattern CAT ":" ;
+ INT CONST index pos := pos (list, pattern) ;
+ 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 :
+ index pos > 0 AND (list SUB index pos - 1) <= "9" .
+
+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 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 ;
+
+iNDPACKET command handler ;
diff --git a/system/base/unknown/src/dateieditorpaket b/system/base/unknown/src/dateieditorpaket
new file mode 100644
index 0000000..8aedb2d
--- /dev/null
+++ b/system/base/unknown/src/dateieditorpaket
@@ -0,0 +1,743 @@
+
+PACKET d a t e i e d i t o r paket DEFINES (* Autor: P.Heyderhoff *)
+ (*******************) (* Stand: 19.02.82 *)
+ (* Vers.: 1.6.0 *)
+ define escape ,
+ dateieditor :
+
+LET satzmax = 4075, dateianker = 2, left = ""8"", escape = ""27"",
+ hop = ""1"", right = ""2"", hoechstes steuerzeichen = ""31"",
+ clear = ""1""4"", hop and mark = ""1""15"", code f = "f",
+ clear line mark = ""5""14"", bell = ""7"", freianker = 1, down = ""10"",
+ begin mark = ""15"", end mark = ""14"", escape escape = ""27""27"",
+ clear eol and mark = ""5""15"";
+
+LET DATEI = ROW satzmax STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt);
+FOR j FROM 1 UPTO 127 REP escapefkt (j) := "" PER;
+INT VAR j, haltzeile :: satzmax, symboltyp, typ,
+ zahlwert, stelle, satz, marke, maxbildlaenge :: 23;
+FILE VAR sekundaerfile ;
+TEXT VAR zeichen :: "", ersatz :: "", kommando :: "",
+ symbol :: "", textwert :: "", lernsequenz::"";
+BOOL VAR war fehler, boolwert;
+LET op1namen =
+";+;-;BEGIN;COL;GET;HALT;LIMIT;MARK;PUT;IF;NOT;REPEAT;WRITE;SIZE";
+LET b = 5, c = 11, g = 15, h = 19, l = 24, m = 30,
+ p = 35, i = 39, n = 42, r = 46, w = 53, s=59;
+LET op2namen = "&+&-&*&/&;&CHANGETO;&OR";
+LET plus = 1, minus = 3, mal = 5, durch = 7, semicolon = 9,
+ changecode = 11, or = 21;
+LET proznamen = ";col;row;halt;limit;mark;len;eof;";
+LET pcol = 1, prow = 5, phalt = 9, plimit = 14, pmark = 20,
+ plen = 25, peof = 29;
+LET void = 0, (* keine angabe des typs *)
+ tag = 1, (* typ: lower case letter *)
+ bold = 2, (* typ: upper case letter *)
+ integer = 3, (* typ: digit *)
+ texttyp = 4, (* typ: quote *)
+ operator = 5, (* typ: operator +-*=<> ** := *)
+ delimiter = 6, (* typ: delimiter ( ) , ; . *)
+ eol = 7, (* typ: niltext, Zeilenende *)
+ bool = 8; (* typ: boolean *)
+LET varimax = 10;
+INT VAR freivar :: 1;
+ROW varimax INT VAR varzahlwert, vartyp;
+ROW varimax TEXT VAR vartextwert, varname;
+FOR j FROM 1 UPTO varimax
+REP vartextwert (j) := ""; varname (j) := "" PER;
+
+ROW 127 TEXT VAR escapefkt;
+
+
+(************************* d a t e i e d i t o r *************************)
+
+PROC dateieditor (DATEI VAR datei) :
+
+ INTERNAL 295 ;
+
+ REP datei editieren
+ UNTIL (feldkommando SUB 1) <> escape
+ PER .
+
+datei editieren :
+ war fehler := FALSE ;
+ zeichen := feldkommando SUB 2;
+ IF zeichen = "q" OR zeichen = "w"
+ THEN LEAVE dateieditor
+ ELIF zeichen = escape
+ THEN kommando ermitteln
+ ELSE tastenkommando ermitteln ; (* Li 19.1.82 *)
+ abbruchtest;
+ feldkommando (subtext (feldkommando, 3))
+ FI;
+ a u s f u e h r e n .
+
+tastenkommando ermitteln :
+ IF zeichen > ""0"" AND zeichen < ""128""
+ THEN kommando := escapefkt (code (zeichen)) (* Li 06.01.82 *)
+ ELSE kommando := ""
+ FI .
+
+abbruchtest :
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+
+kommando ermitteln :
+ IF (feldkommando SUB 1) = hop
+ THEN lernsequenz auf taste legen;
+ feldkommando (subtext (feldkommando, 4));
+ LEAVE datei editieren
+ FI;
+ feldkommando (subtext (feldkommando, 3));
+ kommando := ""; dialog; analysieren .
+
+dialog:
+ REP kommandodialog;
+ IF (feldzeichen SUB 1) <> escape OR kommando <> "?"
+ THEN LEAVE dialog
+ ELIF (feldzeichen SUB 2) > ""0"" THEN (* Li 19.02.82 *)
+ kommando := escapefkt (code (feldzeichen SUB 2) MOD 128 )
+ ELSE kommando := ""
+ FI
+ PER .
+
+lernsequenz auf taste legen :
+ lernsequenz := feldaudit;
+ lernsequenz := subtext (lernsequenz, 1, LENGTH lernsequenz - 3);
+ INT CONST lerncode := code (feldkommando SUB 3) MOD 128 ;
+ escapefkt (lerncode) := "W""" ;
+ escapefkt (lerncode) CAT lernsequenz ; (* Li 5.1.81 *)
+ escapefkt (lerncode) CAT """" .
+
+kommandodialog :
+ INT CONST feldlaenge :: max (feldende-feldanfang-21, 6) ;
+ cursor (feldrand+1, bildrand+bildzeile+1);
+ out (begin mark, "gib editor kommando: ");
+ feldlaenge TIMESOUT "."; out(end mark);
+ bildneu (TRUE);
+ cursor (feldrand+23, bildrand+bildzeile+1); feldseparator (escape);
+ editget (kommando, 255, feldlaenge); feldseparator ("") .
+
+analysieren :
+ IF (feldzeichen SUB 1) = escape AND (feldzeichen SUB 2) > ""0"" (*02.82*)
+ THEN escapefkt (code (feldzeichen SUB 2) MOD 128) := kommando; (* Li 5.1.*)
+ LEAVE datei editieren
+ ELIF kommando = ""
+ THEN LEAVE datei editieren
+ ELIF (kommando SUB 1) = "?"
+ THEN kommandos erklaeren;
+ LEAVE datei editieren
+ ELIF pos ("quit", kommando) = 1
+ THEN feldkommando (escape escape);
+ LEAVE dateieditor
+ ELSE escapefkt (code (code f)) := kommando
+ FI .
+
+ausfuehren :
+ haltzeile := satzmax;
+ IF kommando = ""
+ THEN zeile unveraendert
+ ELSE scan (kommando); nextsymbol;
+ IF a u s d r u c k (datei)
+ THEN IF symboltyp <> eol THEN fehler bearbeiten FI
+ FI;
+ IF war fehler THEN inchar (zeichen) (* warten *) FI
+ FI .
+
+kommandos erklaeren :
+ out (clear);
+ putline ("kommandos fuer den benutzer :"); line;
+ putline ("quit : beendet das editieren");
+ putline (" n : positioniert auf zeile n");
+ putline ("+ n : blaettert n zeilen vorwaerts");
+ putline ("- n : blaettert n zeilen rueckwaerts");
+ putline (" ""z"" : sucht angegebene zeichenkette ");
+ putline ("""muster"" CHANGETO ""ersatz"" :");
+ putline (" muster wird durch ersatz ersetzt");
+ putline ("HALT n : sieht anhalten des suchens in zeile n vor");
+ putline ("GET ""d"" : kopiert datei d und markiert");
+ putline ("PUT ""d"" : schreibt markierten abschnitt in datei d");
+ putline ("LIMIT n : setzt schreibende auf spalte n");
+ putline ("BEGIN n : setzt feldanfang auf spalte n");
+ putline ("SIZE n : setzt bildlaenge auf n"); line;
+ putline ("?ESCx : zeigt kommando auf escapetaste x");
+ inchar (zeichen) .
+
+END PROC dateieditor;
+
+PROC define escape (TEXT CONST cmd char, kommando) :
+ escapefkt (code (cmd char) MOD 128) := kommando
+END PROC define escape ;
+
+
+(******************** h i l f s - p r o z e d u r e n ********************)
+
+PROC fehler bearbeiten :
+ IF NOT war fehler
+ THEN war fehler := TRUE; bildneu (TRUE);
+ out (""2""2""2" kommandofehler bei ",symbol," erkannt.");
+ out (clear line mark)
+ FI
+END PROC fehler bearbeiten;
+
+BOOL PROC fehler : fehler bearbeiten; FALSE END PROC fehler;
+
+BOOL PROC klammerzu :
+ IF symbol = ")"
+ THEN nextsymbol; TRUE
+ ELSE fehler
+ FI
+END PROC klammerzu;
+
+PROC nextsymbol :
+ nextsymbol (symbol, symboltyp);
+ IF symboltyp = eol THEN symbol := "kommandoende" FI
+END PROC nextsymbol;
+
+PROC eof (DATEI VAR datei) :
+ boolwert := (bildstelle = dateianker); typ := void
+END PROC eof;
+
+PROC nachsatz (DATEI CONST datei) :
+ stelle := datei (stelle).nachfolger;
+ satz INCR 1; protokoll
+END PROC nachsatz;
+
+PROC vorsatz (DATEI CONST datei) :
+ stelle := datei (stelle).vorgaenger;
+ satz DECR 1; protokoll
+END PROC vorsatz;
+
+
+PROC protokoll :
+ cout (satz) ;
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+END PROC protokoll;
+
+
+(******************* s p r i n g e n und s u c h e n *******************)
+
+PROC row (DATEI VAR datei) :
+ IF ziel voraus THEN vorwaerts springen ELSE rueckwaerts springen FI;
+ bildsatz (satz); bildstelle (stelle); typ := void; bildneu (TRUE) .
+
+ziel voraus :
+ satz := bildsatz; stelle := bildstelle;
+ IF zahlwert > satz
+ THEN TRUE
+ ELIF zahlwert <= satz DIV 2 AND bildmarke = 0
+ THEN stelle := datei (dateianker).nachfolger; satz := 1; TRUE
+ ELSE FALSE
+ FI .
+
+vorwaerts springen :
+ IF zahlwert <= 0
+ THEN fehler bearbeiten
+ FI ;
+ WHILE stelle <> dateianker AND satz < zahlwert
+ REP nachsatz (datei) UNTIL war fehler PER;
+ IF stelle = dateianker AND satz > 1
+ THEN vorsatz (datei);
+ feldstelle (LENGTH (datei (stelle).inhalt)+1)
+ FI .
+
+rueckwaerts springen :
+ WHILE stelle <> bildmarke AND satz > zahlwert
+ REP vorsatz (datei) UNTIL war fehler PER .
+
+END PROC row;
+
+PROC search (DATEI VAR datei) :
+ stelle := bildstelle;
+ IF textwert <> "" THEN contextadressierung FI;
+ typ := void .
+
+contextadressierung :
+ j := feldstelle - 1; satz := bildsatz;
+ WHILE noch nicht gefunden REP nachsatz (datei) UNTIL war fehler PER;
+ IF stelle = dateianker
+ THEN vorsatz (datei);
+ feldstelle (LENGTH (datei (stelle).inhalt)+1)
+ ELIF j > 0
+ THEN feldstelle ((LENGTH textwert)+j)
+ FI;
+ IF bildstelle <> stelle
+ THEN bildstelle (stelle); bildsatz (satz); bildneu (TRUE)
+ FI .
+
+noch nicht gefunden :
+ j := pos (datei (stelle).inhalt, textwert, j+1);
+ j = 0 AND stelle <> dateianker AND satz < haltzeile .
+
+END PROC search;
+
+
+(******************** vom file holen, in file bringen ********************)
+
+PROC vom file holen (DATEI VAR datei, TEXT VAR textwert) :
+ stelle := bildstelle; satz := bildsatz;
+ IF datei eroeffnung korrekt
+ THEN IF stelle = dateianker THEN satz erzeugen (datei, stelle) FI;
+ zeile auftrennen; file kopieren; kopiertes markieren;
+ bildstelle (stelle); bildsatz (satz); bildmarke (marke)
+ FI ; textwert := "" .
+
+datei eroeffnung korrekt :
+ IF textwert = ""
+ THEN sekundaerfile := sequential file (input); NOT eof (sekundaerfile)
+ ELIF exists (textwert)
+ THEN sekundaerfile := sequential file (input, textwert);
+ NOT eof (sekundaerfile)
+ ELSE FALSE
+ FI .
+
+file kopieren :
+ INT VAR altstelle;
+ FOR j FROM 0 UPTO satzmax WHILE NOT eof (sekundaerfile)
+ REP nachsatz (datei); altstelle := stelle;
+ satz erzeugen (datei, stelle);
+ IF stelle = altstelle THEN LEAVE file kopieren FI;
+ getline (sekundaerfile, inhalt)
+ UNTIL war fehler
+ PER .
+
+zeile auftrennen :
+ marke := stelle; bildmarksatz (satz);
+ nachsatz (datei); satz erzeugen (datei, stelle);
+ inhalt := subtext (datei (marke).inhalt, feldstelle);
+ vorsatz (datei); inhalt := text (inhalt, feldstelle-1) .
+
+kopiertes markieren :
+ nachsatz (datei);
+ IF inhalt = "" THEN satz loeschen (datei, stelle) FI;
+ vorsatz (datei);
+ IF datei (marke).inhalt = ""
+ THEN satz loeschen (datei, marke); satz DECR 1;
+ ELSE marke := datei (marke).nachfolger; bildmarksatz (bildmarksatz+1)
+ FI;
+ feldmarke (feldanfang); feldanfangsmarke (feldanfang);
+ feldstelle (1+LENGTH inhalt); bildneu (TRUE) .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC vom file holen;
+
+PROC in file bringen ( DATEI VAR datei, TEXT VAR textwert) :
+ neuen sekundaerfile erzeugen;
+ marke := bildstelle; stelle := bildmarke; satz := bildmarksatz;
+ IF stelle = marke
+ THEN IF feldmarke <> feldstelle
+ THEN putline (sekundaerfile,
+ subtext (inhalt, feldmarke, feldstelle-1))
+ FI
+ ELSE IF feldanfangsmarke <= LENGTH inhalt
+ THEN putline (sekundaerfile, subtext (inhalt, feldanfangsmarke))
+ FI; schreiben;
+ IF feldstelle > feldanfang
+ THEN putline (sekundaerfile, subtext (inhalt, 1, feldstelle-1))
+ FI
+ FI .
+
+schreiben:
+ REP nachsatz (datei);
+ IF stelle = marke OR war fehler THEN LEAVE schreiben FI;
+ putline (sekundaerfile, inhalt)
+ PER .
+
+neuen sekundaerfile erzeugen :
+ IF textwert = ""
+ THEN sekundaerfile := sequential file (output) ;
+ ELSE IF exists (textwert)
+ THEN forget (textwert)
+ FI;
+ IF exists (textwert)
+ THEN LEAVE in file bringen
+ FI;
+ sekundaerfile := sequential file (output, textwert)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC in file bringen;
+
+
+(************************* i n t e r p r e t e r *************************)
+
+BOOL PROC primary (DATEI VAR datei) :
+
+ SELECT symboltyp OF
+ CASE integer :
+ IF LENGTH symbol <= 4 (* Li 20.01.82 *)
+ THEN zahlwert := int (symbol);
+ typ := symboltyp;
+ nextsymbol; TRUE
+ ELSE fehler
+ FI
+ CASE texttyp :
+ textwert := symbol; typ := symboltyp; nextsymbol; TRUE
+ CASE delimiter :
+ IF symbol = "("
+ THEN nextsymbol;
+ IF ausdruck (datei) THEN klammerzu ELSE fehler FI
+ ELSE fehler
+ FI
+ CASE tag :
+ INT CONST pcode :: pos (proznamen, ";" + symbol + ";");
+ IF pcode = 0
+ THEN is variable
+ ELSE nextsymbol; prozedurieren
+ FI
+ CASE bold, operator :
+ INT CONST op1code :: pos (op1namen, ";" + symbol);
+ IF op1code = 0
+ THEN fehler
+ ELIF op1code = r (* Li 12.01.81 *)
+ THEN wiederholung (datei)
+ ELSE nextsymbol ;
+ IF primary (datei)
+ THEN operieren
+ ELSE fehler
+ FI
+ FI
+ OTHERWISE : fehler
+ END SELECT .
+
+is variable :
+ INT VAR var :: 1;
+ WHILE varname (var) <> symbol AND var <> freivar REP var INCR 1 PER;
+ IF var = freivar
+ THEN varname (var) := symbol; nextsymbol;
+ IF symbol = ":="
+ THEN deklarieren
+ ELSE LEAVE is variable WITH fehler
+ FI
+ ELSE nextsymbol
+ FI;
+ IF symbol = ":=" THEN nextsymbol; assignieren ELSE dereferenzieren FI .
+
+dereferenzieren :
+ typ := vartyp (var); zahlwert := varzahlwert (var);
+ textwert := vartextwert (var); TRUE .
+
+assignieren :
+ IF primary (datei)
+ THEN IF typ = integer
+ THEN varzahlwert (var) := zahlwert
+ ELIF typ = texttyp
+ THEN vartextwert (var) := textwert
+ ELSE fehler bearbeiten
+ FI;
+ vartyp (var) := typ; typ := void
+ ELSE fehler bearbeiten
+ FI;
+ NOT war fehler .
+
+deklarieren :
+ IF freivar = varimax
+ THEN fehler bearbeiten
+ ELSE freivar INCR 1
+ FI .
+
+prozedurieren :
+ typ := integer;
+ SELECT pcode OF
+ CASE pcol : zahlwert := feldstelle
+ CASE plen : zahlwert := LENGTH (datei (bildstelle).inhalt)
+ CASE prow : zahlwert := bildsatz
+ CASE phalt : zahlwert := haltzeile
+ CASE plimit : zahlwert := feldlimit
+ CASE pmark : zahlwert := bildmarke
+ CASE peof : eof (datei)
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ NOT war fehler .
+
+operieren :
+ SELECT op1code OF
+ CASE plus : zahlwert INCR bildsatz; row (datei)
+ CASE minus : zahlwert := bildsatz - zahlwert; row (datei)
+ CASE b : begin
+ CASE c : col
+ CASE g : get
+ CASE h : halt
+ CASE l : limit
+ CASE m : mark
+ CASE p : put
+ CASE i : if
+ CASE w : write
+ CASE s : size
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ typ := void; TRUE .
+
+begin :
+ zahlwert := zahlwert MOD 180;
+ feldende (feldende+zahlwert-feldanfang); feldanfang (zahlwert) .
+
+col :
+ zahlwert := zahlwert MOD 256; feldstelle (zahlwert) .
+
+get :
+ IF bildmarke <= 0 AND schreiberlaubnis
+ THEN vom file holen (datei, textwert)
+ FI .
+
+halt :
+ haltzeile := zahlwert .
+
+limit :
+ zahlwert := zahlwert MOD 256; feldlimit (zahlwert) .
+
+mark :
+ IF zahlwert = 0
+ THEN bildmarke (0); feldmarke (0); bildneu (TRUE)
+ ELSE bildmarke (bildstelle); feldmarke (feldstelle);
+ bildmarksatz (bildsatz)
+ FI .
+
+put :
+ IF bildmarke > 0 THEN in file bringen (datei, textwert) FI .
+
+if :
+ IF bedingung (datei)
+ THEN IF boolwert
+ THEN IF pos ("THEN", symbol) = 1
+ THEN nextsymbol;
+ IF ausdruck (datei)
+ THEN skip elseteil
+ ELSE fehler bearbeiten
+ FI
+ ELSE fehler bearbeiten
+ FI
+ ELSE skip thenteil;
+ IF j = 1
+ THEN elseteil
+ ELIF j <> 5
+ THEN fehler bearbeiten
+ FI
+ FI
+ ELSE fehler bearbeiten
+ FI .
+
+elseteil :
+ IF ausdruck (datei)
+ THEN IF symbol = "FI" THEN nextsymbol ELSE fehler bearbeiten FI
+ FI .
+
+skip elseteil :
+ WHILE symboltyp <> eol AND pos ("FI", symbol) <> 1 REP nextsymbol PER;
+ nextsymbol .
+
+skip thenteil :
+ WHILE (symboltyp <> eol) AND nicht elsefi REP nextsymbol PER;
+ nextsymbol .
+
+nicht elsefi :
+ j := pos ("ELSEFI", symbol); j = 0 .
+
+write :
+ feldkommando (textwert); zeile unveraendert .
+
+size :
+ IF bildlaenge > maxbildlaenge
+ THEN maxbildlaenge := bildlaenge
+ FI;
+ bildlaenge (max (1, min (zahlwert, maxbildlaenge)));
+ bildzeile (min (bildzeile, bildlaenge));
+ bildrand (0); bildneu (TRUE); page .
+
+END PROC primary;
+
+
+(*********** w i e d e r h o l u n g , b e d i n g u n g ***************)
+
+BOOL PROC wiederholung (DATEI VAR datei) :
+
+ fix scanner ; (* Li 12.01.81 *)
+ wiederholt interpretieren;
+ skip endrep; typ := void;
+ NOT war fehler .
+
+wiederholt interpretieren :
+ REP reset scanner; nextsymbol; (* 12.01.81 *)
+ WHILE ausdruck (datei) REP UNTIL until PER; abbruchtest
+ UNTIL ende der wiederholung
+ PER .
+
+until :
+ IF pos ("UNTIL", symbol) = 1
+ THEN nextsymbol;
+ IF primary (datei) THEN FI;
+ IF bedingung (datei)
+ THEN IF boolwert
+ THEN LEAVE wiederholt interpretieren;TRUE
+ ELSE TRUE
+ FI
+ ELSE fehler
+ FI
+ ELSE TRUE
+ FI .
+
+ende der wiederholung :
+ IF war fehler
+ THEN TRUE
+ ELIF datei (stelle).nachfolger = dateianker
+ THEN feldstelle > LENGTH (datei (stelle).inhalt)
+ ELSE FALSE
+ FI .
+
+skip endrep :
+ WHILE pos ("ENDREPEAT", symbol) <> 1 AND symboltyp <> eol
+ REP nextsymbol PER;
+ nextsymbol .
+
+abbruchtest :
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+
+END PROC wiederholung;
+
+BOOL PROC bedingung (DATEI VAR datei) :
+ INT VAR relator;
+ relator := pos ("=><<=>=<>", symbol);
+ IF relator = 0
+ THEN fehler
+ ELSE IF typ = texttyp THEN relator INCR 8 FI;
+ nextsymbol;
+ INT VAR operandtyp :: typ, operandzahlwert :: zahlwert;
+ TEXT VAR operandtextwert :: textwert;
+ IF primary (datei) THEN FI;
+ IF operandtyp <> typ
+ THEN fehler
+ ELSE boolwert := vergleich; typ := bool; TRUE
+ FI
+ FI .
+
+vergleich :
+ SELECT relator OF
+ CASE 1 : operandzahlwert = zahlwert
+ CASE 2 : operandzahlwert > zahlwert
+ CASE 3 : operandzahlwert < zahlwert
+ CASE 4 : operandzahlwert <= zahlwert
+ CASE 6 : operandzahlwert >= zahlwert
+ CASE 8 : operandzahlwert <> zahlwert
+ CASE 9 : operandtextwert = textwert
+ CASE 10 : operandtextwert > textwert
+ CASE 11 : operandtextwert < textwert
+ CASE 12 : operandtextwert <= textwert
+ CASE 14 : operandtextwert >= textwert
+ CASE 16 : operandtextwert <> textwert
+ OTHERWISE fehler
+ END SELECT .
+
+END PROC bedingung;
+
+(**************************** a u s d r u c k ****************************)
+
+BOOL PROC ausdruck (DATEI VAR datei) :
+ INT VAR opcode, operandtyp, operandzahlwert;
+ TEXT VAR operandtextwert;
+ IF primary (datei)
+ THEN BOOL VAR war operation :: TRUE;
+ WHILE operator AND war operation
+ REP IF primary (datei)
+ THEN war operation := operator verarbeiten
+ ELSE war operation := FALSE
+ FI
+ PER;
+ war operation
+ ELSE fehler
+ FI .
+
+operator :
+ IF kommandoende
+ THEN IF typ = integer
+ THEN row (datei)
+ ELIF typ = texttyp
+ THEN search (datei)
+ FI
+ FI;
+ opcode := pos (op2namen, "&" + symbol);
+ IF opcode = 0
+ THEN FALSE
+ ELSE nextsymbol; operandtyp := typ;
+ operandzahlwert := zahlwert;
+ operandtextwert := textwert;
+ NOT war fehler
+ FI .
+
+operator verarbeiten :
+ SELECT opcode OF
+ CASE plus :
+ IF typ = integer
+ THEN zahlwert := operandzahlwert + zahlwert
+ ELSE textwert := operandtextwert + textwert
+ FI
+ CASE minus :
+ zahlwert := operandzahlwert - zahlwert
+ CASE mal :
+ IF typ = integer
+ THEN zahlwert := operandzahlwert * zahlwert
+ ELSE textwert := operandzahlwert * textwert
+ FI
+ CASE durch :
+ zahlwert := operandzahlwert DIV zahlwert
+ CASE changecode :
+ change
+ CASE semicolon :
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ NOT war fehler .
+
+change :
+ IF bildmarke <= 0 AND schreiberlaubnis AND bildstelle <> dateianker
+ THEN ersatz := textwert; textwert := operandtextwert; search (datei);
+ INT VAR fstelle :: feldstelle;
+ IF textwert = "" AND ersatz <> "" AND fstelle > LENGTH inhalt
+ THEN inhalt := text (inhalt, fstelle-1)
+ FI;
+ IF subtext (inhalt, fstelle-LENGTH textwert, fstelle-1) = textwert
+ THEN fstelle := fstelle - LENGTH textwert;
+ FOR j FROM 1 UPTO LENGTH ersatz
+ REP IF j <= LENGTH textwert
+ THEN replace (inhalt, fstelle, ersatz SUB j)
+ ELSE insert char (inhalt, ersatz SUB j, fstelle)
+ FI;
+ fstelle INCR 1
+ PER;
+ FOR j FROM 1+LENGTH ersatz UPTO LENGTH textwert
+ REP delete char (inhalt, fstelle) PER;
+ FI;
+ feldstelle (fstelle); typ := void
+ ELSE fehler bearbeiten
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+kommandoende :
+ SELECT pos (";FIELSEENDREPEATUNTIL", symbol) OF
+ CASE 1,2,4,8,17 : TRUE
+ OTHERWISE symboltyp = eol
+ END SELECT .
+
+END PROC ausdruck;
+
+(************************** schrott ****************************************)
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291 ;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+END PACKET dateieditorpaket;
diff --git a/system/base/unknown/src/editor b/system/base/unknown/src/editor
new file mode 100644
index 0000000..55fbfb1
--- /dev/null
+++ b/system/base/unknown/src/editor
@@ -0,0 +1,210 @@
+
+PACKET editor DEFINES (* Autor: P.Heyderhoff *)
+ (* Stand: 26.04.82 *)
+ edit , (* Vers.: 1.6.3 *)
+ show ,
+ editmode :
+
+FILE VAR file 1, file 2 ;
+
+PROC edit (FILE VAR file) :
+ x edit (file) ;
+ENDPROC edit ;
+
+PROC edit (FILE VAR file 1, file 2) :
+ x edit (file 1, file 2 )
+ENDPROC edit ;
+
+PROC edit (TEXT CONST file name) :
+ last param (file name) ;
+ IF exists (file name)
+ THEN edit 1 (file name)
+ ELIF yes ("neue datei einrichten")
+ THEN edit 1 (file name)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit ;
+
+PROC edit :
+ edit (last param)
+ENDPROC edit ;
+
+PROC edit 1 (TEXT CONST name) :
+ file 1 := sequential file (modify, name) ;
+ IF NOT is error
+ THEN edit (file 1)
+ FI
+ENDPROC edit 1 ;
+
+PROC edit (TEXT CONST file name 1, file name 2) :
+ IF exists (file name 1)
+ THEN edit 2 (file name 1, file name 2)
+ ELIF yes ("erste datei neu einrichten")
+ THEN edit 2 (file name 1, file name 2)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit ;
+
+PROC edit 2 (TEXT CONST file name 1, file name 2) :
+ file 1 := sequential file (modify, file name 1) ;
+ IF exists (file name 2)
+ THEN file 2 := sequential file (modify, file name 2) ;
+ edit (file 1, file 2)
+ ELIF yes ("zweite datei neu einrichten")
+ THEN file 2 := sequential file (modify, file name 2) ;
+ edit (file 1, file 2)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit 2 ;
+
+PROC show (FILE VAR file) :
+ schreiberlaubnis (FALSE) ;
+ edit (file) ;
+ schreiberlaubnis (TRUE)
+ENDPROC show ;
+
+PROC show (TEXT CONST file name) :
+ IF exists (file name)
+ THEN file 1 := sequential file (modify, file name) ;
+ show (file 1) ;
+ ELSE errorstop ("file does not exist")
+ FI
+ENDPROC show ;
+
+PROC editmode :
+ feldwortweise (NOT feldwortweise) ;
+ say (" ") ;
+ IF feldwortweise
+ THEN say ("Flietext"13""10"")
+ ELSE say ("kein Umbruch"13""10"")
+ FI .
+
+ENDPROC editmode ;
+
+
+(****************************** e d i t o r ******************************)
+
+LET DATEI = ROW 4075 STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt),
+ freianker = 1, dateianker = 2, satzmax = 4075,
+ bottom = ""6""23""0"" , escape = ""27"", escape w = ""27"w";
+
+BOOL VAR war kein wechsel ;
+TEXT VAR tabulator :: 77*" ";
+
+
+PROC editor (DATEI VAR datei) :
+ enable stop ;
+ grundzustand;
+ zustand aus datei holen ;
+
+ REP b i l d e d i t o r (datei);
+ d a t e i e d i t o r (datei)
+ UNTIL (feldkommando SUB 1) = escape
+ PER;
+ war kein wechsel := (feldkommando SUB 2) <> "w";
+ feldkommando (subtext (feldkommando, 3));
+
+ IF schreiberlaubnis THEN zustand in datei retten FI;
+ schreiberlaubnis (TRUE);
+ out (bottom) .
+
+grundzustand :
+ bildneu (TRUE); bildeinfuegen (FALSE); bildmarke (0);
+ feldmarke (0); feldseparator (""); feldstelle(1);
+ feldeinfuegen (FALSE).
+
+zustand in datei retten :
+ inhalt := text (bildstelle, 5);
+ inhalt CAT text (bildsatz, 5);
+ inhalt CAT text (bildzeile, 5);
+ inhalt CAT text (feldlimit, 5);
+ feldtab (tabulator);
+ inhalt CAT tabulator .
+
+zustand aus datei holen :
+ INT CONST satz nr := int (subtext (inhalt, 1, 5)) ;
+ IF satz nr > 0
+ THEN bildstelle (satz nr)
+ ELSE bildstelle (datei (dateianker).nachfolger)
+ FI ;
+ bildsatz (int (subtext (inhalt, 6, 10)));
+ bildzeile (int (subtext (inhalt, 11, 15)));
+ feldlimit (int (subtext (inhalt, 16, 20)));
+ tabulator := subtext (inhalt, 21) ;
+ feldtabulator (tabulator) .
+
+inhalt :
+ datei (freianker).inhalt .
+
+END PROC editor;
+
+PROC y edit (DATEI VAR datei) :
+ editor (datei);
+ close
+END PROC y edit;
+
+LET begin mark = ""15"", endmark blank = ""14" ";
+
+PROC y edit (DATEI VAR erste datei, zweite datei) :
+ INT CONST alte laenge := bildlaenge - 1;
+ INT VAR laenge := alte laenge DIV 2, flen := feldende - feldanfang + 2;
+ bildlaenge (laenge); feldkommando (escape w);
+ zweimal editieren;
+ bildlaenge (alte laenge + 1); bildrand (0);
+ close .
+
+zweimal editieren:
+ page;
+ REP cursor ( 1, laenge + 2); out (begin mark);
+ cursor(flen, laenge + 2); out (endmark blank);
+ bildrand (0); editor (erste datei); laenge anpassen;
+ IF war kein wechsel THEN LEAVE zweimal editieren FI;
+ bildrand (alte laenge + 1 - laenge);
+ editor (zweite datei); laenge anpassen
+ UNTIL war kein wechsel
+ PER .
+
+laenge anpassen :
+ laenge := bildlaenge;
+ IF laenge = 1 THEN laenge := 2 FI;
+ IF laenge <= alte laenge - 2
+ THEN laenge := alte laenge - laenge
+ ELSE laenge := 2
+ FI ; bildlaenge (laenge) .
+END PROC y edit;
+
+(**************** schrott ***********************)
+
+PROC x edit (FILE VAR f) :
+ EXTERNAL 296
+ENDPROC x edit ;
+
+PROC x edit (FILE VAR f1, f2) :
+ EXTERNAL 297
+ENDPROC x edit ;
+
+LET FDATEI= STRUCT ( BOUND DATEI f ,
+ INT index, pointer, line counter,
+ mode, max line length, max page length,
+ BOOL edit status unchanged) ;
+
+PROC x edit (FDATEI VAR f1) :
+ INTERNAL 296 ;
+ y edit (CONCR (f1.f))
+ENDPROC x edit ;
+
+PROC x edit (FDATEI VAR f1, f2) :
+ INTERNAL 297 ;
+ y edit (CONCR (f1.f), CONCR (f2.f))
+ENDPROC x edit ;
+
+PROC dateieditor (DATEI VAR d) :
+ EXTERNAL 295
+ENDPROC dateieditor ;
+
+PROC bildeditor (DATEI VAR d) :
+ EXTERNAL 293
+ENDPROC bildeditor ;
+
+ENDPACKET editor ;
diff --git a/system/base/unknown/src/elan b/system/base/unknown/src/elan
new file mode 100644
index 0000000..744003d
--- /dev/null
+++ b/system/base/unknown/src/elan
@@ -0,0 +1,245 @@
+
+PACKET local manager part 2 DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 29.04.80 *)
+ list ,
+ file names :
+
+
+FILE VAR list file ;
+TEXT VAR file name, status text;
+
+PROC list :
+
+ list file := sequential file (output) ;
+ headline (list file, "list") ;
+ list (list file) ;
+ show (list file) ;
+ close
+
+ENDPROC list ;
+
+PROC list (FILE VAR f) :
+
+ begin list ;
+ putline (f, "") ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE list
+ FI ;
+ out (f, status text + " """ ) ;
+ out (f, file name) ;
+ out (f, """") ;
+ line (f)
+ PER
+
+ENDPROC list ;
+
+PROC file names (FILE VAR f) :
+
+ begin list ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE file names
+ FI ;
+ putline (f, file name)
+ PER
+
+ENDPROC file names ;
+
+ENDPACKET local manager part 2 ;
+
+
+PACKET elan DEFINES (*Autor: J.Liedtke *)
+ (*Stand: 01.05.82 *)
+ do ,
+ run ,
+ run again ,
+ insert ,
+ prot ,
+ prot off ,
+ check on ,
+ check off :
+
+
+LET newinit option = FALSE ,
+ ins = TRUE ,
+ no ins = FALSE ,
+ lst = TRUE ,
+ no lst = FALSE ,
+ compiler dump option = FALSE ,
+ sys option = TRUE ,
+ stop at first error = TRUE ,
+ multiple error analysis = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+ compile line mode = 2 ,
+
+ error message = 4 ;
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ errors occurred ;
+
+INT VAR run again mod nr := 0 ;
+DATASPACE VAR ds ;
+
+FILE VAR error file, source file ;
+
+
+PROC do (TEXT CONST command) :
+
+ INT VAR dummy mod ;
+ run again mod nr := 0 ;
+ errors occurred := FALSE ;
+ elan (compile line mode, ds, command, dummy mod,
+ newinit option, no ins, compiler dump option, no lst, sys option,
+ check option, stop at first error, no sermon) ;
+ IF errors occurred
+ THEN forget (ds) ;
+ errorstop ("")
+ FI
+
+ENDPROC do ;
+
+
+PROC run (TEXT CONST file name) :
+
+ 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 INT VAR mod := run again mod nr ;
+ elan (run again mode, ds, "", run again mod nr,
+ newinit option, no ins, compiler dump option, no lst,
+ sys option, check option, stop at first error, no sermon)
+ ELSE errorstop ("run again impossible")
+ FI
+
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+
+ 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) :
+
+ IF exists (file name)
+ THEN compile and execute
+ ELSE errorstop ("file does not exist")
+ FI .
+
+compile and execute :
+ disable stop ;
+ errors occurred := FALSE ;
+ elan (compile file mode, old (file name, 1002), "" , run again mod nr,
+ newinit option, insert option, compiler dump option, list option,
+ sys option, check option, multiple error analysis, sermon) ;
+
+ IF errors occurred
+ THEN ignore halt during compiling ;
+ errors occurred := FALSE ;
+ enable stop ;
+ source file := sequential file (modify, file name) ;
+ modify (error file) ;
+ edit (error file, source file) ;
+ forget (ds)
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+ENDPROC run elan ;
+
+PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line,
+ INT VAR start module number,
+ BOOL CONST newinit, ins, dump, lst, sys, rt check, error1, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+PROC out text (TEXT CONST text, INT CONST out type) :
+
+ INTERNAL 257 ;
+ out (text) ;
+ IF out type = error message
+ THEN access error file ;
+ out (error file, text)
+ FI .
+
+access error file :
+ IF NOT errors occurred
+ THEN open error file
+ FI .
+
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+
+ INTERNAL 258 ;
+ out (""13""10"") ;
+ IF out type = error message
+ THEN access error file ;
+ line (error file)
+ FI .
+
+access error file :
+ IF NOT errors occurred
+ THEN open error file
+ FI .
+
+ENDPROC out line ;
+
+PROC open error file :
+
+ errors occurred := TRUE ;
+ forget (ds) ;
+ ds := nilspace ;
+ error file := sequential file (output, ds) ;
+ headline (error file, "errors")
+
+ENDPROC open error file ;
+
+PROC prot :
+ list option := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE
+ENDPROC prot off ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+ENDPACKET elan ;
diff --git a/system/base/unknown/src/feldeditor b/system/base/unknown/src/feldeditor
new file mode 100644
index 0000000..4156111
--- /dev/null
+++ b/system/base/unknown/src/feldeditor
@@ -0,0 +1,747 @@
+
+PACKET f e l d e d i t o r DEFINES (* Autor: P.Heyderhoff *)
+ (*****************) (* Stand: 12.04.82 *)
+ (* Vers.: 1.6.0 *)
+ editget,
+ feldeditor,
+ feldout,
+ feldposition,
+ feldeinruecken,
+ feldtab,
+ feldtabulator,
+ feldseparator,
+ feldmarke,
+ feldstelle,
+ feldwortweise,
+ feldanfang,
+ feldende,
+ feldrand,
+ feldlimit,
+ feldaudit,
+ feldzeichen,
+ feldkommando,
+ feldeinfuegen,
+ feldlernmodus,
+ is incharety,
+ getchar,
+ min :
+
+
+TEXT VAR tabulator :: "", separator :: "", fzeichen ::"",
+ kommando :: "", audit :: "";
+
+INT VAR fmarke :: 0, fstelle :: 1, frand :: 0, limit :: 77,
+ fanfang :: 1, dyn fanfang :: fanfang, flaenge, fj,
+ fende :: 77, dyn fende :: fende, dezimalen :: 0;
+
+BOOL VAR wortweise :: FALSE, feinfuegen :: FALSE,
+ blankseparator :: FALSE, lernmodus :: FALSE,
+ war absatz;
+
+LET blank = " ", hop=""1"", right=""2"", up=""3"", clear eop=""4"",
+ clear eol=""5"", bell=""7"", left=""8"", tab=""9"", down=""10"",
+ rubin=""11"", rubout=""12"", cr=""13"", mark=""16"", escape=""27"",
+ hoechstes steuerzeichen=""31"", dach=""94"", end mark=""14"", begin
+ mark=""15"", clear=""1""4"", hop tab=""1""9"", hop rubin=""1""11"",
+ hop rubout=""1""12"", hop cr=""1""13"", cr down=""13""10"",
+ right left tab rubout escape = ""2""8""9""12""27"", hop escape=""1""27"",
+ left left=""8""8"", left endmark=""8""14"", endmark left=""14""8"",
+ left right=""8""2"", blank left=" "8"",
+ blank left rubout=" "8""12"", absatzmarke=""15""14"",
+ hop esc right left tab rubin rubout cr = ""1""27""2""8""9""11""12""13"",
+ hop esc right left tab down cr = ""1""27""2""8""9""10""13"";
+
+(*************************** p r o z e d u r e n *************************)
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, editfende):
+
+ disable stop ; (* J.Liedtke 10.02.82 *)
+
+ INT CONST altflaenge :: LENGTH editsatz, altfrand :: frand,
+ altfmarke :: fmarke, altfstelle :: fstelle,
+ altfanfang :: fanfang, altfende :: fende, altlimit :: limit;
+ BOOL CONST altwortweise :: wortweise, altfeinfuegen :: feinfuegen;
+ fmarke := 0; fstelle := 1; fanfang := 1; dyn fanfang := 1;
+ fende := editfende MOD 256; dyn fende := fende;
+ limit := editlimit MOD 256; wortweise := FALSE;
+ feinfuegen := FALSE;
+ INT VAR x, y; get cursor (x,y); frand := x-1;
+ out (editsatz); cursor (x,y);
+ REP
+ feldeditor (editsatz);
+ IF (kommando SUB 1) = escape OR (kommando SUB 1) = hop
+ THEN delete char (kommando, 1)
+ FI;
+ delete char (kommando, 1)
+ UNTIL fzeichen = cr OR (fzeichen SUB 1) = separator OR is error
+ PER;
+ cursor (x + 1 + editflaenge - dyn fanfang, y);
+ fmarke := altfmarke; fstelle := altfstelle; fanfang := altfanfang;
+ dyn fanfang := fanfang; fende := altfende; dyn fende := fende;
+ limit := altlimit; wortweise := altwortweise; frand := altfrand;
+ feinfuegen := altfeinfuegen .
+
+editflaenge :
+ min (dyn fende, flaenge) .
+
+END PROC editget;
+
+PROC editget (TEXT VAR editsatz) :
+ INT VAR x, y; get cursor (x,y);
+ editget (editsatz, 255, fende-fanfang+2+frand-x)
+END PROC editget;
+
+PROC feldout (TEXT CONST satz) :
+ INT VAR x, y;
+ flaenge := min (fende, LENGTH satz);
+ out (cr);
+ frand TIMESOUT right; feldrest loeschen (fanfang);
+ IF fmarke > 0
+ THEN outsubtext (satz, fanfang, fmarke-1); out (begin mark);
+ outsubtext (satz, fmarke, min (fstelle-1,flaenge));
+ out (end mark); outsubtext (satz, fstelle, flaenge);
+ ELIF absatzmarke noetig (satz)
+ THEN get cursor (x,y); outsubtext (satz, fanfang, flaenge);
+ cursor (x + fende + 1 - fanfang, y); out (absatzmarke)
+ ELSE outsubtext (satz, fanfang, flaenge)
+ FI
+END PROC feldout;
+
+
+PROC feld einruecken (TEXT CONST satz) :
+
+ IF fstelle = fanfang
+ THEN fstelle := neue einrueckposition;
+ (fstelle-fanfang) TIMESOUT right
+ FI .
+
+neue einrueckposition :
+ INT VAR suchindex;
+ FOR suchindex FROM fanfang UPTO min (LENGTH satz, fende)
+ REP IF (satz SUB suchindex) <> blank
+ THEN LEAVE neue einrueckposition WITH suchindex
+ FI
+ PER;
+ fanfang .
+
+END PROC feld einruecken;
+
+TEXT PROC feldzeichen :
+ fzeichen
+END PROC feldzeichen;
+
+TEXT PROC feldkommando :
+ kommando
+END PROC feldkommando;
+
+PROC feldkommando (TEXT CONST t) :
+ kommando := t
+END PROC feldkommando;
+
+PROC feldtab (TEXT VAR t) :
+ t := tabulator
+END PROC feldtab;
+
+PROC feldtabulator (TEXT CONST t) :
+ tabulator := t
+END PROC feldtabulator;
+
+TEXT PROC feldseparator :
+ separator
+END PROC feldseparator;
+
+PROC feldseparator (TEXT CONST t) :
+ separator := t; blankseparator := t = blank
+END PROC feldseparator;
+
+TEXT PROC feldaudit :
+ audit
+END PROC feldaudit;
+
+PROC feldaudit (TEXT CONST a) :
+ audit := a
+END PROC feldaudit;
+
+BOOL PROC feldlernmodus :
+ lernmodus
+END PROC feldlernmodus;
+
+PROC feldlernmodus (BOOL CONST b) :
+ lernmodus := b
+END PROC feldlernmodus;
+
+BOOL PROC feldeinfuegen :
+ feinfuegen
+END PROC feldeinfuegen;
+
+PROC feldeinfuegen (BOOL CONST b):
+ feinfuegen := b
+END PROC feldeinfuegen;
+
+BOOL PROC feldwortweise :
+ wortweise
+END PROC feldwortweise;
+
+PROC feldwortweise (BOOL CONST b) :
+ wortweise := b
+END PROC feldwortweise;
+
+INT PROC feldmarke :
+ fmarke
+END PROC feldmarke;
+
+PROC feldmarke (INT CONST i) :
+ fmarke := i MOD 256
+END PROC feldmarke;
+
+INT PROC feldstelle :
+ fstelle
+END PROC feldstelle;
+
+PROC feldstelle (INT CONST i) :
+ fstelle := i MOD 256
+END PROC feldstelle;
+
+INT PROC feldanfang :
+ fanfang
+END PROC feldanfang;
+
+PROC feldanfang (INT CONST i) :
+ fanfang := i MOD 256; dyn fanfang := fanfang
+END PROC feldanfang;
+
+INT PROC feldende :
+ fende
+END PROC feldende;
+
+PROC feldende (INT CONST i) :
+ fende := i MOD 256; dyn fende := fende
+END PROC feldende;
+
+INT PROC feldrand :
+ frand
+END PROC feldrand;
+
+PROC feldrand (INT CONST i) :
+ frand := i MOD 256
+END PROC feldrand;
+
+INT PROC feldlimit :
+ limit
+END PROC feldlimit;
+
+PROC feldlimit (INT CONST i) :
+ limit := i MOD 256
+END PROC feldlimit;
+
+PROC feldposition :
+ INT VAR x, y;
+ IF fstelle <= fende
+ THEN IF fstelle < fanfang
+ THEN fstelle := fanfang;
+ IF fanfang > fende
+ THEN fende := fanfang; dyn fende := fanfang
+ FI
+ FI
+ ELSE fstelle := fende;
+ IF fanfang > fende
+ THEN fanfang := fende; dyn fanfang := fende
+ FI
+ FI;
+ get cursor(x,y); cursor(1+frand+fstelle-fanfang+fmarke oder fstelle, y).
+
+fmarke oder fstelle :
+ IF fmarke > 0 THEN 1 ELSE 0 FI .
+
+END PROC feldposition;
+
+PROC feldposition (INT CONST i) :
+ fstelle := i; feldposition
+END PROC feldposition;
+
+BOOL PROC absatzmarke noetig (TEXT CONST satz) :
+
+ IF wortweise
+ THEN (satz SUB LENGTH satz) = blank
+ ELSE FALSE
+ FI
+END PROC absatzmarke noetig;
+
+PROC zeile neu schreiben (TEXT CONST satz) :
+ INT VAR x,y; get cursor (x,y);
+ flaenge := min (dyn fende, LENGTH satz);
+ cursor (1+frand, y);
+ feldrest loeschen (dyn fanfang);
+ outsubtext (satz, dyn fanfang, flaenge);
+ cursor (x,y)
+END PROC zeile neu schreiben;
+
+PROC feldrest loeschen (INT CONST fstelle):
+ INT VAR x,y;
+ IF frand + fende <= 76
+ THEN get cursor (x,y); (1 + dyn fende - fstelle) TIMESOUT blank;
+ cursor (x,y)
+ ELSE out (clear eol); war absatz := FALSE
+ FI
+END PROC feldrest loeschen;
+
+TEXT OP SUBB (TEXT CONST t, INT CONST i) :
+ IF i <= LENGTH t THEN t SUB i ELSE blank FI
+END OP SUBB;
+
+INT PROC min (INT CONST a, b):
+ IF a < b THEN a ELSE b FI
+END PROC min;
+
+BOOL PROC is incharety (TEXT CONST muster) :
+
+ fzeichen := incharety;
+ IF fzeichen = ""
+ THEN FALSE
+ ELSE IF lernmodus
+ THEN audit CAT fzeichen;
+ IF fzeichen = """" THEN audit CAT fzeichen
+ FI FI ;
+ IF fzeichen = muster
+ THEN kommando := ""; TRUE
+ ELSE kommando CAT fzeichen; FALSE
+ FI FI
+END PROC is incharety;
+
+PROC getchar (TEXT VAR fzeichen) :
+
+ IF kommando = ""
+ THEN inchar (fzeichen)
+ ELSE fzeichen := kommando SUB 1;
+ delete char (kommando, 1);
+ kommando CAT incharety
+ FI;
+ IF lernmodus
+ THEN audit CAT fzeichen;
+ IF fzeichen = """"
+ THEN audit CAT fzeichen
+ FI
+ FI .
+END PROC getchar;
+
+
+(************************** f e l d e d i t o r **************************)
+
+PROC feldeditor (TEXT VAR satz) :
+
+ enable stop ; (* J. Liedtke 10.02.82 *)
+
+ INT VAR x, y;
+ BOOL VAR inkompetent :: FALSE; war absatz := absatzmarke noetig (satz);
+ IF fstelle <= fende
+ THEN IF fstelle < fanfang THEN feldposition FI
+ ELSE feldposition
+ FI;
+ flaenge := min (fende, LENGTH satz);
+
+ REP e i n g a b e UNTIL inkompetent PER;
+
+ blanks abschneiden;
+ IF dyn fanfang <> fanfang THEN zurechtruecken FI;
+ IF NOT war absatz AND absatzmarke noetig (satz)
+ THEN absatzmarke schreiben
+ ELIF war absatz AND NOT absatzmarke noetig (satz)
+ THEN absatzmarke loeschen
+ FI .
+
+absatzmarke schreiben :
+ get cursor (x,y); cursor (frand+fende-fanfang+2, y); out (absatzmarke);
+ cursor (x,y) .
+
+absatzmarke loeschen :
+ get cursor (x,y); cursor (frand+fende-fanfang+2, y); out (" ");
+ cursor (x,y) .
+
+zurechtruecken :
+ fstelle DECR (dyn fanfang - fanfang);
+ dyn fanfang := fanfang; dyn fende := fende;
+ zeile neu schreiben (satz) .
+
+blanks abschneiden :
+ flaenge := LENGTH satz;
+ FOR fj FROM flaenge DOWNTO 0 WHILE (satz SUB fj) = blank
+ REP delete char (satz, fj) PER;
+ IF fj < flaenge THEN satz CAT blank FI .
+
+eingabe :
+ IF fmarke <= 0
+ THEN s c h r e i b e d i t o r;
+ IF ueberlaufbedingung
+ THEN ueberlauf
+ ELSE a u s f u e h r e n
+ FI
+ ELSE m a r k e d i t o r
+ FI .
+
+ueberlaufbedingung :
+ IF fstelle <= dyn fende
+ THEN IF fstelle <= limit
+ THEN FALSE
+ ELSE fzeichen > hoechstes steuerzeichen
+ FI
+ ELSE TRUE
+ FI .
+
+ueberlauf :
+ IF fstelle > limit
+ THEN IF wortweise OR fstelle > LENGTH satz
+ THEN ueberlauf in naechste zeile; LEAVE ueberlauf
+ FI
+ FI;
+ IF fstelle > dyn fende
+ THEN fstelle := dyn fende; out (left);
+ zeile um eins nach links verschieben
+ FI .
+
+ueberlauf in naechste zeile :
+ IF wortweise
+ THEN umbrechen
+ ELSE out (bell); kommando := cr
+ FI;
+ inkompetent := TRUE .
+
+umbrechen :
+ IF LENGTH satz > limit
+ THEN kommando CAT subtext (satz, limit+1);
+ FOR fj FROM LENGTH satz DOWNTO fstelle
+ REP kommando CAT left PER;
+ satz := subtext (satz, 1, limit)
+ FI;
+ fj := limit;
+ zeichen zuruecknehmen;
+ (fstelle-fj) TIMESOUT left; fstelle := fj; feldrest loeschen (fstelle);
+ IF kommando = "" THEN kommando := blank left rubout FI;
+ blanks loeschen.
+
+blanks loeschen:
+ REP fj DECR 1;
+ IF (satz SUB fj) <> blank THEN LEAVE blanks loeschen FI;
+ delete char (satz, fj)
+ PER .
+
+zeichen zuruecknehmen:
+ REP fzeichen := satz SUB fj; delete char (satz, fj);
+ IF fzeichen = blank THEN LEAVE zeichen zuruecknehmen FI;
+ insert char (kommando, fzeichen, 1);
+ IF fj = fanfang THEN LEAVE zeichen zuruecknehmen FI;
+ fj DECR1
+ PER.
+
+ausfuehren :
+ dezimalen := 0;
+ SELECT pos (hop esc right left tab rubin rubout cr, fzeichen) OF
+ CASE 1 : getchar (fzeichen);
+ SELECT pos (right left tab rubout escape, fzeichen) OF
+ CASE 1 : zum rechten frand
+ CASE 2 : zum linken frand
+ CASE 3 : tabulator setzen
+ CASE 4 : zeile loeschen
+ CASE 5 : bei lernmodus ein zeichen lesen
+ OTHERWISE hop return
+ END SELECT
+ CASE 2 : escape aktion
+ CASE 3 : nach rechts
+ CASE 4 : nach links
+ CASE 5 : nach tabulator
+ CASE 6 : feinfuegen umschalten
+ CASE 7 : ausfuegen
+ CASE 8 : ggf absatz erzeugen; return
+ OTHERWISE return
+ END SELECT .
+
+ggf absatz erzeugen :
+ IF wortweise
+ THEN IF fstelle > LENGTH satz
+ THEN IF (satz SUB LENGTH satz) <> blank
+ THEN satz CAT blank; fstelle INCR 1
+ FI
+ FI
+ FI .
+
+nach rechts :
+ IF fstelle < dyn fende AND (fstelle < limit OR fstelle < flaenge)
+ THEN out (right); fstelle INCR1
+ ELIF LENGTH satz > dyn fende
+ THEN zeile um eins nach links verschieben
+ ELSE return
+ FI .
+
+nach links :
+ IF fstelle > dyn fanfang
+ THEN out (left); fstelle DECR1
+ ELIF dyn fanfang = fanfang
+ THEN out (bell)
+ ELSE zeile um eins nach rechts verschieben
+ FI .
+
+bei lernmodus ein zeichen lesen :
+ IF lernmodus
+ THEN getchar (fzeichen); return;
+ fzeichen := escape
+ FI;
+ hop return; fzeichen := hop escape .
+
+zeile um eins nach links verschieben :
+ dyn fanfang INCR 1; dyn fende INCR 1;
+ fstelle := dyn fende; zeile neu schreiben (satz) .
+
+zeile um eins nach rechts verschieben :
+ dyn fanfang DECR 1; dyn fende DECR 1;
+ fstelle := dyn fanfang; zeile neu schreiben (satz) .
+
+feinfuegen umschalten :
+ IF feinfuegen
+ THEN feinfuegen := FALSE
+ ELSE feinfuegen := TRUE; get cursor (x,y); out (dach);
+ outsubtext (satz, fstelle, flaenge);
+ cursor (x,y); pause (1);
+ feldrest loeschen (fstelle);
+ outsubtext (satz, fstelle, flaenge);
+ cursor (x,y)
+ FI;
+ return .
+
+ausfuegen :
+ IF flaenge < dyn fanfang OR fstelle > flaenge
+ THEN IF fstelle = flaenge + 1 AND fstelle > dyn fanfang
+ THEN fstelle := flaenge; out (left)
+ ELSE out (bell);
+ LEAVE ausfuegen
+ FI
+ FI;
+ ausfuegeoperation; delete char (satz, fstelle);
+ flaenge := min (dyn fende, LENGTH satz) .
+
+ausfuegeoperation :
+ get cursor (x,y); outsubtext (satz, fstelle+1, flaenge+1);
+ out (blank); cursor (x,y) .
+
+zum linken frand :
+ IF fstelle > fanfang
+ THEN get cursor (x,y); cursor (1+frand, y);
+ IF dyn fanfang = fanfang
+ THEN fstelle := fanfang
+ ELSE verschieben an linken frand
+ FI
+ FI .
+
+zum rechten frand :
+ fj := min (dyn fende, limit); get cursor (x,y);
+ IF LENGTH satz > fj
+ THEN IF fstelle >= LENGTH satz
+ THEN out (bell)
+ ELIF LENGTH satz > dyn fende
+ THEN verschieben an rechten frand
+ ELSE cursor (x + LENGTH satz - fstelle, y);
+ fstelle := LENGTH satz
+ FI
+ ELIF fstelle < fj
+ THEN cursor (x + fj-fstelle, y); fstelle := fj
+ FI .
+
+verschieben an linken frand :
+ dyn fanfang := fanfang; dyn fende := fende;
+ fstelle := fanfang; zeile neu schreiben (satz).
+
+verschieben an rechten frand :
+ (dyn fende - fstelle) TIMESOUT right;
+ dyn fanfang INCR (LENGTH satz - dyn fende); dyn fende := LENGTH satz;
+ fstelle := dyn fende; zeile neu schreiben (satz).
+
+nach tabulator :
+ fj := pos (tabulator, "^", fstelle+1);
+ IF fj = 0
+ THEN IF (satz SUB fstelle) = blank AND fstelle = fanfang
+ THEN IF satz = blank
+ THEN fstelle INCR 1; out (right)
+ ELSE out (blank left); feld einruecken (satz);
+ FI;
+ LEAVE nach tabulator
+ ELIF flaenge < dyn fende AND fstelle <= flaenge
+ THEN fj := flaenge + 1
+ FI
+ ELSE dezimalen := 1
+ FI;
+ IF fj > 0 AND fj <= dyn fende
+ THEN outsubtext (satz, fstelle, fj-1); fstelle := fj
+ ELSE (fstelle-dyn fanfang) TIMESOUT left;
+ fstelle := dyn fanfang; insert char (kommando, down, 1)
+ FI .
+
+tabulator setzen :
+ IF (tabulator SUB fstelle) = "^"
+ THEN fzeichen := right
+ ELSE fzeichen := "^"
+ FI;
+ WHILE fstelle > LENGTH tabulator
+ REP tabulator CAT right PER;
+ replace (tabulator, fstelle, fzeichen);
+ insert char (kommando, tab, 1);
+ insert char (kommando, hop, 1);
+ inkompetent := TRUE .
+
+zeile loeschen :
+ IF fstelle = 1
+ THEN satz := ""; feldrest loeschen (fstelle); hop return
+ ELIF fstelle <= flaenge
+ THEN REP delete char (satz, LENGTH satz)
+ UNTIL fstelle > LENGTH satz
+ PER;
+ flaenge := fstelle - 1; feldrest loeschen (fstelle)
+ ELSE hop return
+ FI .
+
+(*********************** s c h r e i b e d i t o r ***********************)
+
+schreibeditor :
+ REP getchar (fzeichen);
+ IF fzeichen <= hoechstes steuerzeichen THEN LEAVE schreibeditor
+ ELIF separator bedingung THEN LEAVE schreibeditor
+ ELSE f o r t s c h r e i b e n FI
+ PER .
+
+separatorbedingung :
+ IF blankseparator
+ THEN IF flaenge + 2 <= fstelle
+ THEN insert char (kommando, fzeichen, 1);
+ fzeichen := blank
+ FI
+ FI;
+ fzeichen = separator .
+
+fortschreiben :
+ IF dezimalen > 0 THEN dezimaltabulator FI;
+ out (fzeichen);
+ IF fstelle > flaenge
+ THEN anhaengen
+ ELIF dezimalen = 0 AND feinfuegen
+ THEN insert char (satz, fzeichen, fstelle)
+ ELSE replace (satz, fstelle, fzeichen)
+ FI;
+ flaenge := min (dyn fende, LENGTH satz);
+ fstelle INCR 1;
+ IF feinfuegen AND dezimalen = 0 AND fstelle <= flaenge
+ THEN zeilenrest neu schreiben
+ FI;
+ IF fstelle > dyn fende
+ OR fstelle > limit AND (wortweise OR fstelle > flaenge)
+ THEN LEAVE schreibeditor
+ FI .
+
+zeilenrest neu schreiben :
+ get cursor (x,y); outsubtext (satz, fstelle, flaenge); cursor (x,y) .
+
+dezimaltabulator :
+ IF fzeichen < "0" OR fzeichen > "9"
+ THEN dezimalen := 0
+ ELIF dezimalen = 1
+ THEN IF (satz SUB fstelle) = blank OR fstelle > flaenge
+ THEN dezimalen := 2
+ ELSE dezimalen := 0
+ FI
+ ELIF (satz SUB fstelle-dezimalen) = blank
+ THEN replace (satz, fstelle-dezimalen,
+ subtext (satz, fstelle-dezimalen+1, fstelle-1)) ;
+ dezimalen TIMESOUT left;
+ outsubtext (satz, fstelle-dezimalen, fstelle-2);
+ dezimalen INCR 1; fstelle DECR 1
+ ELSE dezimalen := 0
+ FI .
+
+anhaengen :
+ FOR fj FROM flaenge+2 UPTO fstelle
+ REP satz CAT blank PER;
+ satz CAT fzeichen .
+
+
+(************************** m a r k e d i t o r **************************)
+
+markeditor :
+ getchar (fzeichen);
+ SELECT pos (hop esc right left tab down cr, fzeichen) OF
+ CASE 1 : getchar (fzeichen);
+ IF fzeichen = right THEN markierung maximal
+ ELIF fzeichen = left THEN markierung minimal
+ ELSE hop return
+ FI
+ CASE 2 : escape aktion
+ CASE 3 : markierung verlaengern
+ CASE 4 : markierung verkuerzen
+ CASE 5 : markierung bis tab verlaengern
+ CASE 6,7 : zeilenrest markieren
+ OTHERWISE IF fzeichen <= hoechstes steuerzeichen
+ THEN return
+ ELSE out (bell)
+ FI
+ END SELECT .
+
+markierung verlaengern :
+ IF fstelle <= flaenge
+ THEN out (satz SUB fstelle, end mark left); fstelle INCR 1
+ ELSE return
+ FI .
+
+markierung maximal :
+ IF fstelle <= flaenge
+ THEN outsubtext (satz, fstelle, flaenge); out (end mark left);
+ fstelle := flaenge + 1
+ FI .
+
+zeilenrest markieren :
+ IF fstelle <= flaenge
+ THEN outsubtext (satz, fstelle, flaenge);
+ out (end mark left);
+ (flaenge-fstelle+2) TIMESOUT left
+ FI;
+ return .
+
+markierung verkuerzen :
+ IF fstelle > fmarke
+ THEN fstelle DECR 1;
+ out (left end mark, satz SUBB fstelle, left left)
+ ELSE out (bell)
+ FI .
+
+markierung minimal :
+ IF fstelle > fmarke
+ THEN (fstelle-fmarke) TIMESOUT left; out (end mark);
+ outsubtext (satz, fmarke, fstelle-1);
+ (fstelle-fmarke+1) TIMESOUT left; fstelle := fmarke
+ FI .
+
+markierung bis tab verlaengern :
+ fj := pos (tabulator, "^", fstelle + 1);
+ IF fj = 0
+ THEN fj := flaenge - fstelle + 1; IF fj <= 0 THEN return FI
+ ELSE fj DECR fstelle
+ FI;
+ IF fj > 0
+ THEN outsubtext (satz, fstelle, min (fstelle+fj-1, flaenge));
+ out (end mark left)
+ FI;
+ fstelle INCR fj;
+ IF fstelle > (dyn fende+1) THEN return FI .
+
+
+(******************* allgemein verwendete refinements *********************)
+
+return :
+ insert char (kommando, fzeichen, 1);
+ inkompetent := TRUE .
+
+hop return :
+ return; insert char (kommando, hop, 1) .
+
+escape aktion :
+ getchar (fzeichen); return;
+ insert char (kommando, escape, 1);
+ insert char (fzeichen, escape, 1) .
+
+END PROC feldeditor;
+
+END PACKET feldeditor;
diff --git a/system/base/unknown/src/file b/system/base/unknown/src/file
new file mode 100644
index 0000000..e556bec
--- /dev/null
+++ b/system/base/unknown/src/file
@@ -0,0 +1,810 @@
+
+PACKET file DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.04.82 *)
+ FILE ,
+ := ,
+ input ,
+ output ,
+ modify ,
+ sequential file ,
+ getline ,
+ putline ,
+ line ,
+ reset ,
+ eof ,
+ put ,
+ get ,
+ page ,
+ out ,
+ eop ,
+ close ,
+ max line length ,
+ max page length ,
+ read record ,
+ write record ,
+ forward ,
+ backward ,
+ delete record ,
+ insert record ,
+ to first record ,
+ to eof ,
+ is first record ,
+ headline ,
+ copy attributes ,
+ reorganize ,
+ feldeditor ,
+ feldout ,
+ feldeinruecken ,
+ pos ,
+ change ,
+ subtext ,
+ sort :
+
+
+
+TYPE FILE = STRUCT ( BOUND DATEI f ,
+ INT index, pointer, line counter,
+ mode, max line length, max page length,
+ BOOL edit status unchanged) ;
+
+TYPE TRANSPUTDIRECTION = INT ;
+
+LET closed = 1 ,
+ in = 2 ,
+ outp = 3 ,
+ mod = 4 ,
+ end = 5 ,
+ escape = ""27"" ,
+
+ nullzustand = " 0 1 1" ,
+
+ max length = 15 000 ; (* < maxint/2 because 2 * maxlength possible*)
+
+
+TRANSPUTDIRECTION PROC input :
+ TRANSPUTDIRECTION : ( in )
+ENDPROC input ;
+
+TRANSPUTDIRECTION PROC output :
+ TRANSPUTDIRECTION : ( outp )
+ENDPROC output ;
+
+TRANSPUTDIRECTION PROC modify :
+ TRANSPUTDIRECTION : ( mod )
+ENDPROC modify ;
+
+LET DATEI = ROW 4075 STRUCT (
+ INT nachfolger, vorgaenger, index, fortsetzung,
+ TEXT inhalt ) ;
+
+LET anker = 2 ,
+ freianker = 1 ;
+
+TEXT VAR number word ;
+
+FILE VAR result file ;
+
+DATASPACE VAR scratch space ;
+close ;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode) :
+
+ IF CONCR (mode) = outp
+ THEN close
+ FI ;
+ sequential file (mode, scratch space)
+
+ENDPROC sequential file ;
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ DATASPACE VAR ds) :
+
+ IF type (ds) = 1002
+ THEN result file.f := ds
+ ELIF type (ds) < 0
+ THEN result file.f := ds ;
+ type (ds, 1002) ;
+ datei initialisieren (CONCR (result file.f))
+ ELSE errorstop ("dataspace has wrong type") ;
+ result file.f := scratch space
+ FI ;
+ result file.mode := CONCR (mode) ;
+ reset (result file) ;
+ result file.max line length := max line length (result file) ;
+ result file.max page length := 0 ;
+
+ result file .
+
+ENDPROC sequential file ;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ TEXT CONST name ) :
+
+ IF exists (name)
+ THEN get dataspace if file
+ ELIF CONCR (mode) <> in
+ THEN get new file space
+ ELSE errorstop ("input file not existing") ;
+ result file.f := scratch space
+ FI ;
+ IF CONCR (mode) <> in
+ THEN status (name, "") ;
+ headline (result file, name)
+ FI ;
+ result file.mode := CONCR (mode) ;
+ reset (result file) ;
+ result file.max line length := max line length (result file) ;
+ result file.max page length := 0 ;
+
+ result file .
+
+get new file space :
+ result file.f := new (name) ;
+ IF NOT is error
+ THEN type (old (name), 1002) ;
+ datei initialisieren ( CONCR (result file.f) )
+ FI .
+
+get dataspace if file :
+ result file.f := old (name, 1002) .
+
+ENDPROC sequential file ;
+
+INT PROC max line length (FILE CONST file) :
+
+ int (subtext (zustand, 16, 20)) .
+
+zustand :
+ CONCR (file.f) (freianker).inhalt .
+
+ENDPROC max line length ;
+
+PROC max line length (FILE VAR file, INT CONST length) :
+
+ replace (zustand, 16, text (length,5)) .
+
+zustand :
+ CONCR (file.f) (freianker).inhalt .
+
+ENDPROC max line length ;
+
+PROC headline (FILE VAR file, TEXT CONST head) :
+
+ CONCR (file.f)(anker).inhalt := head
+
+ENDPROC headline ;
+
+TEXT PROC headline (FILE VAR file) :
+
+ CONCR (file.f)(anker).inhalt
+
+ENDPROC headline ;
+
+PROC copy attributes (FILE CONST source, FILE VAR dest) :
+
+ dest attributes := source attributes ;
+ reset edit status (dest) ;
+ dest headline := source headline .
+
+dest attributes : CONCR (dest.f) (freianker).inhalt .
+source attributes : CONCR (source.f) (freianker).inhalt .
+
+dest headline : CONCR (dest.f) (anker).inhalt .
+source headline : CONCR (source.f) (anker).inhalt .
+
+ENDPROC copy attributes ;
+
+
+PROC input (FILE VAR file) :
+
+ file.mode := in ;
+ reset (file)
+
+ENDPROC input ;
+
+PROC output (FILE VAR file) :
+
+ file.mode := outp ;
+ reset (file)
+
+ENDPROC output ;
+
+PROC modify (FILE VAR file) :
+
+ file.mode := mod ;
+ reset (file)
+
+ENDPROC modify ;
+
+
+PROC putline (FILE VAR file, TEXT CONST record) :
+
+ check mode (file, outp) ;
+ line (file) ;
+ CONCR (file.f)(file.index).inhalt := record ;
+ file.pointer := max length
+
+ENDPROC putline ;
+
+
+PROC getline (FILE VAR file, TEXT VAR record) :
+
+ check mode (file, in) ;
+ line (file) ;
+ record := CONCR (file.f)(file.index).inhalt ;
+ file.pointer := max length
+
+ENDPROC getline ;
+
+
+PROC line (FILE VAR file) :
+
+ file.index := CONCR (file.f) (file.index).nachfolger ;
+ file.pointer := 0 ;
+ IF file.mode = in
+ THEN check eof
+ ELIF file.mode = outp
+ THEN satz erzeugen (CONCR (file.f), file.index) ;
+ CONCR (file.f)(file.index).inhalt := "" ;
+ perhaps implicit page feed
+ FI .
+
+check eof :
+ IF eof
+ THEN file.mode := end
+ FI .
+
+eof : CONCR (file.f)(file.index).nachfolger = anker .
+
+perhaps implicit page feed :
+ file.line counter INCR 1 ;
+ IF file.line counter = file.max page length
+ THEN page (file)
+ FI .
+
+ENDPROC line ;
+
+PROC check mode (FILE CONST file, INT CONST mode) :
+
+ IF file.mode = mode
+ THEN LEAVE check mode
+ ELIF file.mode = closed
+ THEN errorstop ("file not open")
+ ELIF file.mode = mod
+ THEN errorstop ("operation not in transputdirection 'modify'")
+ ELIF mode = mod
+ THEN errorstop ("operation only in transputdirection 'modify'")
+ ELIF file.mode = end
+ THEN IF eof (file) THEN errorstop ("input after end of file") FI
+ ELIF mode = in
+ THEN errorstop ("input access to output file")
+ ELIF mode = outp
+ THEN errorstop ("output access to input file")
+ FI
+
+ENDPROC check mode ;
+
+PROC reset (FILE VAR file) :
+
+ file.pointer := max length ;
+ file.line counter := 0 ;
+ file.edit status unchanged := TRUE ;
+ initialize file index ;
+ set correct file mode .
+
+initialize file index :
+ IF file.mode = outp
+ THEN file.index := last record
+ ELSE file.index := anker
+ FI .
+
+set correct file mode :
+ IF file.mode = end
+ THEN file.mode := in
+ FI ;
+ IF file.mode = in AND empty file
+ THEN file.mode := end
+ FI .
+
+last record : CONCR (file.f) (anker).vorgaenger .
+
+empty file : CONCR (file.f) (anker).nachfolger = anker .
+
+ENDPROC reset ;
+
+BOOL PROC eof (FILE CONST file) :
+
+ IF file.mode = end
+ THEN end of record
+ ELIF file.mode = mod
+ THEN file.index = anker
+ ELSE FALSE
+ FI .
+
+end of record :
+ file.pointer >= length (CONCR (file.f)(file.index).inhalt) .
+
+ENDPROC eof ;
+
+PROC line (FILE VAR file, INT CONST lines) :
+
+ check mode (file, outp) ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO lines REP
+ line (file)
+ PER
+
+ENDPROC line ;
+
+PROC page (FILE VAR file) :
+
+ file.line counter := 0 ;
+ putline (file, "#page")
+
+ENDPROC page ;
+
+BOOL PROC eop (FILE CONST file) :
+
+ CONCR (file.f)(file.index).inhalt = "#page"
+
+ENDPROC eop ;
+
+PROC put (FILE VAR file, TEXT CONST word) :
+
+ check mode (file, outp) ;
+ IF file.pointer + LENGTH word >= file.max line length
+ THEN line (file)
+ FI ;
+ put word (CONCR (file.f)(file.index).inhalt, word, file.pointer)
+
+ENDPROC put ;
+
+PROC put word (TEXT VAR record, TEXT CONST word, INT VAR pointer) :
+
+ IF pointer > 0
+ THEN record CAT " " ;
+ FI ;
+ record CAT word ;
+ pointer := LENGTH record
+
+ENDPROC put word ;
+
+PROC put (FILE VAR f, INT CONST value) :
+
+ put (f, text (value) )
+
+ENDPROC put ;
+
+PROC put (FILE VAR f, REAL CONST real) :
+
+ put (f, text (real) )
+
+ENDPROC put ;
+
+PROC out (FILE VAR file, TEXT CONST word) :
+
+ check mode (file, outp) ;
+ IF file.pointer + LENGTH word >= file.max line length
+ THEN line (file)
+ FI ;
+ record CAT word ;
+ file.pointer INCR LENGTH word .
+
+record : CONCR (file.f)(file.index).inhalt .
+
+ENDPROC out ;
+
+PROC get (FILE VAR file, TEXT VAR word, TEXT CONST separator) :
+
+ check mode (file, in) ;
+ get word (CONCR (file.f)(file.index).inhalt, word,
+ file.pointer, max length, separator)
+
+ENDPROC get ;
+
+PROC get (FILE VAR file, TEXT VAR word, INT CONST max length) :
+
+ check mode (file, in) ;
+ get word (CONCR (file.f)(file.index).inhalt, word,
+ file.pointer, max length, "")
+
+ENDPROC get ;
+
+PROC get (FILE VAR file, TEXT VAR word) :
+
+ check mode (file, in) ;
+ next word (file, CONCR (file.f)(file.index).inhalt, word)
+
+ENDPROC get ;
+
+PROC next word (FILE VAR file, TEXT CONST record, TEXT VAR word) :
+
+ get next non blank char ;
+ IF char found
+ THEN get word (record, word, file.pointer, max length, " ")
+ ELIF last line of file
+ THEN word := "" ;
+ file.pointer := max length
+ ELSE line (file) ;
+ get (file, word)
+ FI .
+
+get next non blank char :
+ TEXT VAR char ;
+ REP
+ file.pointer INCR 1 ;
+ char := record SUB file.pointer
+ UNTIL char <> " " PER ;
+ file.pointer DECR 1 .
+
+char found : char <> "" .
+
+last line of file :
+ CONCR (file.f) (anker).nachfolger = anker .
+
+ENDPROC next word ;
+
+PROC get (FILE VAR f, INT VAR number) :
+
+ get (f, number word) ;
+ number := int (number word)
+
+ENDPROC get ;
+
+PROC get (FILE VAR f, REAL VAR number) :
+
+ get (f, number word) ;
+ number := real (number word)
+
+ENDPROC get ;
+
+PROC get word (TEXT CONST record, TEXT VAR word, INT VAR pointer,
+ INT CONST max length, TEXT CONST separator) :
+
+ INT VAR end of word := pos (record, separator, pointer+1) - 1 ;
+ IF end of word < 0
+ THEN end of word := pointer + max length
+ FI ;
+ word := subtext (record, pointer+1, end of word) ;
+ pointer := end of word + 1
+
+ENDPROC get word ;
+
+PROC close (FILE VAR file) :
+
+ file.mode := closed
+
+ENDPROC close ;
+
+PROC close :
+
+ disable stop ;
+ forget (scratch space) ;
+ scratch space := nilspace
+
+ENDPROC close ;
+
+INT PROC max page length (FILE CONST file) :
+ file.max page length
+ENDPROC max page length ;
+
+PROC max page length (FILE VAR file, INT CONST length) :
+ file.max page length := length
+ENDPROC max page length
+
+
+PROC read record (FILE CONST file, TEXT VAR record) :
+
+ check mode (file, mod) ;
+ record := CONCR (file.f) (file.index).inhalt
+
+ENDPROC read record ;
+
+PROC write record (FILE VAR file, TEXT CONST record) :
+
+ check mode (file, mod) ;
+ CONCR (file.f) (file.index).inhalt := record
+
+ENDPROC write record ;
+
+PROC forward (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.index <> anker
+ THEN file.index := CONCR (file.f) (file.index).nachfolger
+ ELSE errorstop ("forward at eof")
+ FI
+
+ENDPROC forward ;
+
+PROC backward (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := CONCR (file.f) (file.index).vorgaenger ;
+ IF file.index = anker
+ THEN to first record (file) ;
+ errorstop ("backward at first record")
+ FI
+
+ENDPROC backward ;
+
+PROC delete record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.edit status unchanged
+ THEN reset edit status (file)
+ FI ;
+ satz loeschen (CONCR (file.f), file.index)
+
+ENDPROC delete record ;
+
+PROC insert record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.edit status unchanged
+ THEN reset edit status (file)
+ FI ;
+ satz erzeugen (CONCR (file.f), file.index)
+
+ENDPROC insert record ;
+
+PROC to first record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := CONCR (file.f) (anker).nachfolger
+
+ENDPROC to first record ;
+
+PROC to eof (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := anker
+
+ENDPROC to eof ;
+
+BOOL PROC is first record (FILE CONST file) :
+
+ file.index = CONCR (file.f) (anker).nachfolger
+
+ENDPROC is first record ;
+
+PROC reset edit status (FILE VAR file) :
+
+ replace (zustand, 1, nullzustand) ;
+ file.edit status unchanged := FALSE .
+
+zustand : CONCR (file.f)(freianker).inhalt .
+
+ENDPROC reset edit status ;
+
+
+FILE VAR scratch , file ;
+TEXT VAR record ;
+
+LET esc = ""27"" ;
+
+PROC reorganize (TEXT CONST file name) :
+
+ IF exists (file name)
+ THEN last param (file name) ;
+ reorganize file
+ ELSE errorstop ("file does not exist")
+ FI .
+
+reorganize file :
+ scratch := sequential file (output) ;
+ headline (scratch, file name) ;
+ IF format 15
+ THEN set to 16 file type ;
+ file := sequential file (input, file name)
+ ELSE file := sequential file (input, file name) ;
+ copy attributes (file, scratch)
+ FI ;
+
+ disable stop ;
+
+ INT VAR counter := 0 ;
+ WHILE NOT eof (file) REP
+ getline (file, record) ;
+ putline (scratch, record) ;
+ counter INCR 1 ;
+ cout (counter) ;
+ IF is incharety (escape) OR is error
+ THEN close ;
+ LEAVE reorganize
+ FI
+ PER ;
+ forget file ;
+ copy (scratch space, file name) ;
+ close .
+
+forget file :
+ BOOL CONST old status := command dialogue ;
+ command dialogue (FALSE) ;
+ forget (file name) ;
+ command dialogue (old status) .
+
+format 15 : type (old (file name)) = 1001 .
+
+set to 16 file type :
+ type (old (file name), 1002) .
+
+ENDPROC reorganize ;
+
+PROC reorganize :
+
+ reorganize (last param)
+
+ENDPROC reorganize ;
+
+PROC feldout (FILE CONST file, TEXT CONST satz) :
+
+ feldout ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldout ;
+
+PROC feldeinruecken (FILE CONST file, TEXT CONST satz) :
+
+ feldeinruecken ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldeinruecken ;
+
+PROC feldeditor (FILE VAR file, TEXT CONST satz) :
+
+ feldeditor ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldeditor ;
+
+INT PROC pos (FILE CONST file, TEXT CONST pattern, INT CONST from) :
+
+ pos ( CONCR (file.f) (file.index).inhalt, pattern, from )
+
+ENDPROC pos ;
+
+PROC change (FILE VAR file, INT CONST from, to, TEXT CONST new) :
+
+ change ( CONCR (file.f) (file.index).inhalt, from, to, new )
+
+ENDPROC change ;
+
+TEXT PROC subtext (FILE CONST file, INT CONST from) :
+
+ record := subtext ( CONCR (file.f) (file.index).inhalt, from ) ;
+ record
+
+ENDPROC subtext ;
+
+TEXT PROC subtext (FILE CONST file, INT CONST from, to) :
+
+ record := subtext ( CONCR (file.f) (file.index).inhalt, from, to ) ;
+ record
+
+ENDPROC subtext ;
+
+(* sortieren sequentieller Dateien Autor: P.Heyderhoff *)
+ (* Stand: 14.11.80 *)
+
+BOUND DATEI VAR datei;
+INT VAR sortierstelle, sortanker, byte;
+TEXT VAR median, tausch ;
+
+PROC sort (TEXT CONST dateiname) :
+ sortierstelle := feldanfang; sort (dateiname, "")
+ END PROC sort;
+
+PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) :
+ sortierstelle := sortieranfang; sort (dateiname, "")
+ END PROC sort;
+
+PROC sort (TEXT CONST dateiname, feldname) :
+ IF exists (dateiname)
+ THEN datei := old (dateiname);
+ IF CONCR(datei) (freianker).nachfolger <> freianker
+ THEN reorganize (dateiname)
+ FI ;
+ sortanker := 3;
+ IF feldname = ""
+ THEN byte := 0
+ ELSE feldname in feldnummer uebersetzen
+ FI;
+ quicksort(sortanker, CONCR(datei)(freianker).fortsetzung-1)
+ FI .
+feldname in feldnummer uebersetzen :
+ byte := pos (CONCR(datei) (sortanker).inhalt, feldname);
+ IF byte > 0
+ THEN byte := pos (CONCR(datei) (sortanker).inhalt, code(255-byte))
+ FI;
+ IF byte = 0
+ THEN errorstop ("sort: feldname"); LEAVE sort
+ FI ; sortanker INCR 1 .
+ END PROC sort;
+
+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, merkmal m) .
+
+ 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 subtext (datei p, merkmal p) <= median ELSE FALSE FI .
+
+ q kann kleiner werden :
+ IF q >= anfang THEN subtext(datei q,merkmal q) >= median 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 .
+
+ merkmal m :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei m SUB byte) FI .
+
+ merkmal p :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei p SUB byte) FI .
+
+ merkmal q :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei q SUB byte) FI .
+
+ datei m : CONCR(datei)(m).inhalt .
+ datei p : CONCR(datei)(p).inhalt .
+ datei q : CONCR(datei)(q).inhalt .
+
+END PROC spalte;
+
+
+(*********** schrott ************)
+
+OP := (FILE VAR a, FILE CONST b) :
+ EXTERNAL 294
+ENDOP := ;
+
+PROC becomes (ROW 8 INT VAR a, b) :
+ INTERNAL 294 ;
+ a := b
+ENDPROC becomes ;
+
+PROC datei initialisieren (DATEI VAR datei) :
+ EXTERNAL 290 ;
+END PROC datei initialisieren;
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+ENDPACKET file ;
diff --git a/system/base/unknown/src/init b/system/base/unknown/src/init
new file mode 100644
index 0000000..02b8e74
--- /dev/null
+++ b/system/base/unknown/src/init
@@ -0,0 +1,250 @@
+ " Compiler Error : "
+" "
+" |"
+" Fehler entdeckt "
+"Keine Fehler gefunden, "
+" Sekunden CPU-Zeit verbraucht"
+" ******* ENDE DER UEBERSETZUNG *******"
+"FEHLER bei >> "
+" << "
+"weiter bei "
+" (" ") "
+"EOF im Programm"
+"EOF beim Skippen"
+"EOF im TEXT Denoter"
+"EOF im Kommentar"
+"' nach Bold fehlt"
+"das MAIN PACKET muss das letzte sein"
+"ungueltiger Name fuer ein Interface 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 Endes des MAIN PACKET"
+"ENDPROC fehlt"
+"PROC/OP Schachtelung unzulaessig"
+"OP darf kein Parameter sein"
+"steht mehrfach im PACKET Interface"
+"Mehrfachdeklaration"
+"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"
+"Dieser Typ ist schon definiert"
+"ungueltiger Deklarierer"
+"ungueltiger OP Name"
+"OP muss monadisch oder dyadisch sein"
+"ist nicht der OP Name"
+"ENDOP fehlt"
+"Name nach ENDPROC fehlt"
+"Name nach ENDOP fehlt"
+"END END ist Unsinn"
+"Diese 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 initialisert werden"
+"'::' verwenden"
+"')' fehlt"
+"Nachkommastellen fehlen"
+"Exponent fehlt"
+"Undefinierter Typ"
+"Rekursiv definierter Typ"
+"Mehrfach definierter Selektor"
+"VARs koennen aus dem Paket nicht herausgereicht werden"
+"NO SHORTHAND DECLARATION IN THIS SCOPE FOR ROW SIZE DENOTER."
+"Typ Deklarationen nur im Paketrumpf"
+"CONST bzw. VAR ohne Zusammenhang"
+"ist nicht deklariert, steht aber in der Paket-Schnittstelle"
+"ist nicht deklariert"
+"Typ ist schon deklariert"
+"THIS IS NO CORRECT EXTERNAL NUMBER."
+" EXTERNAL und INTERNAL 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"
+"Textende fehlt"
+
+"Denoter-Wert wird fuer diese Maschine zu gross"
+"NOBODY SHOULD EVER WRITE THAT, Uli ! "
+"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"
+"Mit ELIF kann kein IF-Statement beginnen"
+"INT - Ausdruck erwartet"
+"OF fehlt"
+"Keine Typanpassung moeglich"
+"CASE - Label fehlt"
+"CASE - Label ist zu gross (skipped)"
+"mehrfach definiertes CASE-Label"
+"ungueltiges Zeichen nach CASE-Label"
+" OTHERWISE PART fehlt"
+"END SELECT fehlt"
+"DEAR USER, PLEASE BE REMINDED OF NOT CALLING REFINEMENTS RECURSIVLY !"
+"Dieses Refinement wird nicht benutzt"
+"Zwischen diesen Symbolen fehlt ein Operator oder ein ';'"
+"undefinierter monadischer Operator"
+"undefinierter dyadischer Operator"
+"Operator vor '(' fehlt"
+"kann nicht redefiniert werden"
+"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen"
+"fuer diesen Typ nicht definierter Selektor"
+"Primitive Typen koennen nicht selektiert werden"
+"bei ROWs nur Subscription"
+"ungueltiger Selectand"
+"unzulaessiger Index fuer Subscription"
+"'[' ohne Zusammenhang"
+"']' ohne Zusammenhang"
+"']' nach Subscription fehlt"
+"',' ungueltig zwischen UNITs"
+"':' ungueltig zwischen UNITs"
+"';' fehlt"
+"nur die letzte UNIT einer SECTION darf einen Wert liefern"
+"Der Paketrumpf kann keinen Wert liefern"
+"anstelle des letzten Symbols wurde ein Operand erwartet"
+"Der Schleifenrumpf darf keinen Wert liefern"
+"INT VAR erwartet"
+"wird schon in einer aeusseren Schleife als Laufvariable benutzt"
+"FROM erwartet"
+"UPTO bzw DOWNTO fehlt"
+"REPEAT fehlt"
+"END REP fehlt"
+"UNTIL ohne Zusammenhang"
+"Die Konstante darf nicht mit ':=' 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"
+"Es gibt keine Prozedur mit diesen Parametern"
+"unbekannte Parameter-Prozedur"
+"VIRTUAL PARAM MODE INCONSISTENCE"
+"INCONSISTENCE BETWEEN THE PARAMETERS OF THE ACTUAL AND THE FORMAL PARAM PROC
+EDURE "
+"nicht deklariertes Objekt"
+"THIS OBJECT IS USED OUTSIDE IT'S RANGE"
+"Kein TYPE DISPLAY moeglich, da die Feinstruktur hier unbekannt ist"
+"zu wenig Felder angegeben"
+"zu viele Felder angegeben"
+"unzulaessiger Trenner zwischen Feldern"
+"Dies Feld hat einen falschen Typ"
+"THIS ROW DISPLAY DOES NOT HAVE THE CORRECT NUMBER OF ELEMENTS."
+"Dieser Typ kann nicht noch mehr konkretisiert werden"
+
+"Warnung in Zeile"
+" Zeile "
+"in Zeile "
+"<----+--->"
+" TYPE undefiniert "
+" MODE undefiniert "
+"Parameter spezifiziert "
+"Parameter Typ(en) sind "
+" B Code, "
+" B Paketdaten generiert"
+"Operandentyp"
+"Typ des linken Operanden "
+"Typ des rechten Operanden "
+"erwartet "
+"gefunden "
+ "NULL 1TEST 1NOT 2INCR 1DECR
+ 1MOV2 2MOV8 2MOVS 2EQI 2LSEQI
+ 2EQR 2LSEQR 2COMPLI 2COMPLR 2ADDI
+ 3SUBI 3MULTI 3DIVI 3ADDR 3SUBR
+ 3MULTR 3DIVR 3AND 2OR 2BRANCH
+8BTRUE 8BFALSE 8ACCDS 2ALIAS 5RETURN
+0MOVE 3CASE 3SUBS 5SUBS2 4SUBS8
+ 4SUBS16 4SEL 3BSTL 6ESTL 7HEAD
+ 1PACKET 1BOOL 1NBOOL 1"
+
+(*000 *) END INTERNAL BOUND
+(*001 *) PACKET
+(*002 *) ENDPACKET
+(*003 *) DEFINES
+(*003 A*) LET
+(*004 *) PROCEDURE
+(*005 *) PROC
+(*006 *) ENDPROC
+(*006A *) ENDPROCEDURE
+(*007 *) OPERATOR
+(*008 *) OP
+(*009 *) ENDOP
+(*009A *) ENDOPERATOR
+(*010 *) TYPE
+(*011 *) INT
+(*012 *) REAL
+(*013 *) DATASPACE
+(*015 *) TEXT
+(*016 *) BOOL
+(*017 *) CONST
+(*018 *) VAR
+(* INIT CONTROL *) INTERNAL
+(*019 *) ROW
+(*0191 *) STRUCT CONCR
+(*0193*) ACTUAL
+(*020 *) REP
+(*020A *) REPEAT
+(*021 *) ENDREP
+(*021A *) ENDREPEAT PER
+(*022 *) SELECT
+(*023 *) ENDSELECT
+(*0235 *) EXTERNAL
+(*024 *) IF (*024A *) ENDIF
+(*021 *) THEN
+(*022 *) ELIF
+(*023 *) ELSE
+(*024 *) FI
+(*026 *) OF
+(*026A *) CASE
+(*027 *) OTHERWISE
+(*029 *) FOR
+(*030 *) FROM
+(*031 *) UPTO
+(*032 *) DOWNTO
+(*034 *) UNTIL
+(*035 *) WHILE
+(*036 *) LEAVE WITH
+(*0361 *) TRUE
+(*362 *) FALSE
+(*038 *) :: SBL = := INCR DECR
+(*039 *) + - * / 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 ;
+ out (t)
+ENDPROC out text ;
+
+PROC out line (INT CONST typ) :
+ INTERNAL 258 ;
+ out (""13""10"")
+ENDPROC out line ;
+
+ENDPACKET a ;
diff --git a/system/base/unknown/src/integer b/system/base/unknown/src/integer
new file mode 100644
index 0000000..0e1d19d
--- /dev/null
+++ b/system/base/unknown/src/integer
@@ -0,0 +1,134 @@
+
+PACKET integer DEFINES
+ sign, SIGN, abs, ABS, **, min, max, maxint,
+ get, random, initialize random :
+
+INT PROC maxint : 32767 ENDPROC maxint ;
+
+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 errorstop ("INT OP ** : negative exponent") FI ;
+ IF arg = 0 AND exp = 0
+ THEN errorstop (" 0 ** 0 is not defined")
+ FI ;
+ IF exp = 0 THEN x := 1 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 ;
+
+
+PROC get (INT VAR number) :
+
+ get (word) ;
+ number := int (word)
+
+ENDPROC get ;
+
+TEXT VAR word := "" ;
+
+
+
+(************************************************)
+(*** ***)
+(*** generator 32 650 ***)
+(*** ***)
+(************************************************)
+
+(* INT-Zufallsgenerator mit Periode 32650 *) (*Autor: Bake *)
+ (*Gymnasium Aspe *)
+
+INT VAR z1 :: 14, (* fuer den generator mit periode 25 *)
+ z2 :: 345; (* fuer den generator mit periode 1306 *)
+
+
+ INT PROCEDURE random (INT CONST ugrenze, ogrenze) :
+ (*******************************************************)
+
+generator 25;
+generator 1306;
+(zufallszahl MOD intervallgroesse) + ugrenze.
+
+(* Durch MOD wird bei grosser 'intervallgroesse' der vordere
+ Bereich doppelt ueberdeckt, also keine Gleichverteilung. heinrichs
+ 24.04.81 *)
+
+
+ generator 25 :
+z1 := (11 * z1 + 18) MOD 25
+(* erster generator. liefert alle zahlen zwischen 0 und 24. *).
+
+ generator 1306 :
+z2 := (24 * z2 + 23) MOD 1307
+(* zweiter generator. liefert alle zahlen zwischen 0 und 1305. *).
+
+ zufallszahl :
+z1 + z2 * 25 (* diese zahl liegt zwischen 0 und 32 649 *).
+
+ intervallgroesse : ogrenze - ugrenze + 1
+
+END PROC random ;
+
+
+ PROCEDURE initialize random (INT CONST wert) :
+(**************************************************)
+
+z1 := wert MOD 25;
+z2 := wert MOD 1306
+
+END PROC initialize random ;
+
+ENDPACKET integer ;
diff --git a/system/base/unknown/src/mathlib b/system/base/unknown/src/mathlib
new file mode 100644
index 0000000..be44ff6
--- /dev/null
+++ b/system/base/unknown/src/mathlib
@@ -0,0 +1,359 @@
+
+PACKET mathlib DEFINES sqrt,**,exp,ln,log2,log10,sin,cos,
+ tan,arctan,sind,cosd,tand,arctand,e,pi,
+ random,initializerandom :
+
+
+REAL VAR rdg::0.4711;
+
+REAL PROC pi:
+ 3.141592653589793.
+END PROC pi;
+
+REAL PROC e:
+ 2.718281828459045.
+END PROC e;
+
+REAL PROC ln(REAL CONST x):
+LET ln2= 0.6931471805599453;
+log2(x)*ln2.
+END PROC ln;
+
+REAL PROC log2(REAL CONST z):
+INT VAR k::0,p::0;
+REAL VAR m::0.0,x::z,t::0.0,summe::0.0;
+IF x>0.0
+THEN normal
+ELSE errorstop("log2 mit negativer zahl");4711.4711
+FI.
+normal:
+ IF x>=0.5
+ THEN normalise downwards
+ ELSE normalise upwards
+ FI;
+ IF x>=0.1 AND x< 0.7071067811865475 THEN
+ t:=(x-0.5946035575013605)/(x+0.5946035575013605);
+ summe:=reihenentwicklung (t) - 0.75
+ FI;
+ IF x>=0.7071067811865475 AND x < 1.0 THEN
+ t:=(x - 0.8408964152537145)/(x+0.8408964152537145);
+ summe:= reihenentwicklung(t)-0.25
+ FI;
+ summe-real(p - 4*k).
+
+ normalise downwards:
+ WHILE x>= 16.0 REP
+ x:=x/16.0;k:=k+1;
+ END REP;
+ WHILE x>=0.5 REP
+ x:=x/2.0;p:=p-1;
+ END REP.
+
+ normalise upwards:
+ WHILE x<=0.0625 REP
+ x:=x*16.0;k:=k-1;
+ END REP;
+ WHILE x<= 0.5 REP
+ x:=x*2.0;p:=p+1;
+ END REP.
+
+END PROC log2;
+
+REAL PROC reihenentwicklung(REAL CONST x):
+ REAL VAR i::39.0,s::1.0/39.0;
+ LET ln2=0.6931471805599453;
+ WHILE i>1.0 REP
+ i:=i-2.0;s:=s*x*x + 1.0/i;
+ END REP;
+ s*2.0*x/ln2.
+END PROC reihenentwicklung;
+
+REAL PROC log10(REAL CONST x):
+ LET lg2=0.301029995664;
+ log2(x)*lg2.
+END PROC log10;
+
+REAL PROC sqrt(REAL CONST z):
+ REAL VAR y0,y1,x::z;
+ INT VAR p::0;
+ BOOL VAR q::FALSE;
+ IF x<0.0
+ THEN errorstop("sqrt von negativer zahl");0.0
+ ELSE correct
+ FI.
+
+ correct:
+ IF x=0.0
+ THEN 0.0
+ ELSE nontrivial
+ FI.
+
+ nontrivial:
+ IF x<0.01
+ THEN small
+ ELSE notsmall
+ FI.
+
+
+ notsmall:
+ IF x>1.0
+ THEN big
+ ELSE normal
+ FI.
+
+ small:
+ WHILE x<0.01 REP
+ p:=p-1;x:=x*100.0;
+ END REP;
+ normal.
+
+ big:
+ WHILE x>=1.0 REP
+ p:=p+1;x:=x/100.0;
+ END REP;
+ normal.
+
+ normal:
+ IF x<0.1
+ THEN x:=x*10.0;q:=TRUE
+ FI;
+ y0:=10.0**p*(1.681595-1.288973/(0.8408065+x));
+ IF q
+ THEN y0:=y0/3.162278
+ FI;
+ y1:=(y0+z/y0)/2.0;
+ y0:=(y1+z/y1)/2.0;
+ y1:=(y0+z/y0)/2.0;
+ (y1-z/y1)/2.0+z/y1.
+
+END PROC sqrt;
+
+REAL PROC exp(REAL CONST z):
+ REAL VAR c,d,x::z, a, b ;
+ IF x<-180.2187
+ THEN 0.0
+ ELIF x<0.0
+ THEN 1.0/exp(-x)
+ ELIF x=0.0
+ THEN 1.0
+ ELSE x:=x/0.6931471805599453;approx
+ FI.
+
+ approx:
+ a:=floor(x/4.0)+1.0;
+ b:=floor(4.0*a-x);
+ c:=(4.0*a-b-x)*16.0;
+ d:=(c -floor(c))/16.0;
+ d:=d*0.6931471805599453;
+ ( (16.0 POWER a) / (2.0 POWER b) / (1.044273782427419 POWER c ))*
+ ((((((0.135910788320380e-2*d-0.8331563191293753e-2)*d
+ +0.4166661437490328e-1)*d-0.1666666658727157)*d+0.4999999999942539)*d
+ - 0.9999999999999844)*d+1.0).
+
+ENDPROC exp ;
+
+REAL OP POWER (REAL CONST basis, exponent) :
+
+ IF floor (exponent) = 0.0
+ THEN 1.0
+ ELSE power
+ FI .
+
+power :
+ REAL VAR counter := floor (abs (exponent)) - 1.0 ,
+ result := basis ;
+ WHILE counter > 0.0 REP
+ result := result * basis ;
+ counter := counter - 1.0
+ PER ;
+ IF exponent > 0.0
+ THEN result
+ ELSE 1.0 / result
+ FI .
+
+ENDOP POWER ;
+
+REAL PROC tan (REAL CONST x):
+ REAL VAR p;
+ p:=1.273239544735168*ABSx;
+ tg(p)*sign(x).
+END PROC tan;
+
+REAL PROC tand(REAL CONST x):
+ REAL VAR p;
+ p:=0.02222222222222222*ABSx;
+ tg(p)*sign(x).
+END PROC tand;
+
+REAL PROC tg(REAL CONST x):
+ REAL VAR r,s,u,q;
+ q:=floor(x);r:=x-q;
+ IF q = floor(q/2.0) * 2.0
+ THEN s:=r
+ ELSE s:=(1.0-r)
+ FI;
+ q:= q - floor(q/4.0) * 4.0 ;
+ u:=s*s;
+ s:=s*0.785398163397448;
+ s:=s/(((((((((-0.4018243865271481e-10*u-0.4404768172667185e-9)*u-
+ 0.748183650813680e-8)*u-0.119216115119129e-6)*u-0.1909255769212821e-5)*u-
+0.3064200638849133e-4)*u-0.4967495424202482e-3)*u-0.8455650263333471e-2)*u-
+ 0.2056167583560294)*u+1.0);
+ IF q=0.0
+ THEN s
+ ELIF q=3.0
+ THEN -s
+ ELIF q=1.0
+ THEN 1.0/s
+ ELSE -1.0/s
+ FI .
+
+END PROC tg;
+
+REAL PROC sin(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x*1.273239544735168;
+ q:=int(y);
+ r:=y-real(q);
+ IF x<0.0
+ THEN q:=q+4
+ FI;
+ sincos(q,r).
+END PROC sin;
+
+REAL PROC sind(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABSx/45.0;
+ q:=int(y);
+ r:=y-real(q);
+ IF x<0.0
+ THEN q:=q+4
+ FI;
+ sincos(q,r).
+END PROC sind;
+
+
+REAL PROC cos(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x*1.273239544735168;
+ q:=int(y);
+ r:=y-real(q);
+ q:=q+2;
+ sincos(q,r).
+END PROC cos;
+
+REAL PROC cosd(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x/45.0;
+ q:=int(y);
+ r:=y-real(q);
+ q:=q+2;
+ sincos(q,r).
+END PROC cosd;
+
+
+REAL PROC sincos(INT VAR q,REAL VAR r):
+ SELECT q MOD 8 + 1 OF
+ CASE 1 : sin approx(r)
+ CASE 2 : cos approx (1.0-r)
+ CASE 3 : cos approx(r)
+ CASE 4 : sin approx(1.0-r)
+ CASE 5 : - sin approx(r)
+ CASE 6 : - cos approx(1.0-r)
+ CASE 7 : - cos approx(r)
+ CASE 8 : - sin approx(1.0-r)
+ OTHERWISE 0.0
+ END SELECT
+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.313361621667256
+8
+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 x):
+REAL VAR z::x*x;
+IF x<0.0 THEN -arctan(-x)
+ELIF x>1.0 THEN 3.141592653589792/2.0-arctan(1.0/x)
+ELIF x*1.0e16>2.67949192431e15 THEN pi/6.0+arctan(1.732050807568877-4.0
+/(x+1.732050807568877))
+ELSE x/(((((((0.0107090276046822*z-0.01647757182108040)*z
+ +0.02177846332482151)*z-0.03019339673273880)*z+0.04656083561183398)*z
+ -0.0888888888888888)*z+0.3333333333333333)*z+1.0)FI.
+END PROC arctan;
+
+REAL PROC arctand(REAL CONST x):
+ arctan(x)/3.1415926589793*180.0.
+END PROC arctand;
+
+
+BOOL PROC even(INT CONST number):
+ (number DIV 2)*2=number.
+END PROC even;
+
+REAL OP **(REAL CONST base,exponent):
+ IF base<0.0
+ THEN errorstop("hoch mit negativer basis")
+ FI;
+ IF base=0.0
+ THEN test exponent
+ ELSE
+ exp(exponent*ln(base))
+ FI.
+
+ test exponent:
+ IF exponent=0.0
+ THEN errorstop("0**0 geht nicht");4711.4711
+ ELSE 0.0
+ FI.
+
+END OP **;
+
+
+REAL PROC sign(REAL CONST number):
+ IF number >0.0 THEN 1.0
+ ELIF number <0.0 THEN -1.0
+ ELSE 0.0
+ FI.
+END PROC sign ;
+
+REAL OP **(REAL CONST a,INT CONST b):
+REAL VAR p::1.0,r::a;INT VAR n::ABS b;
+WHILE n>0 REP
+ IF n MOD 2=0
+ THEN n:=n DIV 2;r:=r*r
+ ELSE n DECR 1;p:=p*r
+ FI;
+END REP;
+IF b>0
+THEN p
+ELSE 1.0/p
+FI.
+END OP **;
+
+
+
+REAL PROC random:
+rdg:=rdg+pi;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=frac(rdg);rdg.
+END PROC random;
+
+
+PROC initializerandom(REAL CONST z):
+ rdg:=z;
+END PROC initializerandom;
+
+END PACKET mathlib;
diff --git a/system/base/unknown/src/real b/system/base/unknown/src/real
new file mode 100644
index 0000000..a2ab9c3
--- /dev/null
+++ b/system/base/unknown/src/real
@@ -0,0 +1,378 @@
+
+PACKET real DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.04.80 *)
+ text ,
+ int ,
+ real ,
+ round ,
+ floor ,
+ frac ,
+ INCR ,
+ DECR ,
+ abs ,
+ ABS ,
+ sign ,
+ SIGN ,
+ MOD ,
+ min ,
+ max ,
+ put ,
+ get ,
+ max real ,
+ small real :
+
+LET mantissa length = 13 ;
+
+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 ;
+ set exp (decimal exponent (result) - digits, result) .
+
+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 :
+ result CAT subtext (short mantissa, 1, exponent+1) ;
+ result CAT (exponent+1 - LENGTH short mantissa) * "0" ;
+ result CAT "." ;
+ IF exponent < 0
+ THEN result + (-exponent-1) * "0" + short mantissa
+ ELSE result + subtext (short mantissa, exponent+2)
+ 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 ;
+
+PROC put (REAL CONST real) :
+
+ put (text (real) )
+
+ENDPROC put ;
+
+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 ;
+ check correct conversion ;
+ 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 := 0.0 ;
+ INT VAR exponent pos := 0 ;
+ WHILE pos <= LENGTH text REP
+ TEXT VAR digit := text SUB pos ;
+ IF digit <= "9" AND digit >= "0"
+ THEN value := value * 10.0 + real digit (code (digit) - 47) ;
+ pos INCR 1
+ ELIF digit = "."
+ THEN pos INCR 1 ;
+ exponent pos := pos
+ ELSE LEAVE mantissa part
+ FI
+ END REP .
+
+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))
+ FI .
+
+check correct conversion :
+ 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 ;
+
+TEXT VAR word ;
+
+PROC get (REAL VAR value) :
+
+ get (word) ;
+ value := real (word)
+
+ENDPROC get ;
+
+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 left < 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) :
+
+ 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 ;
+
+ IF value < 0.0
+ THEN - result
+ ELSE result
+ FI
+
+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/unknown/src/scanner b/system/base/unknown/src/scanner
new file mode 100644
index 0000000..ed04699
--- /dev/null
+++ b/system/base/unknown/src/scanner
@@ -0,0 +1,255 @@
+
+PACKET scanner DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.12.81 *)
+ scan ,
+ continue scan ,
+ next symbol ,
+ fix scanner ,
+ reset scanner :
+
+
+LET tag = 1 ,
+ bold = 2 ,
+ integer = 3 ,
+ text = 4 ,
+ operator= 5 ,
+ delimiter = 6 ,
+ end of file = 7 ,
+ within comment = 8 ,
+ within text = 9 ;
+
+
+TEXT VAR line := "" ,
+ char := "" ;
+
+INT VAR position := 0 ,
+ reset position ,
+ 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 ;
+ next non blank char ;
+ reset position := position
+
+ENDPROC continue scan ;
+
+PROC fix scanner :
+
+ reset position := position
+
+ENDPROC fix scanner ;
+
+PROC reset scanner :
+
+ position := reset position ;
+ char := line SUB position
+
+ENDPROC reset scanner ;
+
+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 ;
+ symbol := "" ;
+ IF is niltext THEN eof
+ ELIF is comment THEN process comment
+ ELIF is 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 integer
+ ELIF is delimiter THEN process delimiter
+ ELSE process operator
+ FI .
+
+skip blanks :
+ IF char = " "
+ THEN next non blank char
+ FI .
+
+
+process comment :
+ read comment ;
+ IF comment depth = 0
+ THEN next symbol (symbol, type)
+ ELSE type := within comment
+ FI .
+
+process tag :
+ type := tag ;
+ REP
+ symbol CAT char ;
+ next non blank char
+ UNTIL NOT (is lower case letter OR is digit) ENDREP .
+
+process bold :
+ type := bold ;
+ REP
+ symbol CAT char ;
+ next char
+ UNTIL NOT is upper case letter ENDREP .
+
+process integer :
+ type := integer ;
+ REP
+ symbol CAT char ;
+ next non blank char
+ UNTIL NOT (is digit OR char = ".") ENDREP .
+
+process text :
+ type := text ;
+ IF continue text
+ THEN continue text := FALSE
+ ELSE next char
+ FI ;
+ WHILE not end of text REP
+ symbol CAT char ;
+ next char
+ 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 TRUE
+ ELIF is digit
+ THEN get special char ; TRUE
+ ELSE FALSE
+ FI .
+
+get special char :
+ TEXT VAR special symbol ;
+ next symbol (special symbol) ;
+ char := code ( int (special symbol ) ) .
+
+process delimiter :
+ type := delimiter ;
+ symbol := char ;
+ next non blank char .
+
+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 : char lies in (97, 122) .
+
+is upper case letter : char lies in (65, 90) .
+
+is digit : char lies in (48, 57) .
+
+is delimiter : pos ( "()[].,;" , char ) > 0 AND char <> "" .
+
+is relational double char :
+ TEXT VAR double := symbol + char ;
+ double = "<>" OR double = "<=" OR double = ">=" .
+
+is text : is quote OR continue text .
+
+is quote : char = """" .
+
+is niltext : char = "" .
+
+is comment :
+ IF comment depth = 0
+ THEN char = "{" OR char = "(" AND ahead char = "*"
+ ELSE comment depth DECR 1 ; TRUE
+ FI .
+
+ENDPROC next symbol ;
+
+PROC next char :
+
+ position INCR 1 ;
+ char := line SUB position
+
+ENDPROC next char ;
+
+PROC next non blank char :
+
+ REP
+ position INCR 1
+ UNTIL (line SUB position) <> " " ENDREP ;
+ char := line SUB position
+
+ENDPROC next non blank char ;
+
+TEXT PROC ahead char :
+
+ line SUB position+1
+
+ENDPROC ahead char ;
+
+BOOL PROC char lies in (INT CONST lower bound, upper bound) :
+
+ lower bound <= code(char) AND code(char) <= upper bound
+
+ENDPROC char lies in ;
+
+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 nonblank char .
+
+is end comment :
+ char = "}" OR char = ")" AND last char = "*" .
+
+is begin comment :
+ char = "{" OR char = "(" AND ahead char = "*" .
+
+ENDPROC read comment ;
+
+ENDPACKET scanner ;
diff --git a/system/base/unknown/src/stdescapeset b/system/base/unknown/src/stdescapeset
new file mode 100644
index 0000000..0c69ea7
--- /dev/null
+++ b/system/base/unknown/src/stdescapeset
@@ -0,0 +1,31 @@
+PACKET std escape set (* Autor: P.Heyderhoff *)
+ (************) (* Stand: 20.01.1981 *)
+ (* Vers.: 1.5.5 *)
+DEFINES std escape set :
+
+PROC std escape set :
+
+ define escape ("p", "IFmark>0THEN PUT"""";W""""12""""FI") ;
+ define escape ("g", "GET"""";M0") ;
+ define escape ("d", "IFmark>0THEN PUT"""";M0ELSE GET"""";M0FI");
+ define escape ("B", "W""""194""""") ;
+ define escape ("A", "W""""193""""") ;
+ define escape ("O", "W""""207""""") ;
+ define escape ("U", "W""""213""""") ;
+ define escape ("a", "W""""225""""") ;
+ define escape ("o", "W""""239""""") ;
+ define escape ("u", "W""""245""""") ;
+ define escape ("z", "C1;""""C(((limit-len)/2)*"" "")") ;
+ define escape ("l", "i:=col;C1;M1;Ci;W""""12""""") ;
+ define escape ("h", "S11") ;
+ define escape ("v", "S23") ;
+ define escape ("1", "1;C1");
+ define escape ("9", "9999;C(len+1)");
+ define escape (""2"", """ """);
+ define escape (""10"","+1;R Clen;"" ""Ucol>lenE");
+ define escape (""3"", "R-1;Hrow;Clen;"" ""Ucol>lenE");
+ define escape (""8"", "COL(col-10)");
+
+ENDPROC std escape set ;
+
+ENDPACKET std escape set ;
diff --git a/system/dos/1986/doc/DSKDOS.ELA b/system/dos/1986/doc/DSKDOS.ELA
new file mode 100644
index 0000000..69bc714
--- /dev/null
+++ b/system/dos/1986/doc/DSKDOS.ELA
@@ -0,0 +1,967 @@
+#type ("17.klein")#
+prefix of extended fcb:
+
+ offset size name
+ -7 1 flag byte 255
+ -6 5 reserved
+ -1 1 attribute byte 2=hidden file, 4=system file
+
+normal fcb format:
+
+ offset size name
+ 0 1 drive number 0=default (for open), 1=A, 2=B
+ 1 8 filename 8 chars, left aligned and padded
+ (if necessary) with blanks
+ 9 3 extension 3 chars, left aligned and padded
+ (if necessary) with blanks
+ 12 2 current block pointer to the block of 128 records
+ containing the current record
+ (0 after open)
+ 14 2 record size logical record size in bytes
+ (128 after open, changed eventually)
+ 16 4 file size file size in bytes (1. byte low)
+ 20 2 date of last write 20:mmmddddd 21:yyyyyyym
+ 22 2 time of last write 22:mmmsssss 23:hhhhhmmm
+ 24 8 reserved
+ 32 1 current record pointer to one of the 128 records in
+ the block (not initialized by open)
+ must be set before sequential read/write
+ 33 4 relative record pointer to selected record
+ (counting from the beginning of file by 0)
+ not initialized by open
+ must be set before sequential read/write
+ record size less than
+ 64 bytes: both words used
+ else only first 3 bytes
+
+fields of directory entry:
+
+ offset size name
+ 0 8 filename 8 chars, left aligned and padded
+ (if necessary) with blanks
+ special use of first byte:
+ 0 : end of allocated directory
+ 229: free directory entry
+ 8 3 extension 3 chars, left aligned and padded
+ (if necessary) with blanks
+ 11 1 attributes 1: read only file
+ 2: hidden file
+ 4: system file
+ 8: entry is the volume's id
+ 16: entry is subdirectory's name
+ 32: archive bit (set, when written to)
+ 12 10 reserved
+ 22 2 time of last write 22:mmmsssss 23:hhhhhmmm
+ 24 2 date of last write 24:mmmddddd 25:yyyyyyym
+ 26 2 reserved
+ 28 4 file size file size in bytes (1. byte low)
+
+directory structure:
+
+ - the root directory has a fixed number of entries
+ - entries that represent a subdirectory have a special attribute in their
+ entry set
+ - the subdirectories are themselves files which records are of the same type
+ as those in the root directory
+ - the number of entries in subdirectories are not limited
+ - the length of a path to a subdirectory is not limited
+
+application of the directory entry fields on subdirectory entries:
+
+ volume id : present at root, only one entry has this attribute
+ directory : the directory entry represents itself an directory
+ read only : meaningless
+ archive : meaningless
+ hidden/system: prevents directories from beeing found, function $3B
+ will still work
+
+ms-dos interrupts:
+
+ $20 : program terminate
+ call:
+ CS: segment address
+ terminates process, returns control to parent process,
+ file handles are closed, disk cache cleaned, file buffers flushed
+ programm terminate, alt-c and critical error addresses are restored
+ new programs should use function $4C
+ $21 : function request
+ call:
+ AH: function number
+ other registers dependent on function
+ $22 to $24 :
+ address locations for msdos use
+ can be changed by function $25
+ $22 : terminate address
+ $23 : alt-c exit address
+ address of an alt-c routine
+ $24 : fatal error abort address
+ address of the error handler
+ BP:SI can contain further information
+ not called if error occurs during absolute disk operations (int $25,$26)
+ $25 : absolute disk read
+ call:
+ AL: drive number
+ DS:BX: disk transfer address
+ CX: number of sectors
+ DX: beginning relative sector
+ return:
+ CF: 0=successful
+ 1=unsuccessful
+ AL: error code if unsuccessful
+ $26 : absolute disk write
+ call:
+ AL: drive number
+ DS:BX: disk transfer address
+ CX: number of sectors
+ DX: beginning relative sector
+ return:
+ CF: 0=successful
+ 1=unsuccessful
+ AL: error code if unsuccessful
+ $27 : terminate but stay resident
+ call:
+ CS:DX: first byte following the code
+ new programms should use function $31
+
+ms-dos function requests:
+
+ $00 : terminate program
+ call:
+ AH: $00
+ CS: segment of programm prefix
+ $01 : read keyboard and echo
+ call:
+ AH: $01
+ return:
+ AL: character typed
+ waits for input, echos and returns it
+ alt-c will call interrupt
+ $02 : display character
+ call:
+ AH: $02
+ DL: character to be displayed
+ alt-c will call interrupt
+ $03 : auxiliary input
+ call:
+ AH: $03
+ return:
+ AL: character from auxiliary device
+ waits for input, alt-c will call interrupt
+ $04 : auxiliary output
+ call:
+ AH: $04
+ DL: character to output
+ alt-c will call interrupt
+ $05 : print character
+ call:
+ AH: $05
+ DL: character for printer
+ alt-c will call interrupt
+ $06 : direct console i/o
+ call:
+ AH: $06
+ DL: $FF: check for keyboard input
+ otherwise: display DL on screen
+ return:
+ ZF: 0=no char available
+ 1=char was read
+ AL: char if read
+ $07 : direct konsole input
+ call:
+ AH: $07
+ return:
+ AL: character from keyboard
+ waits for character
+ $08 : read keyboard
+ call:
+ AH: $08
+ return:
+ AL: character from keyboard
+ waits for character, alt-c will call interrupt
+ $09 : display string
+ call:
+ AH: $09
+ DS:DX: string, ending with '$'
+ $0A : buffered keyboard input
+ call:
+ AH: $0A
+ DS:DX: input buffer
+ byte 1: maximum number of chars in buffer (with CR)
+ 2: actual number of chars in buffer (set by function)
+ 3-n: must be at least as long as the max
+ waits for chars, allows editing, ignores overflow,
+ alt-c will call interrupt
+ $0B : check keyboard status
+ call:
+ AH: $0B
+ return:
+ AL: 0=no chars in type-ahead buffer
+ 255=chars available
+ $0C : flush buffer and read keyboard
+ call:
+ AH: $0C
+ AL: $01,$06,$07,$08 or $0A: corresponding function is called
+ other values: no further processing
+ return:
+ AL: 0=type ahead buffer was flushed, no processing performed
+ $0D : disk reset
+ call:
+ AH: $0D
+ all disk buffers are flushed, no directory updates performed
+ $0E : select disk
+ call:
+ AH: $0E
+ DL: drive number, 1=A, 2=B, ..
+ return:
+ AL: number of logical drives
+ $0F : open file
+ call:
+ AH: $0F
+ DS:DX: unopened fcb
+ return:
+ AL: 0=directory entry found
+ if drive code was 0, it is set to the default
+ current block is set to 0
+ record size is set to 128
+ file size, time and date of last modification are set
+ from directory
+ the default record size must be set, if not 128
+ before performing a sequential (random) operation,
+ current record (relative record) field must be set
+ 255=no directory entry found
+
+ $10 : close file
+ call:
+ AH: $10
+ DS:DX: opened fcb
+ return:
+ AL: 0=directory entry found
+ 255=no directory entry found
+ $11 : search for first entry
+ call:
+ AH: $11
+ DS:DX: unopened fcb
+ return:
+ 0=directory entry found
+ fcb (normal or extended) is created
+ at the disk transfer address
+ 255=no directory entry found
+ to search for hidden or system files, the fcb must be extended
+ see notes on search attributes
+ $12 : search for next entry
+ call:
+ AH: $12
+ DS:DX: unopened fcb
+ return:
+ AL: 0=directory entry found
+ fcb (normal or extended) is created
+ at the disk transfer address
+ 255=no directory entry found
+ the fcb must be one used previously in a call to $11
+ $13 : delete file
+ call:
+ AH: $13
+ DS:DX: unopened fcb
+ return:
+ AL: 0=directory entry found
+ 255=no directory entry found
+ deletes all files with matching names
+ $14 : sequential read
+ call:
+ AH: $14
+ DS:DX: opened fcb
+ return:
+ AL: 0=read completed successfully
+ 1=eof, no data in the record
+ 2=dta too small, not enough space to read without exceeding
+ the segment boundaries, read cancelled
+ 3=eof, partial record was read and padded to the record
+ length with zeros
+ the record pointed to by the current block and current record
+ is loaded to the disk transfer address and the fields are incremented
+ $15 : sequential write
+ call:
+ AH: $15
+ DS:DX: opened fcb
+ return:
+ AL: 0=write completed successfully
+ 1=disk full, write canceled
+ 2=dta too small to write one record without exceeding the
+ segment boundaries, write canceled
+ the record pointed to by the current block and current record
+ are written from the disk transfer address and the fields are incremented
+ $16 : create file
+ call:
+ AH: $16
+ DS:DX: unopened fcb
+ return:
+ AL: 0=empty directory entry found
+ 255=no empty entry available and file didn't exist before
+ if the file does already exist, it is made a zero length file
+ else it is created if an empty entry is found
+ $17 : rename file
+ call:
+ AH: $17
+ DS:DX: modified fcb
+ return:
+ AL: 0=directory entry found
+ 255=no directory entry found or destination already exists
+ the fcb must contain the search file name and another file name
+ at offset $11
+ $19 : current disk
+ call:
+ AH: $19
+ return:
+ AL: selected drive (0=A, 1=B, .. )
+ $1A : set disk transfer address
+ call:
+ AH: $1A
+ DS:DX: disk transfer address
+ default is $80 in the psp
+ $21 : random read
+ call:
+ AH: $21
+ DS:DX: opened fcb
+ return:
+ 0=read completed successfully
+ 1=eof, no data read
+ 2=dta too small, read canceled
+ 3=eof, partial record, padded with zeros
+ the current block and current record fields are set to match the
+ relative record field, then the record is loaded
+ $22 : random write
+ call:
+ AH: $22
+ DS:DX: opened fcb
+ return:
+ AL: 0=write completed successfully
+ 1=disk full
+ 2=dta too small, read canceled
+ $23 : file size
+ call:
+ AH: $23
+ DS:DX: unopened fcb
+ return:
+ AL: 0=directory entry found
+ the relative record field is set to the number
+ of records in the file
+ 255=no directory entry found
+ the record size field must be set
+ $24 : set relative record
+ call:
+ AH: $24
+ DS:DX: opened fcb
+ the relative record field is set to the same record as the current block
+ an the current record field
+ $25 : set vector
+ call:
+ AH: $25
+ AL: interrupt number
+ DS:DX: interrupt handling routine
+ $27 : random block read
+ call:
+ AH: $27
+ DS:DX: opened fcb
+ CX: number of blocks to read
+ return:
+ AL: 0=read completed successfully
+ 1=eof, no data read
+ 2=end of segment, read canceled
+ 3=eof, partial record, padded with zeros
+ CX: number of blocks read
+ the reading starts at the relative record
+ the current block, current record and relative record field are updated
+ $28 : random block write
+ call:
+ AH: $28
+ DS:DX: opened fcb
+ CX: number of records to write
+ 0=set file size
+ the file size field of thedirectory entry is set to the number
+ of records specified by the relative record field
+ return:
+ AL: 0=write completed successfully
+ 1=disk full, no records written
+ 2=end of dta-segment, read canceled
+ CX: number of blocks written
+ the writing starts at the relative record
+ the current block, current record and relative record field are updated
+ $29 : parse file name
+ call:
+ AH: $29
+ AL: controls parsing
+ bit 0: if file separators are encountered
+ (: . ; , = + / " [ ] \ < ] | blank tab)
+ 0: all parsing stops
+ 1: leading separators are ignored
+ bit 1: if the string does not contain a drive letter
+ 0: the fcb drive number is set to 0 (default)
+ 1: the fcb drive number is not changed
+ bit 2: if the string does not contain a filename
+ 0: the fcb filename is set to 8 blanks
+ 1: the fcb filename is not changed
+ bit 3: if the string does not contain an extension
+ 0: the fcb extension is set to three blanks
+ 1: the fcb extension is not changed
+ DS:SI: string to parse
+ filename terminators include all filename separators
+ plus any control character
+ ES:DI: if the string contained a valid filename,
+ it points to an unopened fcb
+ else ES:DI+1 points to a blank
+ return:
+ AL: 0=no wild card characters
+ 1=wild card characters used
+ 255=drive letter invalid
+ DS:SI: first byte past string that was parsed
+ if the filename contains an asterisk,
+ all folowing letters are set to question mark
+ ES:DI: unopened fcb
+ if filename is found, an unopened fcb is created here
+ $2A : get date
+ call:
+ AH: $2A
+ return:
+ CX: year (1980-2099)
+ DH: month (1-12)
+ DL: day (1-31)
+ AL: day of week (0=sun, .., 6=sat)
+ $2B : set date
+ call:
+ AH: $2B
+ CX: year (1980-2099)
+ DH: month (1-12)
+ DL: day (1-31)
+ return:
+ AL: 0=date was valid
+ 255=date was invalid
+ $2C : get time
+ call:
+ AH: $2C
+ return:
+ CH: hour (0-23)
+ CL: minutes (0-59)
+ DH: seconds (0-59)
+ DL: hundredths (0-99)
+ $2D : set time
+ call:
+ AH: $2D
+ CH: hour (0-23)
+ CL: minutes (0-59)
+ DH: seconds (0-59)
+ DL: hundredths (0-99)
+ return:
+ AL: 0=time was valid
+ 255=time was invalid
+ $2E : set/reset verify flag
+ call:
+ AH: $2E
+ AL: 0=do not verify
+ 1=verify
+ $2F : get disk transfer address
+ call:
+ AH: $2F
+ return:
+ ES:BX: points to disk transfer address
+ $30 : get dos version number
+ call:
+ AH: $30
+ return:
+ AL: major version number
+ AH: minor version number
+ $31 : keep process
+ call:
+ AH: $31
+ AL: exit code
+ DX: memory size in paragraphs
+ attemts to set the initial allocation block to a specific size
+ in paragraphs, will not free up other allocation blocks belonging
+ to that process, the exit code is available via function $4D
+ $33 : alt-c check
+ call:
+ AH: $33
+ AL: function
+ 0=request current state
+ 1=set state
+ DL: if setting
+ 0=off
+ 1=on
+ return:
+ AL: 255=al parameter was not in range 0..1
+ DL: if requesting current state
+ 0=off
+ 1=on
+ if check is on, every system call executes the check,
+ else only the device operations
+ $35 : get interrupt vector
+ call:
+ AH: $35
+ AL: interrupt number
+ return:
+ ES:BX: pointer to interrupt routine
+ $36 : get disk free space
+ call:
+ AH: $36
+ DL: drive (0=default, .....)
+ return:
+ BX: available clusters
+ DX: clusters per drive
+ CX: bytes per sector
+ AX: $FFFF=drive number invalid
+ otherwise sectors per cluster
+ $38 : return country-dependent information
+ call:
+ AH: $38
+ DS:DX: pointer to 32 byte memory area
+ area format:
+ size name
+ 2 date/time format
+ 0=usa standard h:m:s m/d/y
+ 1=europe standard h:m:s d/m/y
+ 2=japan standard y/m/d h:m:s
+ 5 asciz currency symbol
+ 2 asciz thousands separator
+ 2 asciz decimal separator
+ 2 asciz date separator
+ 2 asciz time separator
+ 1 bit field
+ bit 0: 0=currency symbol precedes amount
+ 1=symbol comes after amount
+ bit 1: 0=symbol immediately precedes the amount
+ 1=space between symbol and amount
+ 1 currency places
+ figures after decimal point of currency amounts
+ 1 time format
+ 0=12 hour time
+ 1=24 hour time
+ 4 case mapping call
+ FAR procedure performs country-specific
+ lower- to uppercase mapping
+ 2 asciz data list separator
+ if dx=-1 and the country code in AL is found,
+ the current country is set accordingly
+
+ AL: function code
+ 0=current country
+ or country code (usually international telephone prefix)
+ must be 0 in msdos 2.0 (only fully implemented after 2.01)
+ return:
+ CARRY: 1
+ AX: 2=file not found
+ CARRY: 0
+ DS:DX: filled with country data
+ $39 : create subdirectory
+ call:
+ AH: $39
+ DS:DX: pointer to pathname (asciz)
+ return:
+ CARRY: 1
+ AX: 3=path not found
+ 5=access denied
+ no room in parent,
+ directory already exists or device was specified
+ CARRY: 0=no error
+ $3A : remove a directory entry
+ call:
+ AH: $3A
+ DS:DX: pointer to pathname (asciz)
+ return:
+ CARRY: 1
+ AX: 3=path not found
+ 5=access denied
+ directory not empty, not a directory, root directory
+ 16=current directory
+ CARRY: 0=no error
+ $3B : change the current directory
+ call:
+ AH: $3B
+ DS:DX: pointer to pathname (asciz)
+ return:
+ CARRY: 1
+ AX: 3=path not found
+ CARRY: 0=no error
+ $3C : create a file
+ call:
+ AH: $3C
+ DS:DX: pointer to pathname
+ CX: file attribute
+ return:
+ CARRY: 1
+ AX: 3=path not found
+ 4=too many open files
+ file was created, but no room for handle
+ 5=access denied
+ uncreatable attribute (directory or volume id),
+ a file with a more inklusive attribute set exists,
+ or a directory with the same name exists
+ CARRY: 0
+ AX is handle number
+ handle is open for read/write
+ creates a new file or truncates existing to length 0
+ $3D : open a file
+ call:
+ AH: $3D
+ DS:DX: pointer to pathname (asciz)
+ AL: access
+ 0=open for reading
+ 1=open for writing
+ 2=open for both
+ return:
+ CARRY: 1
+ AX: 2=file not found
+ 4=too many open files
+ no file handles available
+ 5=access denied
+ attempted to open a directory, volume id or
+ a read only file for writing
+ 12=invalid access
+ AL was not in range 0..2
+ CARRY: 0
+ AX is handle number
+ read/write pointer is set to the first byte of the file
+ and the record size is set to 1
+ the returned file handle must be used in subsequent operations
+ $3E : close a file handle
+ call:
+ AH: $3E
+ BX: file handle
+ return:
+ CARRY: 1
+ 6=invalid handle (not currently open)
+ CARRY: 0=no error
+ the associated file is closed, buffers are flushed
+ $3F : read from file/device
+ call:
+ AH: $3F
+ DS:DX: pointer to buffer
+ CX: bytes to read
+ BX: file handle
+ return:
+ CARRY: 1
+ AX: 5=access denied
+ not opened for read
+ 6=invalid handle (not currently open)
+ CARRY: 0
+ AX: number of bytes read
+ 0=eof
+ $40 : write to file/device
+ call:
+ AH: $40
+ DS:DX: pointer to buffer
+ CX: bytes to write
+ if 0, the file size is set to the current position
+ BX: file handle
+ return:
+ CARRY: 1
+ AX: 5=access denied
+ 6=invalid handle
+ CARRY: 0
+ AX: number of bytes written
+ is error if not the same number as requested
+ $41 : delete a directory entry
+ call:
+ AH: $41
+ DS:DX: pointer to pathname
+ return:
+ CARRY: 1
+ AX: 2=file not found
+ 5=access denied
+ directory or read only
+ CARRY: 0=no error
+ $42 : move file pointer
+ call:
+ AH: $42
+ CX:DX: distance to move, in bytes
+ AL: method of moving
+ 0=move pointer to offset from beginning of file
+ 1=move to offset from current location
+ 2=move to offset from eof
+ BX: file handle
+ return:
+ CARRY: 1
+ AX: 1=invalid function
+ AL not in range 0..2
+ 6=invalid handle
+ CARRY 0:
+ DX:AX: new pointer location
+ moves the read/write file pointer
+ $43 : change attributes
+ call:
+ AH: $43
+ DS:DX: pointer to pathname (asciz)
+ AL: function
+ 0=return in CX
+ 1=set to CX
+ CX: if AL=1
+ attribute to be set
+ return:
+ CARRY: 1
+ AX: 1=invalid function
+ AL not in range 0..1
+ 3=path not found
+ 5=access denied
+ CX contained attributes that can not be changed
+ (directory, volume id)
+ CARRY: 0
+ if AL=0
+ CX: attributes
+ $44 : i/o control for devices
+ call:
+ AH: $44
+ BX: handle
+ BL: (for calls AL=4, 5) drive: 0=default, ..
+ DS:DX: data or buffer
+ CX: bytes to read or write
+ AL: function code
+ calls 0,1: bits of DX (DH must be 0 on a set call)
+ 0: iscin
+ 1: iscot
+ 2: isnul
+ 3: isclk
+ 4: specl
+ 5: raw
+ 6: eof
+ 7: isdev
+ 8-13: reserved
+ 14: ctrl
+ 15: res
+ if isdev=0 then channel is a disk file
+ eof: 0=channel has been written
+ bits 0-5 are block device number for the channel
+ (0=a, 1=b, ..)
+ if isdev=1 then channel is device
+ eof : 0=end of file on input
+ raw : 0=this device is cooked
+ 1=device in raw mode
+ isclk: 1=clock
+ isnul: 1=nul
+ iscot: 1=console output
+ iscin: 1=console input
+ specl: 1=device is special
+ ctrl : 0=device can not do control strings
+ via calls 2,3
+ 1=can do control
+ 0=get device information (returned in DX)
+ 1=set device information (according to DX)
+ calls 2,5: arbitrary control strings sent or received
+ to or from a device
+ call syntax is the same as in read/write calls,
+ except for 4 and 5, which take drive number in BL
+ instead of a handle in BX
+ an invalid function error is returned, if
+ the ctrl bit is 0
+ 2=read CX number of bytes to DS:DX from device control channel
+ 3=write CX number of bytes from DS:DX to device control channel
+ 4=read CX number of bytes to DS:DX from device control channel
+ drive number in BL (0=default, ..)
+ 5=write CX number of bytes from DS:DX to device control channel
+ drive number in BL (0=default, ..)
+ calls 6,7: check, if a file handle is ready for i/o
+ intended for status of handles associated with
+ devices, but checks of file handles are allowed
+ and defined: input: always ready (255), until eof
+ then always not ready (0)
+ output: always ready
+ 6=get input status
+ 7=get output status
+ return:
+ CARRY: 1
+ AX: 1=invalid function
+ 5=access denied
+ 6=invalid handle
+ 13=invalid data
+ CARRY: 0
+ AL: 2,3,4,5
+ AX: count transferred
+ AL: 6,7
+ 0=not ready
+ 255=ready
+ sets or gets device information associated with an open handle
+ or sends or receives a control string to or from a device handle or device
+ if the function is used for files, only functions 0,6,7 are defined
+ $45 : duplicate a file handle
+ call:
+ AH: $45
+ BX: file handle
+ return:
+ CARRY: 1
+ AX: 4=too many files open
+ 6=invalid handle
+ CARRY: 0
+ AX: new file handle
+ retruns a new handle that refers to the same file
+ $46 : force a duplicate of a handle
+ call:
+ AH: $46
+ BX: existing file handle
+ CX: new file handle
+ return:
+ CARRY: 1
+ AX: 4=too many open files
+ 6=invalid handle
+ CARRY: 0=no error
+ CX then refers to the same file as BX, eventually, CX is closed first
+ $47 : return text of current directory
+ call:
+ AH: $47
+ DS:SI: pointer to 64 byte area
+ DL: drive number (0=default, ..)
+ return:
+ CARRY: 1
+ AX: 15=invalid drive
+ CARRY: 0=no error
+ the path name does not contain the leading separators
+ $48 : allocate memory
+ call:
+ AH: $48
+ BX: size of memory to be allocated
+ return:
+ CARRY: 1
+ AX: 7=arena trashed
+ internal consistency has been destroyed
+ 8=not enough memory
+ BX: maximum size that could be allocated
+ CARRY: 0
+ AX:0: pointer to the allocated memory
+ $49 : free allocated memory
+ call:
+ AH: $49
+ ES: segment address of memory area to be freed
+ return:
+ CARRY: 1
+ AX: 7=arena trashed
+ internal consistency has been destroyed
+ 9=invalid block
+ the block was not allocated by $49
+ CARRY: 0=no error
+ returns a piece of memory to the system pool that was allocated with $49
+ $4A : modify allocated memory blocks
+ call:
+ AH: $4A
+ ES: segment address of memory area
+ BX: requested memory area
+ return:
+ CARRY: 1
+ AX: 7=arena trashed
+ internal consistency has been destroyed
+ 8=not enough memory
+ 9=invalid block
+ the block was not allocated by $49
+ BX: maximum size possible
+ CARRY: 0=no error
+ attempts to grow or shrink an allocated block
+ $4B : load and execute a program
+ call:
+ AH: $4B
+ DS:DX: pointer to pathname (asciz)
+ ES:BX: pointer to parameter block
+ for AL=0:
+ size name
+ 2 segment address of environment
+ 4 pointer to command line at $80
+ 4 pointer to default fcb to be passed at $5C
+ 4 pointer to default fcb to be passed at $6C
+ for AL=3:
+ size name
+ 2 segment address where file will be loaded
+ 2 relocation factor to be applied to the image
+ AL: 0=load and execute
+ 3=load (overlay)
+ return:
+ CARRY: 1
+ AX: 1=invalid function
+ AL was not in range 0,3
+ 2=file not found
+ 8=not enough memory
+ 10=bad environment
+ larger than 32K
+ 11=bad format
+ EXE file contained inconsistent information
+ CARRY: 0=no error
+ all open files of a parent are copied to the child process
+ also inherited is an environment (block of text strings less than 32K)
+ a zero environment address causes the child to inherit then parents
+ environment unchanged
+ $4C : terminate process
+ call:
+ AH: $4C
+ AL: return code
+ $4D : retrieve then return code of a child
+ call:
+ AH: $4D
+ return:
+ AX: exit code
+ high byte: 0=terminate/abort
+ 1=alt-c
+ 2=hard error
+ 3=terminate and stay resident
+ returns code only once
+ $4E : find match file
+ call:
+ AH: $4E
+ DS:DX: pointer to pathname
+ CX: search attributes
+ return:
+ CARRY: 1
+ AX: 2=file not found
+ 18=no more files
+ CARRY: 0=no error
+ data block is written to current dma address:
+ size name
+ 21 reserved for subsequent calls
+ 1 attribute found
+ 2 time
+ 2 date
+ 2 low(size)
+ 2 high(size)
+ 13 packed name
+ subsequent calls: see $4F
+ $4F : step through a directory matching files
+ call:
+ AH: $4F
+ return:
+ CARRY: 1
+ AX: 18=no more files
+ CARRY: 0=no error
+ only used for subsequent calls after $4E
+ dma address must point to the parablock
+ $54 : return current setting of verify after write flag
+ call:
+ AH: $54
+ return:
+ current verify flag value
+ $56 : move a directory entry
+ call:
+ AH: $56
+ DS:DX: pointer to pathname of existing file
+ ES:DI: pointer to new pathname
+ return:
+ CARRY: 1
+ AX: 2=file not found
+ 5=access denied
+ path is directory or new file exists
+ or directory entry could not be created
+ 17=not same device
+ CARRY: 0=no error
+ attempts to rename a file in the directory of one device
+ $57 : get/set date/time of file
+ call:
+ AH: $57
+ AL: 0=get date and time
+ 1=set date and time
+ BX: file handle
+ CX: if AL=1
+ time to be set
+ DX: if AL=1
+ date to be set
+ return:
+ CARRY: 1
+ AX: 1=invalid function
+ 6=invalid handle
+ CARRY: 0=no error
+ CX: if AL=0
+ time
+ DX: if AL=0
+ date
+ date and time are not recorded until file is closed
+
diff --git a/system/dos/1986/src/252 b/system/dos/1986/src/252
new file mode 100644
index 0000000..b4369b6
--- /dev/null
+++ b/system/dos/1986/src/252
Binary files differ
diff --git a/system/dos/1986/src/253 b/system/dos/1986/src/253
new file mode 100644
index 0000000..c7a4494
--- /dev/null
+++ b/system/dos/1986/src/253
Binary files differ
diff --git a/system/dos/1986/src/254 b/system/dos/1986/src/254
new file mode 100644
index 0000000..f71eeb6
--- /dev/null
+++ b/system/dos/1986/src/254
Binary files differ
diff --git a/system/dos/1986/src/255 b/system/dos/1986/src/255
new file mode 100644
index 0000000..d21b649
--- /dev/null
+++ b/system/dos/1986/src/255
Binary files differ
diff --git a/system/dos/1986/src/COND.TXT b/system/dos/1986/src/COND.TXT
new file mode 100644
index 0000000..02cb949
--- /dev/null
+++ b/system/dos/1986/src/COND.TXT
@@ -0,0 +1,5 @@
+FLOPPY = TRUE
+HDU = FALSE
+TEST = FALSE
+DOS = TRUE
+CPM = FALSE
diff --git a/system/dos/1986/src/block i-o b/system/dos/1986/src/block i-o
new file mode 100644
index 0000000..4336746
--- /dev/null
+++ b/system/dos/1986/src/block i-o
@@ -0,0 +1,104 @@
+PACKET disk block io DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ (* 25.03.86 *)
+ read disk block,
+ read disk cluster,
+ write disk block,
+ write disk cluster,
+ io error,
+ first non dummy ds page:
+
+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,
+ INT VAR error):
+ check rerun;
+ read block (ds, ds page no, eublock (block no), error).
+
+END PROC read disk block;
+
+PROC read disk block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no):
+ check rerun;
+ read block (ds, ds page no, eublock (block no), error);
+ IF error <> 0
+ THEN io error (error)
+ FI.
+
+END PROC read disk block;
+
+PROC read disk block (DATASPACE VAR ds,
+ INT CONST block no):
+ read disk block (ds, first non dummy ds page, block no)
+
+END PROC read disk block;
+
+PROC read disk cluster (DATASPACE VAR ds,
+ INT CONST first ds page no,
+ INT CONST cluster no):
+ INT VAR i;
+ FOR i FROM 0 UPTO sectors per cluster - 1 REP
+ read disk block (ds, first ds page no + i, block no + i)
+ PER.
+
+block no:
+ first block no of cluster (cluster no).
+
+END PROC read disk cluster;
+
+PROC write disk block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR error):
+ check rerun;
+ write block (ds, ds page no, 0,eu block (block no), error).
+
+END PROC write disk block;
+
+PROC write disk block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no):
+ check rerun;
+ write block (ds, ds page no, 0, eu block (block no), error);
+ IF error <> 0
+ THEN io error (error)
+ FI.
+
+END PROC write disk block;
+
+PROC write disk block (DATASPACE CONST ds,
+ INT CONST block no):
+ write disk block (ds, first non dummy ds page, block no)
+
+END PROC write disk block;
+
+PROC write disk cluster (DATASPACE CONST ds,
+ INT CONST first ds page no,
+ INT CONST cluster no):
+ INT VAR i;
+ FOR i FROM 0 UPTO sectors per cluster - 1 REP
+ write disk block (ds, first ds page no + i, block no + i)
+ PER.
+
+block no:
+ first block no of cluster (cluster no).
+
+END PROC write disk cluster;
+
+PROC io error (INT CONST error code):
+ SELECT error code OF
+ CASE 1: errorstop ("Laufwerk nicht betriebsbereit")
+ CASE 2: errorstop ("Schreib-/Lesefehler")
+ CASE 3: errorstop ("Interner Fehler (Blocknummer zu hoch)")
+ CASE 4: errorstop ("Block nicht lesbar")
+ OTHERWISE errorstop ("Schreib-/Lesefehler " + text (error))
+ END SELECT.
+
+END PROC io error;
+
+END PACKET disk block io;
diff --git a/system/dos/1986/src/cluster b/system/dos/1986/src/cluster
new file mode 100644
index 0000000..ef2720b
--- /dev/null
+++ b/system/dos/1986/src/cluster
@@ -0,0 +1,109 @@
+PACKET cluster DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ (* 19.03.86 *)
+
+ CLUSTER,
+ :=,
+ text,
+ text 32, (* typical dir entry *)
+ write text,
+ write text 32,
+ reduce cluster buffer:
+
+LET max cluster size = 8192; (* 8192 * 8 = 64 KB *)
+
+TYPE CLUSTER = BOUND STRUCT (ALIGN dummy,
+ ROW max cluster size REAL cluster row);
+
+TEXT VAR string;
+INT VAR string length;
+
+INT VAR sector no, eight byte pos, index;
+
+reduce cluster buffer;
+
+.reals per sector: sector size DIV 8.
+.reals per std eu sector: 512 DIV 8.
+
+PROC reduce cluster buffer:
+ string := 32 * "*";
+ string length := 32.
+
+END PROC reduce cluster buffer;
+
+OP := (CLUSTER VAR cluster, DATASPACE VAR ds):
+ CONCR (cluster) := ds
+
+END OP :=;
+
+TEXT PROC text (CLUSTER CONST cluster, INT CONST from, to):
+ init string;
+ FOR sector no FROM 0 UPTO sectors per cluster - 1 REP
+ get text of sector
+ PER;
+ subtext (string, from, to).
+
+init string:
+ IF string length < cluster size
+ THEN string := cluster size * "*";
+ string length := cluster size
+ FI.
+
+get text of sector:
+ FOR eight byte pos FROM 1 UPTO reals per sector REP
+ replace (string, string index, cluster.cluster row [row index])
+ PER.
+
+string index:
+ reals per sector * sector no + eight byte pos.
+
+row index:
+ reals per std eu sector * sector no + eight byte pos.
+
+END PROC text;
+
+TEXT PROC text 32 (CLUSTER CONST cluster, INT CONST part):
+ FOR index FROM 1 UPTO 4 REP
+ replace (string, index, cluster.cluster row [index + 4 * part])
+ PER;
+ subtext (string, 1, 32).
+
+END PROC text 32;
+
+PROC write text (CLUSTER VAR cluster,
+ TEXT CONST string):
+ IF LENGTH string < cluster size
+ THEN execute write text (cluster, text (string, cluster size))
+ ELSE execute write text (cluster, string)
+ FI.
+
+END PROC write text;
+
+PROC execute write text (CLUSTER VAR cluster,
+ TEXT CONST string):
+ FOR sector no FROM 0 UPTO sectors per cluster - 1 REP
+ write text of sector
+ PER.
+
+write text of sector:
+ FOR eight byte pos FROM 1 UPTO reals per sector REP
+ cluster.cluster row [row index] := string RSUB (string index)
+ PER.
+
+row index:
+ reals per std eu sector * sector no + eight byte pos.
+
+string index:
+ reals per sector * sector no + eight byte pos.
+
+
+END PROC execute write text;
+
+PROC write text 32 (CLUSTER VAR cluster, TEXT CONST string, INT CONST part):
+ FOR index FROM 1 UPTO 4 REP
+ cluster.cluster row [index + 4 * part] := string RSUB (index)
+ PER;
+
+END PROC write text 32;
+
+END PACKET cluster;
diff --git a/system/dos/1986/src/disk descriptor.dos.fd b/system/dos/1986/src/disk descriptor.dos.fd
new file mode 100644
index 0000000..660dd46
--- /dev/null
+++ b/system/dos/1986/src/disk descriptor.dos.fd
@@ -0,0 +1,290 @@
+PACKET dos disk DEFINES (* Copyright (C) 1985, 86 *)
+ (* Frank Klapper *)
+ first fat byte, (* 30.05.86 *)
+ begin of fat,
+ number of fat sectors,
+ number of fat entrys,
+ number of fat copies,
+ begin of dir,
+ number of dir sectors,
+ begin of data area,
+ sectors per cluster,
+ cluster size,
+ sector size,
+
+ eublock,
+ first block no of cluster,
+
+ reset disk attributes,
+ set disk attributes:
+
+LET dir entrys per block = 16,
+ first non dummy ds page = 2;
+
+LET DOSDISK = STRUCT (INT sectors per cluster,
+ number of reserved sectors,
+ number of fats,
+ number of dir sectors,
+ first fat byte,
+ number of fat sectors,
+ heads,
+ sectors per track,
+ tracks,
+ number of fat entrys,
+ REAL size);
+
+LET BLOCK = BOUND STRUCT (ALIGN dummy, ROW 64 REAL block row);
+
+INT CONST sector size :: 512;
+
+TEXT VAR bpb := 32 * " ";
+
+INITFLAG VAR bpb ds used := FALSE;
+
+DATASPACE VAR bpb ds;
+
+BLOCK VAR bpb block;
+
+DOSDISK VAR disk format;
+BOUND DOSDISK VAR format table;
+
+INT VAR eu sectors,
+ xbegin of data area;
+
+INT PROC eublock (INT CONST nr):
+(*COND FLOPPY*)
+ 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:
+ nr MOD disk format.sectors per track.
+
+trac:
+ (nr DIV disk format.sectors per track) DIV disk format.heads.
+
+head:
+ (nr DIV disk format.sectors per track) MOD disk format.heads.
+
+eu sectors per head:
+ eu sectors * eu tracks.
+
+(*ENDCOND*)
+(*COND HDU
+ nr
+
+ENDCOND*)
+
+END PROC eublock;
+
+INT PROC first block no of cluster (INT CONST cluster no):
+ IF cluster no < 2
+ THEN error stop ("interner Fehler")
+ FI;
+ begin of data area + (cluster no - 2) * sectors per cluster.
+
+END PROC first block no of cluster;
+
+INT PROC first fat byte:
+ disk format.first fat byte
+
+END PROC first fat byte;
+
+INT PROC number of fat copies:
+ disk format.number of fats
+
+END PROC number of fat copies;
+
+INT PROC number of fat sectors:
+ disk format.number of fat sectors
+
+END PROC number of fat sectors;
+
+INT PROC number of fat entrys:
+ disk format.number of fat entrys
+
+END PROC number of fat entrys;
+
+INT PROC number of dir sectors:
+ disk format.number of dir sectors
+
+END PROC number of dir sectors;
+
+INT PROC begin of fat (INT CONST no):
+ disk format.number of reserved sectors + no * disk format.number of fat sectors
+
+END PROC begin of fat;
+
+INT PROC begin of dir:
+ disk format.number of reserved sectors +
+ disk format.number of fats * disk format.number of fat sectors
+
+END PROC begin of dir;
+
+INT PROC begin of data area:
+ xbegin of data area
+
+END PROC begin of data area;
+
+INT PROC sectors per cluster:
+ disk format.sectors per cluster
+
+END PROC sectors per cluster;
+
+INT PROC cluster size:
+ disk format.sectors per cluster * 512
+
+END PROC cluster size;
+
+PROC set disk attributes (INT CONST first fat byte):
+ enable stop;
+(*COND FLOPPY*)
+ get bios parameter block;
+ IF is valid bpb
+ THEN load disk data from bpb
+ ELSE load disk disk data from ds
+ FI;
+ eu sectors := eu last sector - eu first sector +1;
+(*ENDCOND*)
+ xbegin of data area := disk format.number of reserved sectors +
+ disk format.number of fats * disk format.number of fat sectors +
+ disk format.number of dir sectors;
+(*COND FLOPPY*)
+ test compatibility
+
+.is valid bpb:
+ first fat byte < 252 OR code (bpb SUB 22) = first fat byte.
+
+load disk disk data from ds:
+ IF exists (text (first fat byte))
+ THEN format table := old (text (first fat byte));
+ copy values
+ ELSE error stop ("DOS-Diskettenformat nicht implementiert")
+ FI.
+
+copy values:
+ disk format.sectors per cluster := format table.sectors per cluster;
+ disk format.number of reserved sectors := format table.number of reserved sectors;
+ disk format.number of fats := format table.number of fats;
+ disk format.size := format table.size;
+ disk format.number of dir sectors := format table.number of dir sectors;
+ disk format.first fat byte := format table.first fat byte;
+ disk format.number of fat sectors := format table.number of fat sectors;
+ disk format.heads := format table.heads;
+ disk format.sectors per track := format table.sectors per track;
+ disk format.tracks := format table.tracks;
+ disk format.number of fat entrys := format table.number of fat entrys.
+
+test compatibility:
+ IF disk format.sectors per track > eu sectors
+ OR eu tracks <> disk format.tracks
+ OR abs (eu heads) < disk format.heads
+ OR disk format.number of reserved sectors <> 1
+ THEN error stop ("DOS-Format auf diesem Diskettenlaufwerk nicht lesbar")
+ FI;
+(*ENDCOND*)
+
+END PROC set disk attributes;
+
+PROC reset disk attributes:
+(*COND FLOPPY*)
+ disk format.sectors per cluster := 1;
+ disk format.number of reserved sectors := 1;
+ disk format.number of fats := 1;
+ disk format.size := real (eu size);
+ disk format.number of dir sectors := 4;
+ disk format.first fat byte := 255;
+ disk format.number of fat sectors := 1;
+ disk format.heads := eu heads;
+ disk format.sectors per track := eu tracks;
+ disk format.tracks := eu sectors;
+ disk format.number of fat entrys := 100.
+
+(*ENDCOND*)
+(*COND HDU
+ get bios parameter block;
+ load disk data from bpb (248).
+
+ENDCOND*)
+
+END PROC reset disk attributes;
+
+PROC get bios parameter block:
+ init bpb ds;
+ read bpb;
+ copy bpb block to bpb text.
+
+init bpb ds:
+ IF NOT initialized (bpb ds used)
+ THEN bpb ds := nilspace;
+ bpb block := bpb ds
+ FI.
+
+read bpb:
+ INT VAR error;
+ read block (bpb ds, first non dummy ds page, 0, error);
+ IF error <> 0
+ THEN SELECT error OF
+ CASE 1: errorstop ("Floppylaufwerk nicht betriebsbereit")
+ CASE 2: errorstop ("Schreib-/Lesefehler")
+ CASE 3: errorstop ("Interner Fehler (Blocknummer zu hoch)")
+ OTHERWISE errorstop ("Schreib-/Lesefehler " + text (error))
+ END SELECT
+ FI.
+
+copy bpb block to bpb text:
+ replace (bpb, 1, bpb block. block row [1]);
+ replace (bpb, 2, bpb block. block row [2]);
+ replace (bpb, 3, bpb block. block row [3]);
+ replace (bpb, 4, bpb block. block row [4]).
+
+END PROC get bios parameter block;
+
+PROC load disk data from bpb:
+ disable stop;
+ enable load disk data from bpb;
+ IF is error
+ THEN clear error;
+ enable stop;
+ error stop ("Bios-Parameterblock ungltig")
+ FI.
+
+END PROC load disk data from bpb;
+
+PROC enable load disk data from bpb:
+ disk format.sectors per cluster := code (bpb SUB 14);
+ disk format.number of reserved sectors := code (bpb SUB 16) * 256 + code (bpb SUB 15);
+ disk format.number of fats := code (bpb SUB 17);
+ disk format.number of dir sectors := dir entrys DIV dir entrys per block;
+ disk format.size := real (code (bpb SUB 21)) * 256.0 + real (code (bpb SUB 20));
+ disk format.first fat byte := code (bpb SUB 22);
+ disk format.number of fat sectors := code (bpb SUB 24) * 256 + code (bpb SUB 23);
+ disk format.heads := dos heads;
+ disk format.sectors per track := code (bpb SUB 26) * 256 + code (bpb SUB 25);
+ disk format.tracks :=
+ int(disk format.size / real(disk format.sectors per track * disk format.heads));
+ disk format.number of fat entrys := fat entrys.
+
+dir entrys:
+ code (bpb SUB 19) * 256 + code (bpb SUB 18).
+
+dos heads:
+ code (bpb SUB 28) * 256 + code (bpb SUB 27).
+
+fat entrys:
+ data clusters + 2.
+
+data clusters:
+ int ((disk format.size - real (no of table sectors)) / real (sectors per cluster)).
+
+no of table sectors:
+ disk format.number of reserved sectors + disk format.number of fats * disk format.number of fat sectors +
+ disk format.number of dir sectors.
+
+END PROC enable load disk data from bpb;
+
+END PACKET dos disk;
diff --git a/system/dos/1986/src/disk descriptor.dos.hd b/system/dos/1986/src/disk descriptor.dos.hd
new file mode 100644
index 0000000..312b273
--- /dev/null
+++ b/system/dos/1986/src/disk descriptor.dos.hd
@@ -0,0 +1,290 @@
+PACKET dos disk DEFINES (* Copyright (C) 1985, 86 *)
+ (* Frank Klapper *)
+ first fat byte, (* 30.05.86 *)
+ begin of fat,
+ number of fat sectors,
+ number of fat entrys,
+ number of fat copies,
+ begin of dir,
+ number of dir sectors,
+ begin of data area,
+ sectors per cluster,
+ cluster size,
+ sector size,
+
+ eublock,
+ first block no of cluster,
+
+ reset disk attributes,
+ set disk attributes:
+
+LET dir entrys per block = 16,
+ first non dummy ds page = 2;
+
+LET DOSDISK = STRUCT (INT sectors per cluster,
+ number of reserved sectors,
+ number of fats,
+ number of dir sectors,
+ first fat byte,
+ number of fat sectors,
+ heads,
+ sectors per track,
+ tracks,
+ number of fat entrys,
+ REAL size);
+
+LET BLOCK = BOUND STRUCT (ALIGN dummy, ROW 64 REAL block row);
+
+INT CONST sector size :: 512;
+
+TEXT VAR bpb := 32 * " ";
+
+INITFLAG VAR bpb ds used := FALSE;
+
+DATASPACE VAR bpb ds;
+
+BLOCK VAR bpb block;
+
+DOSDISK VAR disk format;
+BOUND DOSDISK VAR format table;
+
+INT VAR eu sectors,
+ xbegin of data area;
+
+INT PROC eublock (INT CONST nr):
+(*COND FLOPPY
+ 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:
+ nr MOD disk format.sectors per track.
+
+trac:
+ (nr DIV disk format.sectors per track) DIV disk format.heads.
+
+head:
+ (nr DIV disk format.sectors per track) MOD disk format.heads.
+
+eu sectors per head:
+ eu sectors * eu tracks.
+
+ENDCOND*)
+(*COND HDU*)
+ nr
+
+(*ENDCOND*)
+
+END PROC eublock;
+
+INT PROC first block no of cluster (INT CONST cluster no):
+ IF cluster no < 2
+ THEN error stop ("interner Fehler")
+ FI;
+ begin of data area + (cluster no - 2) * sectors per cluster.
+
+END PROC first block no of cluster;
+
+INT PROC first fat byte:
+ disk format.first fat byte
+
+END PROC first fat byte;
+
+INT PROC number of fat copies:
+ disk format.number of fats
+
+END PROC number of fat copies;
+
+INT PROC number of fat sectors:
+ disk format.number of fat sectors
+
+END PROC number of fat sectors;
+
+INT PROC number of fat entrys:
+ disk format.number of fat entrys
+
+END PROC number of fat entrys;
+
+INT PROC number of dir sectors:
+ disk format.number of dir sectors
+
+END PROC number of dir sectors;
+
+INT PROC begin of fat (INT CONST no):
+ disk format.number of reserved sectors + no * disk format.number of fat sectors
+
+END PROC begin of fat;
+
+INT PROC begin of dir:
+ disk format.number of reserved sectors +
+ disk format.number of fats * disk format.number of fat sectors
+
+END PROC begin of dir;
+
+INT PROC begin of data area:
+ xbegin of data area
+
+END PROC begin of data area;
+
+INT PROC sectors per cluster:
+ disk format.sectors per cluster
+
+END PROC sectors per cluster;
+
+INT PROC cluster size:
+ disk format.sectors per cluster * 512
+
+END PROC cluster size;
+
+PROC set disk attributes (INT CONST first fat byte):
+ enable stop;
+(*COND FLOPPY
+ get bios parameter block;
+ IF is valid bpb
+ THEN load disk data from bpb
+ ELSE load disk disk data from ds
+ FI;
+ eu sectors := eu last sector - eu first sector +1;
+ENDCOND*)
+ xbegin of data area := disk format.number of reserved sectors +
+ disk format.number of fats * disk format.number of fat sectors +
+ disk format.number of dir sectors;
+(*COND FLOPPY
+ test compatibility
+
+.is valid bpb:
+ first fat byte < 252 OR code (bpb SUB 22) = first fat byte.
+
+load disk disk data from ds:
+ IF exists (text (first fat byte))
+ THEN format table := old (text (first fat byte));
+ copy values
+ ELSE error stop ("DOS-Diskettenformat nicht implementiert")
+ FI.
+
+copy values:
+ disk format.sectors per cluster := format table.sectors per cluster;
+ disk format.number of reserved sectors := format table.number of reserved sectors;
+ disk format.number of fats := format table.number of fats;
+ disk format.size := format table.size;
+ disk format.number of dir sectors := format table.number of dir sectors;
+ disk format.first fat byte := format table.first fat byte;
+ disk format.number of fat sectors := format table.number of fat sectors;
+ disk format.heads := format table.heads;
+ disk format.sectors per track := format table.sectors per track;
+ disk format.tracks := format table.tracks;
+ disk format.number of fat entrys := format table.number of fat entrys.
+
+test compatibility:
+ IF disk format.sectors per track > eu sectors
+ OR eu tracks <> disk format.tracks
+ OR abs (eu heads) < disk format.heads
+ OR disk format.number of reserved sectors <> 1
+ THEN error stop ("DOS-Format auf diesem Diskettenlaufwerk nicht lesbar")
+ FI;
+ENDCOND*)
+
+END PROC set disk attributes;
+
+PROC reset disk attributes:
+(*COND FLOPPY
+ disk format.sectors per cluster := 1;
+ disk format.number of reserved sectors := 1;
+ disk format.number of fats := 1;
+ disk format.size := real (eu size);
+ disk format.number of dir sectors := 4;
+ disk format.first fat byte := 255;
+ disk format.number of fat sectors := 1;
+ disk format.heads := eu heads;
+ disk format.sectors per track := eu tracks;
+ disk format.tracks := eu sectors;
+ disk format.number of fat entrys := 100.
+
+ENDCOND*)
+(*COND HDU*)
+ get bios parameter block;
+ load disk data from bpb.
+
+(*ENDCOND*)
+
+END PROC reset disk attributes;
+
+PROC get bios parameter block:
+ init bpb ds;
+ read bpb;
+ copy bpb block to bpb text.
+
+init bpb ds:
+ IF NOT initialized (bpb ds used)
+ THEN bpb ds := nilspace;
+ bpb block := bpb ds
+ FI.
+
+read bpb:
+ INT VAR error;
+ read block (bpb ds, first non dummy ds page, 0, error);
+ IF error <> 0
+ THEN SELECT error OF
+ CASE 1: errorstop ("Floppylaufwerk nicht betriebsbereit")
+ CASE 2: errorstop ("Schreib-/Lesefehler")
+ CASE 3: errorstop ("Interner Fehler (Blocknummer zu hoch)")
+ OTHERWISE errorstop ("Schreib-/Lesefehler " + text (error))
+ END SELECT
+ FI.
+
+copy bpb block to bpb text:
+ replace (bpb, 1, bpb block. block row [1]);
+ replace (bpb, 2, bpb block. block row [2]);
+ replace (bpb, 3, bpb block. block row [3]);
+ replace (bpb, 4, bpb block. block row [4]).
+
+END PROC get bios parameter block;
+
+PROC load disk data from bpb:
+ disable stop;
+ enable load disk data from bpb;
+ IF is error
+ THEN clear error;
+ enable stop;
+ error stop ("Bios-Parameterblock ungltig")
+ FI.
+
+END PROC load disk data from bpb;
+
+PROC enable load disk data from bpb:
+ disk format.sectors per cluster := code (bpb SUB 14);
+ disk format.number of reserved sectors := code (bpb SUB 16) * 256 + code (bpb SUB 15);
+ disk format.number of fats := code (bpb SUB 17);
+ disk format.number of dir sectors := dir entrys DIV dir entrys per block;
+ disk format.size := real (code (bpb SUB 21)) * 256.0 + real (code (bpb SUB 20));
+ disk format.first fat byte := code (bpb SUB 22);
+ disk format.number of fat sectors := code (bpb SUB 24) * 256 + code (bpb SUB 23);
+ disk format.heads := dos heads;
+ disk format.sectors per track := code (bpb SUB 26) * 256 + code (bpb SUB 25);
+ disk format.tracks :=
+ int(disk format.size / real(disk format.sectors per track * disk format.heads));
+ disk format.number of fat entrys := fat entrys.
+
+dir entrys:
+ code (bpb SUB 19) * 256 + code (bpb SUB 18).
+
+dos heads:
+ code (bpb SUB 28) * 256 + code (bpb SUB 27).
+
+fat entrys:
+ data clusters + 2.
+
+data clusters:
+ int ((disk format.size - real (no of table sectors)) / real (sectors per cluster)).
+
+no of table sectors:
+ disk format.number of reserved sectors + disk format.number of fats * disk format.number of fat sectors +
+ disk format.number of dir sectors.
+
+END PROC enable load disk data from bpb;
+
+END PACKET dos disk;
diff --git a/system/dos/1986/src/disk manager b/system/dos/1986/src/disk manager
new file mode 100644
index 0000000..5711ee7
--- /dev/null
+++ b/system/dos/1986/src/disk manager
@@ -0,0 +1,245 @@
+PACKET disk manager DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ disk fetch, (* 07.05.86 *)
+ disk check,
+ disk save first phase,
+ disk save second phase,
+ disk clear,
+ disk format,
+ disk erase,
+ disk exists,
+ disk list,
+ disk all,
+ disk reserve,
+ disk free:
+
+LET ascii = 1,
+ ascii german = 2,
+ transparent = 3,
+ ebcdic = 4,
+ row text = 5,
+ ds = 6,
+ atari st = 10;
+
+TEXT VAR file name;
+
+INT VAR mode := 0;
+TEXT VAR mode extension;
+
+REAL VAR last access time := 0.0;
+
+PROC disk fetch (TEXT CONST name, DATASPACE VAR file ds):
+ enable stop;
+ access disk;
+ file name := adapted name (name, TRUE);
+ IF dir contains (file name)
+ THEN do fetch
+ ELSE errorstop ("die Datei """ + file name + """ gibt es nicht")
+ FI;
+ last access time := clock (1).
+
+do fetch:
+ SELECT mode OF
+ CASE ascii, ascii german, atari st, ebcdic, transparent: fetch filemode (file ds, filename, mode)
+ CASE row text : fetch row textmode (file ds, filename)
+ CASE ds : fetch dsmode (file ds, filename)
+ OTHERWISE error stop ("Unzulssige Betriebsart")
+ END SELECT.
+
+END PROC disk fetch;
+
+PROC disk check (TEXT CONST name):
+ enable stop;
+ access disk;
+ file name := adapted name (name, TRUE);
+ IF dir contains (file name)
+ THEN disable stop;
+ check file (file name);
+ IF is error
+ THEN clear error;
+ error stop ("Fehler beim Prflesen der Datei """ + file name + """")
+ FI;
+ ELSE error stop ("""" + file name + """ gibt es nicht")
+ FI;
+ last access time := clock (1).
+
+END PROC disk check;
+
+PROC disk save first phase (TEXT CONST name, BOOL VAR overwrite question):
+ enable stop;
+ overwrite question := FALSE;
+ access disk;
+ file name := adapted name (name, FALSE);
+ IF dir contains (file name)
+ THEN overwrite question := TRUE
+ FI;
+ last access time := clock (1).
+
+END PROC disk save first phase;
+
+PROC disk save second phase (DATASPACE CONST file ds):
+ enable stop;
+ access disk;
+ erase file if necessary;
+ do save;
+ last access time := clock (1).
+
+erase file if necessary:
+ IF dir contains (file name)
+ THEN erase table entrys (file name)
+ FI.
+
+do save:
+ SELECT mode OF
+ CASE ascii, ascii german,atari st, ebcdic, 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 ("Unzulssige Betriebsart")
+ END SELECT.
+
+END PROC disk save second phase;
+
+(* DOS bekommt die Tabellenparameter von der Diskette
+ CPM bekommt die Tabellenparameter ber 'reserve' *)
+
+PROC disk clear:
+ enable stop;
+(*COND DOS*)
+ access disk;
+(*ENDCOND*)
+(*COND CPM
+ open eu disk;
+ open action;
+ENDCOND*)
+ format disk;
+ last access time := clock (1).
+
+END PROC disk clear;
+
+PROC disk erase (TEXT CONST name):
+ enable stop;
+ access disk;
+ file name := adapted name (name, TRUE);
+ IF NOT dir contains (file name)
+ THEN errorstop ("die Datei """ + file name + """ gibt es nicht")
+ ELSE erase table entrys (file name);
+ FI;
+ last access time := clock (1).
+
+END PROC disk erase;
+
+BOOL PROC disk exists (TEXT CONST name):
+ enable stop;
+ access disk;
+ last access time := clock (1);
+ dir contains (adapted name (name, TRUE)).
+
+END PROC disk exists;
+
+PROC disk list (DATASPACE VAR list ds):
+ enable stop;
+ access disk;
+ dir list (list ds);
+ last access time := clock (1).
+
+END PROC disk list;
+
+THESAURUS PROC disk all:
+ enable stop;
+ access disk;
+ last access time := clock (1);
+ dir all.
+
+END PROC disk all;
+
+PROC disk format:
+
+(*COND DOS*)
+ error stop ("nicht implementiert")
+(*ENDCOND*)
+
+(*COND CPM
+ enable stop;
+ open eu disk;
+ open action;
+ format archive (eu disk format no);
+ format disk;
+ last access time := clock (1).
+ENDCOND*)
+
+END PROC disk format;
+
+PROC disk reserve (TEXT CONST reserve string):
+ enable stop;
+ close action;
+ last access time := clock (1);
+ get mode.
+
+get mode:
+ TEXT VAR mode text;
+ IF pos (reserve string, ":") = 0
+ THEN mode text := reserve string;
+ mode extension := ""
+ ELSE mode text := subtext (reserve string, 1, pos (reserve string, ":") - 1);
+ mode extension := subtext (reserve string, pos (reserve string, ":") + 1)
+ FI;
+ prepare modetext;
+ IF mode text = "FILEASCII"
+ THEN mode := ascii
+ ELIF mode text = "FILEASCIIGERMAN"
+ THEN mode := asciigerman
+ ELIF mode text = "FILEATARIST"
+ THEN mode := atari st
+ ELIF modetext = "FILEEBCDIC"
+ THEN mode := ebcdic
+ ELIF modetext = "FILETRANSPARENT"
+ THEN mode := transparent
+ ELIF mode text = "ROWTEXT"
+ THEN mode := row text
+ ELIF mode text = "DS"
+ THEN mode := ds
+ ELSE error stop ("Unzulssige Betriebsart")
+ FI.
+
+prepare modetext:
+ change all (mode text, " ", "");
+ INT VAR i;
+ FOR i FROM 1 UPTO LENGTH mode text REP
+ IF is lower case
+ THEN replace (mode text, i, upper case char)
+ FI
+ PER.
+
+is lower case:
+ code (mode text SUB i) > 96 AND code (mode text SUB i) < 123.
+
+upper case char:
+ code (code (mode text SUB i) - 32).
+
+END PROC disk reserve;
+
+PROC disk free:
+ disable stop;
+ close action;
+ close disk;
+ reduce cluster buffer.
+
+END PROC disk free;
+
+PROC access disk:
+ IF action closed COR (last access more than two seconds ago CAND disk changed)
+ THEN open disk archive
+ FI.
+
+open disk archive:
+ close action;
+ open eu disk;
+ open disk (mode extension);
+ open action.
+
+last access more than two seconds ago:
+ abs (clock (1) - last access time) > 2.0.
+
+END PROC access disk;
+
+END PACKET disk manager;
diff --git a/system/dos/1986/src/eu disk descriptor.fd b/system/dos/1986/src/eu disk descriptor.fd
new file mode 100644
index 0000000..c09c820
--- /dev/null
+++ b/system/dos/1986/src/eu disk descriptor.fd
@@ -0,0 +1,102 @@
+PACKET eu disk DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ (* 25.03.86 *)
+ 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,
+ table pointer;
+
+PROC open eu disk:
+ enable stop;
+ init check rerun;
+(*COND FLOPPY*)
+ INT VAR blocks := archive blocks;
+ search format table entry;
+(*ENDCOND*)
+.
+
+(*COND FLOPPY*)
+search format table entry:
+ 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.
+(*ENDCOND*)
+
+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/1986/src/eu disk descriptor.hd b/system/dos/1986/src/eu disk descriptor.hd
new file mode 100644
index 0000000..73179db
--- /dev/null
+++ b/system/dos/1986/src/eu disk descriptor.hd
@@ -0,0 +1,102 @@
+PACKET eu disk DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ (* 25.03.86 *)
+ 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,
+ table pointer;
+
+PROC open eu disk:
+ enable stop;
+ init check rerun;
+(*COND FLOPPY
+ INT VAR blocks := archive blocks;
+ search format table entry;
+ENDCOND*)
+.
+
+(*COND FLOPPY
+search format table entry:
+ 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.
+ENDCOND*)
+
+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/1986/src/eumel-ebcdic + sub b/system/dos/1986/src/eumel-ebcdic + sub
new file mode 100644
index 0000000..5a571cb
--- /dev/null
+++ b/system/dos/1986/src/eumel-ebcdic + sub
@@ -0,0 +1,550 @@
+PACKET eumel ebcdic DEFINES (* Copyright (c) 1986 *)
+ (* Frank Klapper *)
+ (* 19.02.86 *)
+ ebcdic to eumel with substitution,
+ eumel to ebcdic with substitution:
+
+TEXT VAR bild;
+
+PROC eumel to ebcdic with substitution (TEXT VAR string):
+ bild := "";
+ INT VAR pos;
+ FOR pos FROM 1 UPTO LENGTH string REP
+ bild CAT conversion
+ PER;
+ string := bild.
+
+conversion:
+ SELECT code (string SUB pos) OF
+ CASE 0: "{"240""240""240"{"
+ CASE 1: "{"240""240""241"{"
+ CASE 2: "{"240""240""242"{"
+ CASE 3: "{"240""240""243"{"
+ CASE 4: "{"240""240""244"{"
+ CASE 5: "{"240""240""245"{"
+ CASE 6: "{"240""240""246"{"
+ CASE 7: "{"240""240""247"{"
+ CASE 8: "{"240""240""248"{"
+ CASE 9: "{"240""240""249"{"
+ CASE 10: "%"
+ CASE 11: "{"240""241""241"{"
+ CASE 12: ""12""
+ CASE 13: ""13""
+ CASE 14: "{"240""241""244"{"
+ CASE 15: "{"240""241""245"{"
+ CASE 16: "{"240""241""246"{"
+ CASE 17: "{"240""241""247"{"
+ CASE 18: "{"240""241""248"{"
+ CASE 19: "{"240""241""249"{"
+ CASE 20: "{"240""242""240"{"
+ CASE 21: "{"240""242""241"{"
+ CASE 22: "{"240""242""242"{"
+ CASE 23: "{"240""242""243"{"
+ CASE 24: "{"240""242""244"{"
+ CASE 25: "{"240""242""245"{"
+ CASE 26: "{"240""242""246"{"
+ CASE 27: "{"240""242""247"{"
+ CASE 28: "{"240""242""248"{"
+ CASE 29: "{"240""242""249"{"
+ CASE 30: "{"240""243""240"{"
+ CASE 31: "{"240""243""241"{"
+ CASE 32: "@"
+ CASE 33: "O"
+ CASE 34: ""
+ CASE 35: "{"
+ CASE 36: "{"240""243""246"{"
+ CASE 37: "l"
+ CASE 38: "P"
+ CASE 39: "}"
+ CASE 40: "M"
+ CASE 41: "]"
+ CASE 42: "\"
+ CASE 43: "N"
+ CASE 44: "k"
+ CASE 45: "`"
+ CASE 46: "K"
+ CASE 47: "a"
+ CASE 48: ""240""
+ CASE 49: ""241""
+ CASE 50: ""242""
+ CASE 51: ""243""
+ CASE 52: ""244""
+ CASE 53: ""245""
+ CASE 54: ""246""
+ CASE 55: ""247""
+ CASE 56: ""248""
+ CASE 57: ""249""
+ CASE 58: "z"
+ CASE 59: "^"
+ CASE 60: "L"
+ CASE 61: "~"
+ CASE 62: "n"
+ CASE 63: "o"
+ CASE 64: "|"
+ CASE 65: ""
+ CASE 66: ""
+ CASE 67: ""
+ CASE 68: ""
+ CASE 69: ""
+ CASE 70: ""
+ CASE 71: ""
+ CASE 72: ""
+ CASE 73: ""
+ CASE 74: ""
+ CASE 75: ""
+ CASE 76: ""
+ CASE 77: ""
+ CASE 78: ""
+ CASE 79: ""
+ CASE 80: ""
+ CASE 81: ""
+ CASE 82: ""
+ CASE 83: ""226""
+ CASE 84: ""227""
+ CASE 85: ""228""
+ CASE 86: ""229""
+ CASE 87: ""230""
+ CASE 88: ""231""
+ CASE 89: ""232""
+ CASE 90: ""233""
+ CASE 91: "J"
+ CASE 92: ""224""
+ CASE 93: "Z"
+ CASE 94: "{"240""249""244"{"
+ CASE 95: "m"
+ CASE 96: "y"
+ CASE 97: ""
+ CASE 98: ""
+ CASE 99: ""
+ CASE 100: ""
+ CASE 101: ""
+ CASE 102: ""
+ CASE 103: ""
+ CASE 104: ""
+ CASE 105: ""
+ CASE 106: ""
+ CASE 107: ""
+ CASE 108: ""
+ CASE 109: ""
+ CASE 110: ""
+ CASE 111: ""
+ CASE 112: ""
+ CASE 113: ""
+ CASE 114: ""
+ CASE 115: ""
+ CASE 116: ""
+ CASE 117: ""
+ CASE 118: ""
+ CASE 119: ""
+ CASE 120: ""
+ CASE 121: ""
+ CASE 122: ""
+ CASE 123: ""
+ CASE 124: "{"241""242""244"{"
+ CASE 125: ""
+ CASE 126: ""
+ CASE 127: "{"241""242""247"{"
+ CASE 128: "{"241""242""248"{"
+ CASE 129: "{"241""242""249"{"
+ CASE 130: "{"241""243""240"{"
+ CASE 131: "{"241""243""241"{"
+ CASE 132: "{"241""243""242"{"
+ CASE 133: "{"241""243""243"{"
+ CASE 134: "{"241""243""244"{"
+ CASE 135: "{"241""243""245"{"
+ CASE 136: "{"241""243""246"{"
+ CASE 137: "{"241""243""247"{"
+ CASE 138: "{"241""243""248"{"
+ CASE 139: "{"241""243""249"{"
+ CASE 140: "{"241""244""240"{"
+ CASE 141: "{"241""244""241"{"
+ CASE 142: "{"241""244""242"{"
+ CASE 143: "{"241""244""243"{"
+ CASE 144: "{"241""244""244"{"
+ CASE 145: "{"241""244""245"{"
+ CASE 146: "{"241""244""246"{"
+ CASE 147: "{"241""244""247"{"
+ CASE 148: "{"241""244""248"{"
+ CASE 149: "{"241""244""249"{"
+ CASE 150: "{"241""245""240"{"
+ CASE 151: "{"241""245""241"{"
+ CASE 152: "{"241""245""242"{"
+ CASE 153: "{"241""245""243"{"
+ CASE 154: "{"241""245""244"{"
+ CASE 155: "{"241""245""245"{"
+ CASE 156: "{"241""245""246"{"
+ CASE 157: "{"241""245""247"{"
+ CASE 158: "{"241""245""248"{"
+ CASE 159: "{"241""245""249"{"
+ CASE 160: "{"241""246""240"{"
+ CASE 161: "{"241""246""241"{"
+ CASE 162: "{"241""246""242"{"
+ CASE 163: "{"241""246""243"{"
+ CASE 164: "{"241""246""244"{"
+ CASE 165: "{"241""246""245"{"
+ CASE 166: "{"241""246""246"{"
+ CASE 167: "{"241""246""247"{"
+ CASE 168: "{"241""246""248"{"
+ CASE 169: "{"241""246""249"{"
+ CASE 170: "{"241""247""240"{"
+ CASE 171: "{"241""247""241"{"
+ CASE 172: "{"241""247""242"{"
+ CASE 173: "{"241""247""243"{"
+ CASE 174: "{"241""247""244"{"
+ CASE 175: "{"241""247""245"{"
+ CASE 176: "{"241""247""246"{"
+ CASE 177: "{"241""247""247"{"
+ CASE 178: "{"241""247""248"{"
+ CASE 179: "{"241""247""249"{"
+ CASE 180: "{"241""248""240"{"
+ CASE 181: "{"241""248""241"{"
+ CASE 182: "{"241""248""242"{"
+ CASE 183: "{"241""248""243"{"
+ CASE 184: "{"241""248""244"{"
+ CASE 185: "{"241""248""245"{"
+ CASE 186: "{"241""248""246"{"
+ CASE 187: "{"241""248""247"{"
+ CASE 188: "{"241""248""248"{"
+ CASE 189: "{"241""248""249"{"
+ CASE 190: "{"241""249""240"{"
+ CASE 191: "{"241""249""241"{"
+ CASE 192: "{"241""249""242"{"
+ CASE 193: "{"241""249""243"{"
+ CASE 194: "{"241""249""244"{"
+ CASE 195: "{"241""249""245"{"
+ CASE 196: "{"241""249""246"{"
+ CASE 197: "{"241""249""247"{"
+ CASE 198: "{"241""249""248"{"
+ CASE 199: "{"241""249""249"{"
+ CASE 200: "{"242""240""240"{"
+ CASE 201: "{"242""240""241"{"
+ CASE 202: "{"242""240""242"{"
+ CASE 203: "{"242""240""243"{"
+ CASE 204: "{"242""240""244"{"
+ CASE 205: "{"242""240""245"{"
+ CASE 206: "{"242""240""246"{"
+ CASE 207: "{"242""240""247"{"
+ CASE 208: "{"242""240""248"{"
+ CASE 209: "{"242""240""249"{"
+ CASE 210: "{"242""241""240"{"
+ CASE 211: "{"242""241""241"{"
+ CASE 212: "{"242""241""242"{"
+ CASE 213: "{"242""241""243"{"
+ CASE 214: "{"242""241""244"{"
+ CASE 215: "{"242""241""245"{"
+ CASE 216: "{"242""241""246"{"
+ CASE 217: "{"242""241""247"{"
+ CASE 218: "{"242""241""248"{"
+ CASE 219: "{"242""241""249"{"
+ CASE 220: ""
+ CASE 221: "`"
+ CASE 222: "{"
+ CASE 223: "@"
+ CASE 224: "{"242""242""244"{"
+ CASE 225: "{"242""242""245"{"
+ CASE 226: "{"242""242""246"{"
+ CASE 227: "{"242""242""247"{"
+ CASE 228: "{"242""242""248"{"
+ CASE 229: "{"242""242""249"{"
+ CASE 230: "{"242""243""240"{"
+ CASE 231: "{"242""243""241"{"
+ CASE 232: "{"242""243""242"{"
+ CASE 233: "{"242""243""243"{"
+ CASE 234: "{"242""243""244"{"
+ CASE 235: "{"242""243""245"{"
+ CASE 236: "{"242""243""246"{"
+ CASE 237: "{"242""243""247"{"
+ CASE 238: "{"242""243""248"{"
+ CASE 239: "{"242""243""249"{"
+ CASE 240: "{"242""244""240"{"
+ CASE 241: "{"242""244""241"{"
+ CASE 242: "{"242""244""242"{"
+ CASE 243: "{"242""244""243"{"
+ CASE 244: "{"242""244""244"{"
+ CASE 245: "{"242""244""245"{"
+ CASE 246: "{"242""244""246"{"
+ CASE 247: "{"242""244""247"{"
+ CASE 248: "{"242""244""248"{"
+ CASE 249: "{"242""244""249"{"
+ CASE 250: "{"242""245""240"{"
+ CASE 251: "{"242""245""241"{"
+ CASE 252: "{"242""245""242"{"
+ CASE 253: "{"242""245""243"{"
+ CASE 254: "{"242""245""244"{"
+ CASE 255: "{"242""245""245"{"
+ OTHERWISE ""
+ END SELECT.
+
+END PROC eumel to ebcdic with substitution;
+
+PROC ebcdic to eumel with substitution (TEXT VAR string):
+ bild := "";
+ INT VAR pos;
+ FOR pos FROM 1 UPTO LENGTH string REP
+ bild CAT conversion
+ PER;
+ string := bild.
+
+conversion:
+ SELECT code (string SUB pos) OF
+ CASE 0: "#000#"
+ CASE 1: "#001#"
+ CASE 2: "#002#"
+ CASE 3: "#003#"
+ CASE 4: "#004#"
+ CASE 5: "#005#"
+ CASE 6: "#006#"
+ CASE 7: "#007#"
+ CASE 8: "#008#"
+ CASE 9: "#009#"
+ CASE 10: "#010#"
+ CASE 11: "#011#"
+ CASE 12: "#012#"
+ CASE 13: "#013#"
+ CASE 14: "#014#"
+ CASE 15: "#015#"
+ CASE 16: "#016#"
+ CASE 17: "#017#"
+ CASE 18: "#018#"
+ CASE 19: "#019#"
+ CASE 20: "#020#"
+ CASE 21: "#021#"
+ CASE 22: "#022#"
+ CASE 23: "#023#"
+ CASE 24: "#024#"
+ CASE 25: "#025#"
+ CASE 26: "#026#"
+ CASE 27: "#027#"
+ CASE 28: "#028#"
+ CASE 29: "#029#"
+ CASE 30: "#030#"
+ CASE 31: "#031#"
+ CASE 32: "#032#"
+ CASE 33: "#033#"
+ CASE 34: "#034#"
+ CASE 35: "#035#"
+ CASE 36: "#036#"
+ CASE 37: "#037#"
+ CASE 38: "#038#"
+ CASE 39: "#039#"
+ CASE 40: "#040#"
+ CASE 41: "#041#"
+ CASE 42: "#042#"
+ CASE 43: "#043#"
+ CASE 44: "#044#"
+ CASE 45: "#045#"
+ CASE 46: "#046#"
+ CASE 47: "#047#"
+ CASE 48: "#048#"
+ CASE 49: "#049#"
+ CASE 50: "#050#"
+ CASE 51: "#051#"
+ CASE 52: "#052#"
+ CASE 53: "#053#"
+ CASE 54: "#054#"
+ CASE 55: "#055#"
+ CASE 56: "#056#"
+ CASE 57: "#057#"
+ CASE 58: "#058#"
+ CASE 59: "#059#"
+ CASE 60: "#060#"
+ CASE 61: "#061#"
+ CASE 62: "#062#"
+ CASE 63: "#063#"
+ CASE 64: "#064#"
+ CASE 65: "#065#"
+ CASE 66: "#066#"
+ CASE 67: "#067#"
+ CASE 68: "#068#"
+ CASE 69: "#069#"
+ CASE 70: "#070#"
+ CASE 71: "#071#"
+ CASE 72: "#072#"
+ CASE 73: "#073#"
+ CASE 74: "["
+ CASE 75: "."
+ CASE 76: "<"
+ CASE 77: "("
+ CASE 78: "+"
+ CASE 79: "!"
+ CASE 80: "&"
+ CASE 81: "#081#"
+ CASE 82: "#082#"
+ CASE 83: "#083#"
+ CASE 84: "#084#"
+ CASE 85: "#085#"
+ CASE 86: "#086#"
+ CASE 87: "#087#"
+ CASE 88: "#088#"
+ CASE 89: "#089#"
+ CASE 90: "]"
+ CASE 91: "$"
+ CASE 92: "*"
+ CASE 93: ")"
+ CASE 94: ";"
+ CASE 95: "^"
+ CASE 96: "-"
+ CASE 97: "/"
+ CASE 98: "#098#"
+ CASE 99: "#099#"
+ CASE 100: "#100#"
+ CASE 101: "#101#"
+ CASE 102: "#102#"
+ CASE 103: "#103#"
+ CASE 104: "#104#"
+ CASE 105: "#105#"
+ CASE 106: "|"
+ CASE 107: ","
+ CASE 108: "%"
+ CASE 109: "_"
+ CASE 110: ">"
+ CASE 111: "?"
+ CASE 112: "#112#"
+ CASE 113: "#113#"
+ CASE 114: "#114#"
+ CASE 115: "#115#"
+ CASE 116: "#116#"
+ CASE 117: "#117#"
+ CASE 118: "#118#"
+ CASE 119: "#119#"
+ CASE 120: "#120#"
+ CASE 121: "`"
+ CASE 122: ":"
+ CASE 123: "#"
+ CASE 124: "@"
+ CASE 125: "'"
+ CASE 126: "="
+ CASE 127: """"
+ CASE 128: "#128#"
+ CASE 129: "a"
+ CASE 130: "b"
+ CASE 131: "c"
+ CASE 132: "d"
+ CASE 133: "e"
+ CASE 134: "f"
+ CASE 135: "g"
+ CASE 136: "h"
+ CASE 137: "i"
+ CASE 138: "#138#"
+ CASE 139: "#139#"
+ CASE 140: "#140#"
+ CASE 141: "#141#"
+ CASE 142: "#142#"
+ CASE 143: "#143#"
+ CASE 144: "#144#"
+ CASE 145: "j"
+ CASE 146: "k"
+ CASE 147: "l"
+ CASE 148: "m"
+ CASE 149: "n"
+ CASE 150: "o"
+ CASE 151: "p"
+ CASE 152: "q"
+ CASE 153: "r"
+ CASE 154: "#154#"
+ CASE 155: "#155#"
+ CASE 156: "#156#"
+ CASE 157: "#157#"
+ CASE 158: "#158#"
+ CASE 159: "#159#"
+ CASE 160: "#160#"
+ CASE 161: "~"
+ CASE 162: "s"
+ CASE 163: "t"
+ CASE 164: "u"
+ CASE 165: "v"
+ CASE 166: "w"
+ CASE 167: "x"
+ CASE 168: "y"
+ CASE 169: "z"
+ CASE 170: "#170#"
+ CASE 171: "#171#"
+ CASE 172: "#172#"
+ CASE 173: "#173#"
+ CASE 174: "#174#"
+ CASE 175: "#175#"
+ CASE 176: "#176#"
+ CASE 177: "#177#"
+ CASE 178: "#178#"
+ CASE 179: "#179#"
+ CASE 180: "#180#"
+ CASE 181: "#181#"
+ CASE 182: "#182#"
+ CASE 183: "#183#"
+ CASE 184: "#184#"
+ CASE 185: "#185#"
+ CASE 186: "#186#"
+ CASE 187: "#187#"
+ CASE 188: "#188#"
+ CASE 189: "#189#"
+ CASE 190: "#190#"
+ CASE 191: "#191#"
+ CASE 192: "{"
+ CASE 193: "A"
+ CASE 194: "B"
+ CASE 195: "C"
+ CASE 196: "D"
+ CASE 197: "E"
+ CASE 198: "F"
+ CASE 199: "G"
+ CASE 200: "H"
+ CASE 201: "I"
+ CASE 202: "#202#"
+ CASE 203: "#203#"
+ CASE 204: "#204#"
+ CASE 205: "#205#"
+ CASE 206: "#206#"
+ CASE 207: "#207#"
+ CASE 208: "}"
+ CASE 209: "J"
+ CASE 210: "K"
+ CASE 211: "L"
+ CASE 212: "M"
+ CASE 213: "N"
+ CASE 214: "O"
+ CASE 215: "P"
+ CASE 216: "Q"
+ CASE 217: "R"
+ CASE 218: "#218#"
+ CASE 219: "#219#"
+ CASE 220: "#220#"
+ CASE 221: "#221#"
+ CASE 222: "#222#"
+ CASE 223: "#223#"
+ CASE 224: "\"
+ CASE 225: "#225#"
+ CASE 226: "S"
+ CASE 227: "T"
+ CASE 228: "U"
+ CASE 229: "V"
+ CASE 230: "W"
+ CASE 231: "X"
+ CASE 232: "Y"
+ CASE 233: "Z"
+ CASE 234: "#234#"
+ CASE 235: "#235#"
+ CASE 236: "#236#"
+ CASE 237: "#237#"
+ CASE 238: "#238#"
+ CASE 239: "#239#"
+ CASE 240: "0"
+ CASE 241: "1"
+ CASE 242: "2"
+ CASE 243: "3"
+ CASE 244: "4"
+ CASE 245: "5"
+ CASE 246: "6"
+ CASE 247: "7"
+ CASE 248: "8"
+ CASE 249: "9"
+ CASE 250: "#250#"
+ CASE 251: "#251#"
+ CASE 252: "#252#"
+ CASE 253: "#253#"
+ CASE 254: "#254#"
+ CASE 255: "#255#"
+ OTHERWISE ""
+ END SELECT.
+END PROC ebcdic to eumel with substitution;
+
+END PACKET eumel ebcdic;
diff --git a/system/dos/1986/src/fat and dir.dos.fd b/system/dos/1986/src/fat and dir.dos.fd
new file mode 100644
index 0000000..5a82655
--- /dev/null
+++ b/system/dos/1986/src/fat and dir.dos.fd
@@ -0,0 +1,1190 @@
+PACKET dos fat and dir DEFINES (* Copyright (C) 1985, 86 *)
+ (* Frank Klapper *)
+ open disk, (* 30.05.86 *)
+ close disk,
+ format disk,
+ disk changed,
+ open fetch,
+ next fetch cluster no,
+ open save,
+ next save cluster no,
+ close save,
+ erase table entrys,
+(*COND TEST
+ dump fat,
+ENDCOND*)
+ dir all,
+ dir list,
+ dir contains:
+
+LET fat row size = 16384, (* 32 KB *)
+ max fat blocks = 25,
+ first fat entry no = 2,
+ last entry of fat chain = 4088,
+ dir entrys per block = 16,
+ max dir entrys = 1600, (* 100 KB *)
+ archive byte = " ";
+
+LET FAT = BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block row,
+ ROW fat row size INT fat row);
+
+LET LOCATION = STRUCT (INT msdos block no,
+ block entry no),
+
+ FILEENTRY = STRUCT (TEXT date and time,
+ REAL size,
+ INT first cluster,
+ LOCATION location),
+
+ DIRENTRY = INT,
+
+ FILELIST = STRUCT (THESAURUS thes,
+ ROW max dir entrys FILEENTRY entry,
+ INT no of entrys),
+
+ DIRLIST = STRUCT (THESAURUS thes,
+ ROW max dir entrys DIRENTRY entry,
+ INT no of entrys),
+
+ FREELIST = STRUCT (ROW max dir entrys LOCATION stack,
+ INT stacktop,
+ LOCATION begin of free area,
+ end of dir,
+ INT dir chain root),
+
+ DIR = BOUND STRUCT (FILELIST filelist,
+ DIRLIST dirlist,
+ FREELIST freelist,
+ TEXT disklabel,
+ path);
+
+INITFLAG VAR this packet := FALSE;
+
+DATASPACE VAR fat space,
+ dir ds,
+ block ds;
+
+BOOL VAR dataspaces open;
+
+FAT VAR fat struct;
+ROW max fat blocks BOOL VAR write access;
+INT VAR first possible available fat entry;
+
+DIR VAR dir;
+
+CLUSTER VAR block;
+
+INT VAR akt file cluster no,
+ first file cluster no;
+BOOL VAR no cluster saved;
+TEXT VAR save name;
+
+INT VAR count;
+
+TEXT VAR convert buffer := " ",
+ name,
+ dir entry;
+
+.fat:
+ fat struct.fat row.
+
+PROC open disk (TEXT CONST subdir path):
+ disable stop;
+ enable open disk (subdir path);
+ IF is error
+ THEN close action
+ FI
+
+END PROC open disk;
+
+PROC enable open disk (TEXT CONST subdir path):
+ enable stop;
+ init dataspaces;
+ open fat;
+ open dir.
+
+open fat:
+ reset disk attributes;
+ read first fat block;
+ set disk attributes (fat byte (0));
+ read other fat blocks;
+ define write access table (FALSE);
+ first possible available fat entry := first fat entry no.
+
+read first fat block:
+ read fat block (0, FALSE).
+
+read other fat blocks:
+ INT VAR block no;
+ FOR block no FROM 1 UPTO number of fat sectors - 1 REP
+ read fat block (block no, FALSE)
+ PER.
+
+open dir:
+ init dir struct (subdir path, -1);
+ load main dir blocks;
+ load subdirs if necessary.
+
+load main dir blocks:
+ BOOL VAR last block;
+ store end of dir (loc (end of main dir, dir entrys per block - 1));
+ FOR block no FROM begin of dir UPTO end of main dir REP
+ load dir block (block no, last block);
+ UNTIL last block
+ PER.
+
+end of main dir:
+ begin of dir + number of dir sectors - 1.
+
+load subdirs if necessary:
+ TEXT VAR path := subdir path;
+ WHILE path <> "" REP
+ load next subdir if possible
+ PER.
+
+load next subdir if possible:
+ INT VAR cluster no;
+ get next subdir name;
+ get first cluster no of subdir table;
+ clear dir entrys (cluster no);
+ WHILE cluster no >= 0 REP
+ load subdir entrys of cluster;
+ cluster no := next fetch cluster no
+ UNTIL last block
+ PER.
+
+get next subdir name:
+ TEXT VAR subdir name;
+ IF (path SUB 1) <> "\"
+ THEN error stop ("ungltige Pfadbezeichnung")
+ FI;
+ INT VAR backslash pos := pos (path, "\", "\", 2);
+ IF backslash pos = 0
+ THEN subdir name := subtext (path, 2);
+ path := ""
+ ELSE subdir name := subtext (path, 2, backslash pos - 1);
+ path := subtext (path, backslash pos)
+ FI;
+ subdir name := adapted name (subdir name, TRUE).
+
+get first cluster no of subdir table:
+ IF dir thes CONTAINS subdir name
+ THEN open fetch subdir (subdir name, cluster no);
+ ELSE error stop ("Subdirectory existiert nicht")
+ FI.
+
+load subdir entrys of cluster:
+ store end of dir (loc (last block no of cluster, dir entrys per block - 1));
+ FOR block no FROM 0 UPTO (sectors per cluster - 1) REP
+ load dir block (first block no of cluster (cluster no) + block no, last block)
+ UNTIL last block
+ PER.
+
+last block no of cluster:
+ first block no of cluster (cluster no) + sectors per cluster - 1.
+
+END PROC enable open disk;
+
+PROC init dataspaces:
+ enable stop;
+ IF NOT initialized (this packet)
+ THEN dataspaces open := FALSE
+ FI;
+ IF NOT dataspaces open
+ THEN disable stop;
+ dataspaces open := TRUE;
+ fat space := nilspace;
+ dir ds := nilspace;
+ block ds := nilspace;
+ fat struct := fat space;
+ dir := dir ds;
+ block := block ds
+ FI.
+
+END PROC init dataspaces;
+
+PROC init dir struct (TEXT CONST path string, INT CONST root):
+ clear dir entrys (root);
+ dir.path := path string;
+ dir.disk label := "".
+
+END PROC init dir struct;
+
+PROC clear dir entrys (INT CONST root):
+ init file list;
+ init dir list;
+ init free list (root).
+
+init file list:
+ dir.file list.thes := empty thesaurus;
+ dir.file list.no of entrys := 0.
+
+init dir list:
+ dir.dir list.thes := empty thesaurus;
+ dir.dir list.no of entrys := 0.
+
+END PROC clear dir entrys;
+
+PROC close disk:
+ enable stop;
+ IF NOT initialized (this packet)
+ THEN dataspaces open := FALSE
+ FI;
+ IF dataspaces open
+ THEN forget (dir ds);
+ forget (block ds);
+ forget (fat space);
+ dataspaces open := FALSE
+ FI.
+
+END PROC close disk;
+
+(*COND FLOPPY*)
+PROC format disk:
+ enable stop;
+ init dataspaces;
+ format fat;
+ format dir.
+
+format fat:
+ write first four fat bytes;
+ write other fat bytes;
+ define write access table (TRUE);
+ copy fat to disk.
+
+write first four fat bytes:
+ fat [1] := word (first fat byte, 255);
+ fat [2] := word (255, 0).
+
+write other fat bytes:
+ FOR count FROM 3 UPTO fat length REP
+ fat [count] := 0
+ PER.
+
+fat length:
+ INT VAR len := number of fat entrys + number of fat entrys DIV 2
+ + number of fat entrys MOD 2;
+ len DIV 2 + len MOD 2.
+
+format dir:
+ init dir struct ("", -1);
+ store begin of free area (loc (begin of dir, 0));
+ store end of dir (loc (end of dir, dir entrys per block - 1));
+ FOR count FROM 0 UPTO dir entrys per block - 1 REP
+ write text 32 (block, ""0"" + 31 * ""246"", count)
+ PER;
+ disable stop;
+ FOR count FROM begin of dir UPTO end of dir REP
+ write disk block (block ds, count);
+ PER.
+
+end of dir:
+ begin of dir + number of dir sectors - 1.
+
+END PROC format disk;
+(*ENDCOND*)
+
+(*COND HDU
+PROC disk clear:
+ error stop ("nicht implementiert")
+
+END PROC disk clear;
+
+PROC format disk:
+ error stop ("nicht implementiert")
+
+END PROC format disk;
+ENDCOND*)
+
+INT PROC word (INT CONST low byte, high byte):
+ convert buffer := code (low byte) + code (high byte);
+ convert buffer ISUB 1.
+
+END PROC word;
+
+BOOL PROC disk changed:
+(*COND FLOPPY*)
+ disable stop;
+ NOT first fat block ok COR is error (* must be COR *)
+(*ENDCOND*)
+(*COND HDU
+ FALSE
+ENDCOND*)
+
+END PROC disk changed;
+
+BOOL PROC first fat block ok:
+ enable stop;
+ read fat block (0, TRUE);
+ FOR count FROM 1 UPTO 256 REP
+ compare word
+ PER;
+ TRUE.
+
+compare word:
+ IF fat struct.fat row [count] <> fat struct.block row [count]
+ THEN LEAVE first fat block ok WITH FALSE
+ FI.
+
+END PROC first fat block ok;
+
+PROC open fetch (TEXT CONST name, REAL VAR size, INT VAR first cluster no):
+ enable stop;
+ first cluster no := dir.file list.entry [link index].first cluster;
+ size := dir.file list.entry [link index].size;
+ IF first cluster no >= 4088
+ THEN first cluster no := -1
+ FI;
+ akt file cluster no := first cluster no.
+
+link index:
+ link (file thes, name).
+
+END PROC open fetch;
+
+PROC open fetch subdir (TEXT CONST subdir name, INT VAR first cluster no):
+ first cluster no := dir.dir list.entry [link index];
+ IF first cluster no >= 4088
+ THEN first cluster no := -1
+ FI;
+ akt file cluster no := first cluster no.
+
+link index:
+ link (dir thes, subdir name).
+
+END PROC open fetch subdir;
+
+INT PROC next fetch cluster no:
+ enable stop;
+ akt file cluster no := fat entry (akt file cluster no);
+ IF akt file cluster no < 4088 (*ff8h *)
+ THEN akt file cluster no
+ ELSE -1
+ FI.
+
+END PROC next fetch cluster no;
+
+PROC open save (TEXT CONST file name):
+ enable stop;
+ save name := file name;
+ IF dir full
+ THEN error stop ("Directory voll")
+ FI;
+ IF dir thes CONTAINS file name
+ THEN error stop ("Subdirectory mit gleichem Namen existiert bereits")
+ FI;
+ IF file thes CONTAINS file name
+ THEN error stop ("Datei mit gleichem Namen existiert bereits")
+ FI;
+ no cluster saved := TRUE.
+
+END PROC open save;
+
+INT PROC next save cluster no:
+ enable stop;
+ IF no cluster saved
+ THEN akt file cluster no := available fat entry;
+ first file cluster no := akt file cluster no;
+ no cluster saved := FALSE
+ ELSE INT VAR old cluster no := akt file cluster no;
+ akt file cluster no := available fat entry;
+ write fat entry (old cluster no, akt file cluster no)
+ FI;
+ write fat entry (akt file cluster no, last entry of fat chain);
+ akt file cluster no.
+
+END PROC next save cluster no;
+
+PROC close save (REAL CONST size):
+ enable stop;
+ IF no cluster saved
+ THEN insert dir entry (save name, 4088, 0.0)
+ ELSE copy fat to disk;
+ insert dir entry (save name, first file cluster no, size)
+ FI.
+
+END PROC close save;
+
+PROC erase table entrys (TEXT CONST name):
+ enable stop;
+ INT VAR first file cluster := first cluster;
+ delete dir entry (name);
+ erase fat chain (first file cluster);
+ copy fat to disk.
+
+first cluster:
+ dir.file list.entry [link index].first cluster.
+
+link index:
+ link (file thes, name).
+
+END PROC erase table entrys;
+
+INT PROC fat entry (INT CONST entry no):
+ fix bytes;
+ construct value.
+
+fix bytes:
+ INT VAR first byte no := entry no + entry no DIV 2.
+
+construct value:
+ IF entry no MOD 2 = 0
+ THEN (right byte MOD 16) * 256 + left byte
+ ELSE 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;
+
+INT PROC available fat entry:
+ FOR count FROM first possible available fat entry UPTO number of fat entrys - 1 REP
+ IF is available entry (count)
+ THEN first possible available fat entry := count;
+ LEAVE available fat entry WITH count
+ FI;
+ PER;
+ close action; error stop ("MS-DOS Datentraeger voll"); maxint.
+
+END PROC available fat entry;
+
+BOOL PROC is available entry (INT CONST entry no):
+ is zero entry.
+
+is zero entry:
+ IF entry no MOD 2 = 0
+ THEN (left byte = 0) CAND ((right byte MOD 16) = 0)
+ ELSE (right byte = 0) CAND ((left byte DIV 16) = 0)
+ FI.
+
+left byte:
+ fat byte (first byte no).
+
+right byte:
+ fat byte (first byte no + 1).
+
+first byte no:
+ entry no + entry no DIV 2.
+
+END PROC is available entry;
+
+PROC erase fat chain (INT CONST first entry):
+ INT VAR akt entry no := first entry,
+ entry := fat entry (akt entry no);
+ WHILE akt entry no not last chain entry no REP
+ erase akt entry;
+ akt entry no := entry;
+ entry := fat entry (akt entry no)
+ PER;
+ erase akt entry.
+
+akt entry no not last chain entry no:
+ (entry < last entry of fat chain) AND (entry > 1).
+
+erase akt entry:
+ write fat entry (akt entry no, 0).
+
+END PROC erase fat chain;
+
+PROC write fat entry (INT CONST entry no, value):
+ fix bytes;
+ remark write access (fat block of first byte);
+ remark write access (fat block of second byte);
+ write value;
+ update first possible available entry.
+
+fix bytes:
+ INT VAR first byte no := entry no + entry no DIV 2.
+
+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 first possible available fat entry :=
+ min (first possible available fat entry, entry no)
+ FI.
+
+END PROC write fat entry;
+
+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 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;
+
+PROC copy fat to disk:
+ INT VAR block no;
+ FOR block no FROM 0 UPTO number of fat sectors - 1 REP
+ IF was write access (block no)
+ THEN write fat block (block no)
+ FI
+ PER.
+
+END PROC copy fat to disk;
+
+PROC write fat block (INT CONST fat block no):
+ INT VAR fat copy no;
+ INT VAR return code;
+ disable stop;
+ FOR fat copy no FROM 0 UPTO number of fat copies -1 REP
+ write disk block (fat space, ds page no, block no, return code);
+ IF return code > 0
+ THEN close action
+ FI
+ PER;
+ remark no write access (block no);
+ enable stop.
+
+ds page no:
+ first non dummy ds page + fat block no + 1.
+
+block no:
+ begin of fat (fat copy no) + fat block no.
+
+END PROC write fat block;
+
+PROC read fat block (INT CONST fat block, BOOL CONST test block):
+ INT VAR fat copy no;
+ disable stop;
+ FOR fat copy no FROM 0 UPTO number of fat copies - 1 REP
+ clear error;
+ read disk block (fat space, ds page no, fat block no)
+ UNTIL NOT is error
+ PER;
+ IF is error
+ THEN close action
+ FI;
+ enable stop.
+
+ds page no:
+ IF test block
+ THEN first non dummy ds page
+ ELSE fat block + first non dummy ds page + 1
+ FI.
+
+fat block no:
+ begin of fat (fat copy no) + fat block.
+
+END PROC read fat block;
+
+PROC define write access table (BOOL CONST status):
+ FOR count FROM 1 UPTO number of fat sectors REP
+ write access [count] := status
+ PER.
+
+END PROC define write access table;
+
+PROC remark write access (INT CONST fat block no):
+ write access [fat block no + 1] := TRUE
+
+END PROC remark write access;
+
+PROC remark no write access (INT CONST fat block no):
+ write access [fat block no + 1] := FALSE
+
+END PROC remark no write access;
+
+BOOL PROC was write access (INT CONST fat block no):
+ write access [fat block no + 1]
+
+END PROC was write access;
+
+(*COND TEST
+PROC dump fat:
+ IF NOT exists ("fat dump")
+ THEN open file
+ FI;
+ DATASPACE VAR ds := nilspace;
+ FILE VAR in := sequential file (input, "fat dump"),
+ out := sequential file (output, ds);
+ INT VAR i;
+ TEXT VAR line;
+ FOR i FROM 0 UPTO number of fat entrys - 1 REP
+ dump fat entry
+ PER;
+ forget ("fat dump", quiet);
+ copy (ds, "fat dump");
+ forget (ds).
+
+open file:
+ in := sequential file (output, "fat dump");
+ FOR i FROM 0 UPTO number of fat entrys - 1 REP
+ putline (in, text (i, 4) + ": ")
+ PER.
+
+dump fat entry:
+ cout (i);
+ getline (in, line);
+ putline (out, line + " " + text (fat entry (i), 4)).
+
+END PROC dump fat;
+ENDCOND*)
+
+PROC load dir block (INT CONST block no, BOOL VAR last block):
+ last block := FALSE;
+ INT VAR return code;
+ read disk block (block ds, first non dummy ds page, block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI;
+ INT VAR entry no,
+ thes index;
+ FOR entry no FROM 0 UPTO dir entrys per block - 1 REP
+ dir entry := text 32 (block, entry no);
+ process entry
+ PER.
+
+process entry:
+ SELECT pos (""0"."229"", dir entry SUB 1) OF
+ CASE 1: end of dir search
+ CASE 2: main dir entry
+ CASE 3: free entry
+ OTHERWISE file entry
+ END SELECT.
+
+end of dir search:
+ last block := TRUE;
+ store begin of free area (loc (block no, entry no));
+ LEAVE load dir block.
+
+main dir entry:
+ (* no operation *).
+
+free entry:
+ store in free list (loc (block no, entry no)).
+
+file entry:
+ SELECT code (dir entry SUB 12) OF
+ CASE 8: volume label
+ CASE 16: sub dir entry
+ OTHERWISE dos file entry
+ END SELECT.
+
+volume label:
+ dir.disk label := text (dir entry, 1, 11).
+
+sub dir entry:
+ dir.dir list.no of entrys INCR 1;
+ insert (dir thes, name, thes index);
+ dir list entry := first cluster no.
+
+dos file entry:
+ IF dir.file list.no of entrys >= max dir entrys
+ THEN error stop ("Directorytabelle voll")
+ FI;
+ dir.file list.no of entrys INCR 1;
+ insert (file thes, name, thes index);
+ file list entry.first cluster := first cluster no;
+ file list entry.date and time := dos date + " " + dos time;
+ file list entry.size := dos storage;
+ file list entry.location.msdos block no := block no;
+ file list entry.location.block entry no := entry no.
+
+name:
+ IF name post <> ""
+ THEN name pre + "." + name post
+ ELSE name pre
+ FI.
+
+name pre:
+ compress (subtext (dir entry, 1, 8)).
+
+name post:
+ compress (subtext (dir entry, 9, 11)).
+
+file list entry:
+ dir.file list.entry [thes index].
+
+dir list entry:
+ dir.dir list.entry [thes index].
+
+first cluster no:
+ code (dir entry SUB 27) + 256 * code (dir entry SUB 28).
+
+dos storage:
+ real (code (dir entry SUB 29)) +
+ real (code (dir entry SUB 30)) * 256.0 +
+ real (code (dir entry SUB 31)) * 65536.0 +
+ real (code (dir entry SUB 32)) * 16777216.0.
+
+dos date:
+ day + "." + month + "." + year.
+
+day:
+ IF code (dir entry SUB 25) MOD 32 < 10
+ THEN "0" + text (code (dir entry SUB 25) MOD 32)
+ ELSE text (code (dir entry SUB 25) MOD 32)
+ FI.
+
+month:
+ INT VAR dummy := code (dir entry SUB 25) DIV 32 + 8 * (code (dir entry SUB 26) MOD 2);
+ IF dummy < 10
+ THEN "0" + text (dummy)
+ ELSE text (dummy)
+ FI.
+
+year:
+ text (80 + code (dir entry SUB 26) DIV 2, 2).
+
+dos time:
+ hour + ":" + minute.
+
+hour:
+ dummy := code (dir entry SUB 24) DIV 8;
+ IF dummy < 10
+ THEN "0" + text (dummy)
+ ELSE text (dummy)
+ FI.
+
+minute:
+ dummy := code (dir entry SUB 23) DIV 32 + 8 * (code (dir entry SUB 24) MOD 8);
+ IF dummy < 10
+ THEN "0" + text (dummy)
+ ELSE text (dummy)
+ FI.
+
+END PROC load dir block;
+
+PROC insert dir entry (TEXT CONST name, INT CONST start cluster, REAL CONST used storage):
+ (* name must be a dos name *)
+ LOCATION VAR ins pos := free location;
+ TEXT VAR akt date := date (clock (1)),
+ akt time := time of day (clock (1));
+ write disk entry;
+ write dir struct entry.
+
+write disk entry:
+ INT VAR return code;
+ read disk block (block ds, first non dummy ds page, ins pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI;
+ prepare name;
+ dir entry := name pre + name post + archive byte + (10 * ""0"") + dos time +
+ dos date + starting cluster + storage;
+ write text 32 (block, dir entry, ins pos.block entry no);
+ write disk block (block ds, first non dummy ds page,ins pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI.
+
+prepare name:
+ TEXT VAR name pre, name post;
+ IF point pos > 0
+ THEN name pre := subtext (name, 1, point pos - 1);
+ name post := subtext (name, point pos + 1);
+ name pre CAT (8 - LENGTH name pre) * " ";
+ name post CAT (3 - LENGTH name post) * " "
+ ELSE name pre := name + (8 - LENGTH name) * " ";
+ name post := " "
+ FI.
+
+point pos:
+ pos (name, ".").
+
+dos time:
+ 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:
+ 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)).
+
+starting cluster:
+ code (start cluster MOD 256) + code (start cluster DIV 256).
+
+storage:
+ code (int (round (256.0 * frac (used storage / 256.0), 0))) +
+ code (int (round (frac (floor (used storage / 256.0) / 256.0) * 256.0, 0))) +
+ code (int (floor (used storage / 65536.0))) +
+ code (0). (* maximal 16384 K *********************************)
+
+write dir struct entry:
+ INT VAR thes link;
+ insert (file thes, name, thes link);
+ file list entry.location := ins pos;
+ file list entry.first cluster := start cluster;
+ file list entry.date and time := akt date + " " + akt time;
+ file list entry.size := used storage.
+
+file list entry:
+ dir.filelist.entry [thes link].
+
+END PROC insert dir entry;
+
+PROC delete dir entry (TEXT CONST name):
+ LOCATION VAR del pos;
+ get del pos;
+ erase dir struct entry;
+ erase disk entry;
+ store in free list (del pos).
+
+get del pos:
+ del pos := dir.filelist.entry [link index].location.
+
+link index:
+ link (file thes, name).
+
+erase dir struct entry:
+ INT VAR i;
+ delete (file thes, name, i).
+
+erase disk entry:
+ INT VAR return code;
+ read disk block (block ds, first non dummy ds page, del pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI;
+ dir entry := text 32 (block, del pos.block entry no);
+ replace (dir entry, 1, ""229"");
+ write text 32 (block, dir entry, del pos.block entry no);
+ write disk block (block ds, first non dummy ds page, del pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI.
+
+END PROC delete dir entry;
+
+.
+file thes:
+ dir.filelist.thes.
+
+dir thes:
+ dir.dir list.thes.
+
+(*********************** dir information ******************************)
+
+THESAURUS PROC dir all:
+ file thes.
+
+END PROC dir all;
+
+BOOL PROC dir contains (TEXT CONST name):
+ file thes CONTAINS name
+
+END PROC dir contains;
+
+PROC dir list (DATASPACE VAR ds):
+ enable stop;
+ open list file;
+ list files;
+ list dirs;
+ write list head.
+
+open list file:
+ forget (ds);
+ ds := nilspace;
+ FILE VAR list file := sequential file (output, ds);
+ putline (list file, "").
+
+list files:
+ INT VAR number := 0;
+ get (file thes, name, number);
+ WHILE number > 0 REP
+ generate file list line;
+ get (file thes, name, number)
+ PER.
+
+generate file list line:
+ write (list file, centered name);
+ write (list file, " ");
+ write (list file, text (act file entry.size, 11, 0));
+ write (list file, " Bytes belegt ");
+ write (list file, act file entry.date and time);
+(*COND TEST
+ write (list file, " +++ ");
+ write (list file, text (act file entry.first cluster));
+ENDCOND*)
+ line (list file).
+
+list dirs:
+ number := 0;
+ get (dir thes, name, number);
+ WHILE number > 0 REP
+ generate dir list line;
+ get (dir thes, name, number)
+ PER.
+
+generate dir list line:
+ write (list file, centered name);
+ write (list file, " <DIR>");
+(*COND TEST
+ write (list file, " +++ ");
+ write (list file, text (dir.dir list.entry [number]));
+ENDCOND*)
+ line (list file).
+
+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).
+
+act file entry:
+ dir.file list.entry [number].
+
+write list head:
+ head line (list file, head).
+
+head:
+ "DOS" + disk label string + path string.
+
+disk label string:
+ IF dir.disk label <> ""
+ THEN ": " + dir.disk label
+ ELSE ""
+ FI.
+
+path string:
+ IF dir.path <> ""
+ THEN " PATH: " + dir.path
+ ELSE ""
+ FI.
+
+END PROC dir list;
+
+(************ free list handling ******************************************)
+LOCATION PROC loc (INT CONST block, entry):
+ LOCATION : (block, entry)
+
+END PROC loc;
+
+BOOL OP > (LOCATION CONST l, r):
+ l.msdos block no > r.msdos block no
+ OR ((l.msdos block no = r.msdos block no) AND
+ (l.block entry no > r.block entry no) )
+
+END OP >;
+
+OP INCR (LOCATION VAR l):
+ IF l.block entry no = dir entrys per block -1
+ THEN l.block entry no := 0;
+ l.msdos block no INCR 1
+ ELSE l.block entry no INCR 1
+ FI.
+
+END OP INCR;
+
+PROC init free list (INT CONST dir root):
+ dir.freelist.stacktop := 0;
+ dir.freelist.begin of free area.msdos block no := maxint;
+ dir.freelist.end of dir.msdos block no := -1;
+ dir.freelist.dir chain root := dir root.
+
+END PROC init free list;
+
+BOOL PROC dir full:
+ stack empty AND free area empty AND NOT expansion alloweded.
+
+stack empty:
+ dir.freelist.stacktop < 1.
+
+free area empty:
+ dir.freelist.begin of free area > dir.freelist.end of dir.
+
+expansion alloweded:
+ dir.freelist.dir chain root >= 0.
+
+END PROC dir full;
+
+PROC store in free list (LOCATION CONST free):
+ dir.freelist.stacktop INCR 1;
+ dir.freelist.stack [top] := free.
+
+top:
+ dir.freelist.stacktop.
+
+END PROC store in free list;
+
+PROC store begin of free area (LOCATION CONST begin):
+ dir.freelist.begin of free area := begin
+
+END PROC store begin of free area;
+
+PROC store end of dir (LOCATION CONST end):
+ dir.freelist.end of dir := end
+
+END PROC store end of dir;
+
+LOCATION PROC free location:
+ LOCATION VAR result;
+ IF dir.freelist.stacktop > 0
+ THEN pop
+ ELIF NOT free area empty
+ THEN first of free area
+ ELIF expansion alloweded
+ THEN allocate new dir space;
+ result := free location
+ ELSE error stop ("Directorytabelle voll")
+ FI;
+ result.
+
+pop:
+ result := dir.freelist.stack [top];
+ top DECR 1.
+
+top:
+ dir.freelist.stack top.
+
+free area empty:
+ dir.freelist.begin of free area > dir.freelist.end of dir.
+
+first of free area:
+ result := dir.freelist.begin of free area;
+ INCR dir.freelist.begin of free area.
+
+expansion alloweded:
+ dir.freelist.dir chain root >= 0.
+
+END PROC free location;
+
+PROC allocate new dir space:
+ enable stop;
+ INT VAR new cluster no := available fat entry;
+ IF new cluster no < 0
+ THEN error stop ("MS-DOS Datentraeger voll")
+ FI;
+ INT VAR last entry no;
+ search last entry of fat chain;
+ write fat entry (new cluster no, 4095);
+ write fat entry (last entry no, new cluster no);
+ copy fat to disk;
+ store begin of free area (loc (first new block, 0));
+ store end of dir (loc (last new block, dir entrys per block - 1));
+ init new dir cluster.
+
+search last entry of fat chain:
+ last entry no := dir.freelist.dir chain root;
+ WHILE fat entry (last entry no) < last entry of fat chain REP
+ last entry no := fat entry (last entry no)
+ PER.
+
+init new dir cluster:
+ FOR count FROM 0 UPTO dir entrys per block - 1 REP
+ write text 32 (block, ""0"" + 31 * ""246"", count)
+ PER;
+ disable stop;
+ FOR count FROM first new block UPTO last new block REP
+ write disk block (block ds, count);
+ PER.
+
+first new block:
+ firstblock no of cluster (new cluster no).
+
+last new block:
+ first block no of cluster (new cluster no) + sectors per cluster - 1.
+
+END PROC allocate new dir space;
+
+(*COND TEST
+PROC dump freelist:
+ command dialogue (FALSE);
+ FILE VAR f := sequential file (output, "freelistdump");
+ INT VAR i;
+ putline (f, "STACKTOP: " + text (fl.stacktop));
+ putline (f, "STACK:");
+ FOR i FROM 1 UPTO 16 * number of dir sectors REP
+ putline (f, " " + text (i, 4) + ": " +
+ text (fl.stack [i].msdos block no) + ", " +
+ text (fl.stack [i].block entry no))
+ PER;
+ line (f);
+ putline (f, "BEGIN OF FREE: " + text (fl.begin of free area.msdos block no) +
+ ", " + text (fl.begin of free area.block entry no));
+ putline (f, "END OF DIR: " + text (fl.end of dir.msdos block no) +
+ ", " + text (fl.end of dir.block entry no)).
+
+fl:
+ dir.freelist.
+
+END PROC dump free list;
+ENDCOND*)
+
+END PACKET dos fat and dir;
diff --git a/system/dos/1986/src/fat and dir.dos.hd b/system/dos/1986/src/fat and dir.dos.hd
new file mode 100644
index 0000000..7d53f41
--- /dev/null
+++ b/system/dos/1986/src/fat and dir.dos.hd
@@ -0,0 +1,1190 @@
+PACKET dos fat and dir DEFINES (* Copyright (C) 1985, 86 *)
+ (* Frank Klapper *)
+ open disk, (* 30.05.86 *)
+ close disk,
+ format disk,
+ disk changed,
+ open fetch,
+ next fetch cluster no,
+ open save,
+ next save cluster no,
+ close save,
+ erase table entrys,
+(*COND TEST
+ dump fat,
+ENDCOND*)
+ dir all,
+ dir list,
+ dir contains:
+
+LET fat row size = 16384, (* 32 KB *)
+ max fat blocks = 25,
+ first fat entry no = 2,
+ last entry of fat chain = 4088,
+ dir entrys per block = 16,
+ max dir entrys = 1600, (* 100 KB *)
+ archive byte = " ";
+
+LET FAT = BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block row,
+ ROW fat row size INT fat row);
+
+LET LOCATION = STRUCT (INT msdos block no,
+ block entry no),
+
+ FILEENTRY = STRUCT (TEXT date and time,
+ REAL size,
+ INT first cluster,
+ LOCATION location),
+
+ DIRENTRY = INT,
+
+ FILELIST = STRUCT (THESAURUS thes,
+ ROW max dir entrys FILEENTRY entry,
+ INT no of entrys),
+
+ DIRLIST = STRUCT (THESAURUS thes,
+ ROW max dir entrys DIRENTRY entry,
+ INT no of entrys),
+
+ FREELIST = STRUCT (ROW max dir entrys LOCATION stack,
+ INT stacktop,
+ LOCATION begin of free area,
+ end of dir,
+ INT dir chain root),
+
+ DIR = BOUND STRUCT (FILELIST filelist,
+ DIRLIST dirlist,
+ FREELIST freelist,
+ TEXT disklabel,
+ path);
+
+INITFLAG VAR this packet := FALSE;
+
+DATASPACE VAR fat space,
+ dir ds,
+ block ds;
+
+BOOL VAR dataspaces open;
+
+FAT VAR fat struct;
+ROW max fat blocks BOOL VAR write access;
+INT VAR first possible available fat entry;
+
+DIR VAR dir;
+
+CLUSTER VAR block;
+
+INT VAR akt file cluster no,
+ first file cluster no;
+BOOL VAR no cluster saved;
+TEXT VAR save name;
+
+INT VAR count;
+
+TEXT VAR convert buffer := " ",
+ name,
+ dir entry;
+
+.fat:
+ fat struct.fat row.
+
+PROC open disk (TEXT CONST subdir path):
+ disable stop;
+ enable open disk (subdir path);
+ IF is error
+ THEN close action
+ FI
+
+END PROC open disk;
+
+PROC enable open disk (TEXT CONST subdir path):
+ enable stop;
+ init dataspaces;
+ open fat;
+ open dir.
+
+open fat:
+ reset disk attributes;
+ read first fat block;
+ set disk attributes (fat byte (0));
+ read other fat blocks;
+ define write access table (FALSE);
+ first possible available fat entry := first fat entry no.
+
+ read first fat block:
+ read fat block (0, FALSE).
+
+read other fat blocks:
+ INT VAR block no;
+ FOR block no FROM 1 UPTO number of fat sectors - 1 REP
+ read fat block (block no, FALSE)
+ PER.
+
+open dir:
+ init dir struct (subdir path, -1);
+ load main dir blocks;
+ load subdirs if necessary.
+
+load main dir blocks:
+ BOOL VAR last block;
+ store end of dir (loc (end of main dir, dir entrys per block - 1));
+ FOR block no FROM begin of dir UPTO end of main dir REP
+ load dir block (block no, last block);
+ UNTIL last block
+ PER.
+
+end of main dir:
+ begin of dir + number of dir sectors - 1.
+
+load subdirs if necessary:
+ TEXT VAR path := subdir path;
+ WHILE path <> "" REP
+ load next subdir if possible
+ PER.
+
+load next subdir if possible:
+ INT VAR cluster no;
+ get next subdir name;
+ get first cluster no of subdir table;
+ clear dir entrys (cluster no);
+ WHILE cluster no >= 0 REP
+ load subdir entrys of cluster;
+ cluster no := next fetch cluster no
+ UNTIL last block
+ PER.
+
+get next subdir name:
+ TEXT VAR subdir name;
+ IF (path SUB 1) <> "\"
+ THEN error stop ("ungltige Pfadbezeichnung")
+ FI;
+ INT VAR backslash pos := pos (path, "\", "\", 2);
+ IF backslash pos = 0
+ THEN subdir name := subtext (path, 2);
+ path := ""
+ ELSE subdir name := subtext (path, 2, backslash pos - 1);
+ path := subtext (path, backslash pos)
+ FI;
+ subdir name := adapted name (subdir name, TRUE).
+
+get first cluster no of subdir table:
+ IF dir thes CONTAINS subdir name
+ THEN open fetch subdir (subdir name, cluster no);
+ ELSE error stop ("Subdirectory existiert nicht")
+ FI.
+
+load subdir entrys of cluster:
+ store end of dir (loc (last block no of cluster, dir entrys per block - 1));
+ FOR block no FROM 0 UPTO (sectors per cluster - 1) REP
+ load dir block (first block no of cluster (cluster no) + block no, last block)
+ UNTIL last block
+ PER.
+
+last block no of cluster:
+ first block no of cluster (cluster no) + sectors per cluster - 1.
+
+END PROC enable open disk;
+
+PROC init dataspaces:
+ enable stop;
+ IF NOT initialized (this packet)
+ THEN dataspaces open := FALSE
+ FI;
+ IF NOT dataspaces open
+ THEN disable stop;
+ dataspaces open := TRUE;
+ fat space := nilspace;
+ dir ds := nilspace;
+ block ds := nilspace;
+ fat struct := fat space;
+ dir := dir ds;
+ block := block ds
+ FI.
+
+END PROC init dataspaces;
+
+PROC init dir struct (TEXT CONST path string, INT CONST root):
+ clear dir entrys (root);
+ dir.path := path string;
+ dir.disk label := "".
+
+END PROC init dir struct;
+
+PROC clear dir entrys (INT CONST root):
+ init file list;
+ init dir list;
+ init free list (root).
+
+init file list:
+ dir.file list.thes := empty thesaurus;
+ dir.file list.no of entrys := 0.
+
+init dir list:
+ dir.dir list.thes := empty thesaurus;
+ dir.dir list.no of entrys := 0.
+
+END PROC clear dir entrys;
+
+PROC close disk:
+ enable stop;
+ IF NOT initialized (this packet)
+ THEN dataspaces open := FALSE
+ FI;
+ IF dataspaces open
+ THEN forget (dir ds);
+ forget (block ds);
+ forget (fat space);
+ dataspaces open := FALSE
+ FI.
+
+END PROC close disk;
+
+(*COND FLOPPY
+PROC format disk:
+ enable stop;
+ init dataspaces;
+ format fat;
+ format dir.
+
+format fat:
+ write first four fat bytes;
+ write other fat bytes;
+ define write access table (TRUE);
+ copy fat to disk.
+
+write first four fat bytes:
+ fat [1] := word (first fat byte, 255);
+ fat [2] := word (255, 0).
+
+write other fat bytes:
+ FOR count FROM 3 UPTO fat length REP
+ fat [count] := 0
+ PER.
+
+fat length:
+ INT VAR len := number of fat entrys + number of fat entrys DIV 2
+ + number of fat entrys MOD 2;
+ len DIV 2 + len MOD 2.
+
+format dir:
+ init dir struct ("", -1);
+ store begin of free area (loc (begin of dir, 0));
+ store end of dir (loc (end of dir, dir entrys per block - 1));
+ FOR count FROM 0 UPTO dir entrys per block - 1 REP
+ write text 32 (block, ""0"" + 31 * ""246"", count)
+ PER;
+ disable stop;
+ FOR count FROM begin of dir UPTO end of dir REP
+ write disk block (block ds, count);
+ PER.
+
+end of dir:
+ begin of dir + number of dir sectors - 1.
+
+END PROC format disk;
+ENDCOND*)
+
+(*COND HDU*)
+PROC disk clear:
+ error stop ("nicht implementiert")
+
+END PROC disk clear;
+
+PROC format disk:
+ error stop ("nicht implementiert")
+
+END PROC format disk;
+(*ENDCOND*)
+
+INT PROC word (INT CONST low byte, high byte):
+ convert buffer := code (low byte) + code (high byte);
+ convert buffer ISUB 1.
+
+END PROC word;
+
+BOOL PROC disk changed:
+(*COND FLOPPY
+ disable stop;
+ NOT first fat block ok COR is error (* must be COR *)
+ENDCOND*)
+(*COND HDU*)
+ FALSE
+(*ENDCOND*)
+
+END PROC disk changed;
+
+BOOL PROC first fat block ok:
+ enable stop;
+ read fat block (0, TRUE);
+ FOR count FROM 1 UPTO 256 REP
+ compare word
+ PER;
+ TRUE.
+
+compare word:
+ IF fat struct.fat row [count] <> fat struct.block row [count]
+ THEN LEAVE first fat block ok WITH FALSE
+ FI.
+
+END PROC first fat block ok;
+
+PROC open fetch (TEXT CONST name, REAL VAR size, INT VAR first cluster no):
+ enable stop;
+ first cluster no := dir.file list.entry [link index].first cluster;
+ size := dir.file list.entry [link index].size;
+ IF first cluster no >= 4088
+ THEN first cluster no := -1
+ FI;
+ akt file cluster no := first cluster no.
+
+link index:
+ link (file thes, name).
+
+END PROC open fetch;
+
+PROC open fetch subdir (TEXT CONST subdir name, INT VAR first cluster no):
+ first cluster no := dir.dir list.entry [link index];
+ IF first cluster no >= 4088
+ THEN first cluster no := -1
+ FI;
+ akt file cluster no := first cluster no.
+
+link index:
+ link (dir thes, subdir name).
+
+END PROC open fetch subdir;
+
+INT PROC next fetch cluster no:
+ enable stop;
+ akt file cluster no := fat entry (akt file cluster no);
+ IF akt file cluster no < 4088 (*ff8h *)
+ THEN akt file cluster no
+ ELSE -1
+ FI.
+
+END PROC next fetch cluster no;
+
+PROC open save (TEXT CONST file name):
+ enable stop;
+ save name := file name;
+ IF dir full
+ THEN error stop ("Directory voll")
+ FI;
+ IF dir thes CONTAINS file name
+ THEN error stop ("Subdirectory mit gleichem Namen existiert bereits")
+ FI;
+ IF file thes CONTAINS file name
+ THEN error stop ("Datei mit gleichem Namen existiert bereits")
+ FI;
+ no cluster saved := TRUE.
+
+END PROC open save;
+
+INT PROC next save cluster no:
+ enable stop;
+ IF no cluster saved
+ THEN akt file cluster no := available fat entry;
+ first file cluster no := akt file cluster no;
+ no cluster saved := FALSE
+ ELSE INT VAR old cluster no := akt file cluster no;
+ akt file cluster no := available fat entry;
+ write fat entry (old cluster no, akt file cluster no)
+ FI;
+ write fat entry (akt file cluster no, last entry of fat chain);
+ akt file cluster no.
+
+END PROC next save cluster no;
+
+PROC close save (REAL CONST size):
+ enable stop;
+ IF no cluster saved
+ THEN insert dir entry (save name, 4088, 0.0)
+ ELSE copy fat to disk;
+ insert dir entry (save name, first file cluster no, size)
+ FI.
+
+END PROC close save;
+
+PROC erase table entrys (TEXT CONST name):
+ enable stop;
+ INT VAR first file cluster := first cluster;
+ delete dir entry (name);
+ erase fat chain (first file cluster);
+ copy fat to disk.
+
+first cluster:
+ dir.file list.entry [link index].first cluster.
+
+link index:
+ link (file thes, name).
+
+END PROC erase table entrys;
+
+INT PROC fat entry (INT CONST entry no):
+ fix bytes;
+ construct value.
+
+fix bytes:
+ INT VAR first byte no := entry no + entry no DIV 2.
+
+construct value:
+ IF entry no MOD 2 = 0
+ THEN (right byte MOD 16) * 256 + left byte
+ ELSE 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;
+
+INT PROC available fat entry:
+ FOR count FROM first possible available fat entry UPTO number of fat entrys - 1 REP
+ IF is available entry (count)
+ THEN first possible available fat entry := count;
+ LEAVE available fat entry WITH count
+ FI;
+ PER;
+ close action; error stop ("MS-DOS Datentraeger voll"); maxint.
+
+END PROC available fat entry;
+
+BOOL PROC is available entry (INT CONST entry no):
+ is zero entry.
+
+is zero entry:
+ IF entry no MOD 2 = 0
+ THEN (left byte = 0) CAND ((right byte MOD 16) = 0)
+ ELSE (right byte = 0) CAND ((left byte DIV 16) = 0)
+ FI.
+
+left byte:
+ fat byte (first byte no).
+
+right byte:
+ fat byte (first byte no + 1).
+
+first byte no:
+ entry no + entry no DIV 2.
+
+END PROC is available entry;
+
+PROC erase fat chain (INT CONST first entry):
+ INT VAR akt entry no := first entry,
+ entry := fat entry (akt entry no);
+ WHILE akt entry no not last chain entry no REP
+ erase akt entry;
+ akt entry no := entry;
+ entry := fat entry (akt entry no)
+ PER;
+ erase akt entry.
+
+akt entry no not last chain entry no:
+ (entry < last entry of fat chain) AND (entry > 1).
+
+erase akt entry:
+ write fat entry (akt entry no, 0).
+
+END PROC erase fat chain;
+
+PROC write fat entry (INT CONST entry no, value):
+ fix bytes;
+ remark write access (fat block of first byte);
+ remark write access (fat block of second byte);
+ write value;
+ update first possible available entry.
+
+fix bytes:
+ INT VAR first byte no := entry no + entry no DIV 2.
+
+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 first possible available fat entry :=
+ min (first possible available fat entry, entry no)
+ FI.
+
+END PROC write fat entry;
+
+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 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;
+
+PROC copy fat to disk:
+ INT VAR block no;
+ FOR block no FROM 0 UPTO number of fat sectors - 1 REP
+ IF was write access (block no)
+ THEN write fat block (block no)
+ FI
+ PER.
+
+END PROC copy fat to disk;
+
+PROC write fat block (INT CONST fat block no):
+ INT VAR fat copy no;
+ INT VAR return code;
+ disable stop;
+ FOR fat copy no FROM 0 UPTO number of fat copies -1 REP
+ write disk block (fat space, ds page no, block no, return code);
+ IF return code > 0
+ THEN close action
+ FI
+ PER;
+ remark no write access (block no);
+ enable stop.
+
+ds page no:
+ first non dummy ds page + fat block no + 1.
+
+block no:
+ begin of fat (fat copy no) + fat block no.
+
+END PROC write fat block;
+
+PROC read fat block (INT CONST fat block, BOOL CONST test block):
+ INT VAR fat copy no;
+ disable stop;
+ FOR fat copy no FROM 0 UPTO number of fat copies - 1 REP
+ clear error;
+ read disk block (fat space, ds page no, fat block no)
+ UNTIL NOT is error
+ PER;
+ IF is error
+ THEN close action
+ FI;
+ enable stop.
+
+ds page no:
+ IF test block
+ THEN first non dummy ds page
+ ELSE fat block + first non dummy ds page + 1
+ FI.
+
+fat block no:
+ begin of fat (fat copy no) + fat block.
+
+END PROC read fat block;
+
+PROC define write access table (BOOL CONST status):
+ FOR count FROM 1 UPTO number of fat sectors REP
+ write access [count] := status
+ PER.
+
+END PROC define write access table;
+
+PROC remark write access (INT CONST fat block no):
+ write access [fat block no + 1] := TRUE
+
+END PROC remark write access;
+
+PROC remark no write access (INT CONST fat block no):
+ write access [fat block no + 1] := FALSE
+
+END PROC remark no write access;
+
+BOOL PROC was write access (INT CONST fat block no):
+ write access [fat block no + 1]
+
+END PROC was write access;
+
+(*COND TEST
+PROC dump fat:
+ IF NOT exists ("fat dump")
+ THEN open file
+ FI;
+ DATASPACE VAR ds := nilspace;
+ FILE VAR in := sequential file (input, "fat dump"),
+ out := sequential file (output, ds);
+ INT VAR i;
+ TEXT VAR line;
+ FOR i FROM 0 UPTO number of fat entrys - 1 REP
+ dump fat entry
+ PER;
+ forget ("fat dump", quiet);
+ copy (ds, "fat dump");
+ forget (ds).
+
+open file:
+ in := sequential file (output, "fat dump");
+ FOR i FROM 0 UPTO number of fat entrys - 1 REP
+ putline (in, text (i, 4) + ": ")
+ PER.
+
+dump fat entry:
+ cout (i);
+ getline (in, line);
+ putline (out, line + " " + text (fat entry (i), 4)).
+
+END PROC dump fat;
+ENDCOND*)
+
+PROC load dir block (INT CONST block no, BOOL VAR last block):
+ last block := FALSE;
+ INT VAR return code;
+ read disk block (block ds, first non dummy ds page, block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI;
+ INT VAR entry no,
+ thes index;
+ FOR entry no FROM 0 UPTO dir entrys per block - 1 REP
+ dir entry := text 32 (block, entry no);
+ process entry
+ PER.
+
+process entry:
+ SELECT pos (""0"."229"", dir entry SUB 1) OF
+ CASE 1: end of dir search
+ CASE 2: main dir entry
+ CASE 3: free entry
+ OTHERWISE file entry
+ END SELECT.
+
+end of dir search:
+ last block := TRUE;
+ store begin of free area (loc (block no, entry no));
+ LEAVE load dir block.
+
+main dir entry:
+ (* no operation *).
+
+free entry:
+ store in free list (loc (block no, entry no)).
+
+file entry:
+ SELECT code (dir entry SUB 12) OF
+ CASE 8: volume label
+ CASE 16: sub dir entry
+ OTHERWISE dos file entry
+ END SELECT.
+
+volume label:
+ dir.disk label := text (dir entry, 1, 11).
+
+sub dir entry:
+ dir.dir list.no of entrys INCR 1;
+ insert (dir thes, name, thes index);
+ dir list entry := first cluster no.
+
+dos file entry:
+ IF dir.file list.no of entrys >= max dir entrys
+ THEN error stop ("Directorytabelle voll")
+ FI;
+ dir.file list.no of entrys INCR 1;
+ insert (file thes, name, thes index);
+ file list entry.first cluster := first cluster no;
+ file list entry.date and time := dos date + " " + dos time;
+ file list entry.size := dos storage;
+ file list entry.location.msdos block no := block no;
+ file list entry.location.block entry no := entry no.
+
+name:
+ IF name post <> ""
+ THEN name pre + "." + name post
+ ELSE name pre
+ FI.
+
+name pre:
+ compress (subtext (dir entry, 1, 8)).
+
+name post:
+ compress (subtext (dir entry, 9, 11)).
+
+file list entry:
+ dir.file list.entry [thes index].
+
+dir list entry:
+ dir.dir list.entry [thes index].
+
+first cluster no:
+ code (dir entry SUB 27) + 256 * code (dir entry SUB 28).
+
+dos storage:
+ real (code (dir entry SUB 29)) +
+ real (code (dir entry SUB 30)) * 256.0 +
+ real (code (dir entry SUB 31)) * 65536.0 +
+ real (code (dir entry SUB 32)) * 16777216.0.
+
+dos date:
+ day + "." + month + "." + year.
+
+day:
+ IF code (dir entry SUB 25) MOD 32 < 10
+ THEN "0" + text (code (dir entry SUB 25) MOD 32)
+ ELSE text (code (dir entry SUB 25) MOD 32)
+ FI.
+
+month:
+ INT VAR dummy := code (dir entry SUB 25) DIV 32 + 8 * (code (dir entry SUB 26) MOD 2);
+ IF dummy < 10
+ THEN "0" + text (dummy)
+ ELSE text (dummy)
+ FI.
+
+year:
+ text (80 + code (dir entry SUB 26) DIV 2, 2).
+
+dos time:
+ hour + ":" + minute.
+
+hour:
+ dummy := code (dir entry SUB 24) DIV 8;
+ IF dummy < 10
+ THEN "0" + text (dummy)
+ ELSE text (dummy)
+ FI.
+
+minute:
+ dummy := code (dir entry SUB 23) DIV 32 + 8 * (code (dir entry SUB 24) MOD 8);
+ IF dummy < 10
+ THEN "0" + text (dummy)
+ ELSE text (dummy)
+ FI.
+
+END PROC load dir block;
+
+PROC insert dir entry (TEXT CONST name, INT CONST start cluster, REAL CONST used storage):
+ (* name must be a dos name *)
+ LOCATION VAR ins pos := free location;
+ TEXT VAR akt date := date (clock (1)),
+ akt time := time of day (clock (1));
+ write disk entry;
+ write dir struct entry.
+
+write disk entry:
+ INT VAR return code;
+ read disk block (block ds, first non dummy ds page, ins pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI;
+ prepare name;
+ dir entry := name pre + name post + archive byte + (10 * ""0"") + dos time +
+ dos date + starting cluster + storage;
+ write text 32 (block, dir entry, ins pos.block entry no);
+ write disk block (block ds, first non dummy ds page,ins pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI.
+
+prepare name:
+ TEXT VAR name pre, name post;
+ IF point pos > 0
+ THEN name pre := subtext (name, 1, point pos - 1);
+ name post := subtext (name, point pos + 1);
+ name pre CAT (8 - LENGTH name pre) * " ";
+ name post CAT (3 - LENGTH name post) * " "
+ ELSE name pre := name + (8 - LENGTH name) * " ";
+ name post := " "
+ FI.
+
+point pos:
+ pos (name, ".").
+
+dos time:
+ 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:
+ 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)).
+
+starting cluster:
+ code (start cluster MOD 256) + code (start cluster DIV 256).
+
+storage:
+ code (int (round (256.0 * frac (used storage / 256.0), 0))) +
+ code (int (round (frac (floor (used storage / 256.0) / 256.0) * 256.0, 0))) +
+ code (int (floor (used storage / 65536.0))) +
+ code (0). (* maximal 16384 K *********************************)
+
+write dir struct entry:
+ INT VAR thes link;
+ insert (file thes, name, thes link);
+ file list entry.location := ins pos;
+ file list entry.first cluster := start cluster;
+ file list entry.date and time := akt date + " " + akt time;
+ file list entry.size := used storage.
+
+file list entry:
+ dir.filelist.entry [thes link].
+
+END PROC insert dir entry;
+
+PROC delete dir entry (TEXT CONST name):
+ LOCATION VAR del pos;
+ get del pos;
+ erase dir struct entry;
+ erase disk entry;
+ store in free list (del pos).
+
+get del pos:
+ del pos := dir.filelist.entry [link index].location.
+
+link index:
+ link (file thes, name).
+
+erase dir struct entry:
+ INT VAR i;
+ delete (file thes, name, i).
+
+erase disk entry:
+ INT VAR return code;
+ read disk block (block ds, first non dummy ds page, del pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI;
+ dir entry := text 32 (block, del pos.block entry no);
+ replace (dir entry, 1, ""229"");
+ write text 32 (block, dir entry, del pos.block entry no);
+ write disk block (block ds, first non dummy ds page, del pos.msdos block no, return code);
+ IF return code > 0
+ THEN close action;
+ io error (return code)
+ FI.
+
+END PROC delete dir entry;
+
+.
+file thes:
+ dir.filelist.thes.
+
+dir thes:
+ dir.dir list.thes.
+
+(*********************** dir information ******************************)
+
+THESAURUS PROC dir all:
+ file thes.
+
+END PROC dir all;
+
+BOOL PROC dir contains (TEXT CONST name):
+ file thes CONTAINS name
+
+END PROC dir contains;
+
+PROC dir list (DATASPACE VAR ds):
+ enable stop;
+ open list file;
+ list files;
+ list dirs;
+ write list head.
+
+open list file:
+ forget (ds);
+ ds := nilspace;
+ FILE VAR list file := sequential file (output, ds);
+ putline (list file, "").
+
+list files:
+ INT VAR number := 0;
+ get (file thes, name, number);
+ WHILE number > 0 REP
+ generate file list line;
+ get (file thes, name, number)
+ PER.
+
+generate file list line:
+ write (list file, centered name);
+ write (list file, " ");
+ write (list file, text (act file entry.size, 11, 0));
+ write (list file, " Bytes belegt ");
+ write (list file, act file entry.date and time);
+(*COND TEST
+ write (list file, " +++ ");
+ write (list file, text (act file entry.first cluster));
+ENDCOND*)
+ line (list file).
+
+list dirs:
+ number := 0;
+ get (dir thes, name, number);
+ WHILE number > 0 REP
+ generate dir list line;
+ get (dir thes, name, number)
+ PER.
+
+generate dir list line:
+ write (list file, centered name);
+ write (list file, " <DIR>");
+(*COND TEST
+ write (list file, " +++ ");
+ write (list file, text (dir.dir list.entry [number]));
+ENDCOND*)
+ line (list file).
+
+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).
+
+act file entry:
+ dir.file list.entry [number].
+
+write list head:
+ head line (list file, head).
+
+head:
+ "DOS" + disk label string + path string.
+
+disk label string:
+ IF dir.disk label <> ""
+ THEN ": " + dir.disk label
+ ELSE ""
+ FI.
+
+path string:
+ IF dir.path <> ""
+ THEN " PATH: " + dir.path
+ ELSE ""
+ FI.
+
+END PROC dir list;
+
+(************ free list handling ******************************************)
+LOCATION PROC loc (INT CONST block, entry):
+ LOCATION : (block, entry)
+
+END PROC loc;
+
+BOOL OP > (LOCATION CONST l, r):
+ l.msdos block no > r.msdos block no
+ OR ((l.msdos block no = r.msdos block no) AND
+ (l.block entry no > r.block entry no) )
+
+END OP >;
+
+OP INCR (LOCATION VAR l):
+ IF l.block entry no = dir entrys per block -1
+ THEN l.block entry no := 0;
+ l.msdos block no INCR 1
+ ELSE l.block entry no INCR 1
+ FI.
+
+END OP INCR;
+
+PROC init free list (INT CONST dir root):
+ dir.freelist.stacktop := 0;
+ dir.freelist.begin of free area.msdos block no := maxint;
+ dir.freelist.end of dir.msdos block no := -1;
+ dir.freelist.dir chain root := dir root.
+
+END PROC init free list;
+
+BOOL PROC dir full:
+ stack empty AND free area empty AND NOT expansion alloweded.
+
+stack empty:
+ dir.freelist.stacktop < 1.
+
+free area empty:
+ dir.freelist.begin of free area > dir.freelist.end of dir.
+
+expansion alloweded:
+ dir.freelist.dir chain root >= 0.
+
+END PROC dir full;
+
+PROC store in free list (LOCATION CONST free):
+ dir.freelist.stacktop INCR 1;
+ dir.freelist.stack [top] := free.
+
+top:
+ dir.freelist.stacktop.
+
+END PROC store in free list;
+
+PROC store begin of free area (LOCATION CONST begin):
+ dir.freelist.begin of free area := begin
+
+END PROC store begin of free area;
+
+PROC store end of dir (LOCATION CONST end):
+ dir.freelist.end of dir := end
+
+END PROC store end of dir;
+
+LOCATION PROC free location:
+ LOCATION VAR result;
+ IF dir.freelist.stacktop > 0
+ THEN pop
+ ELIF NOT free area empty
+ THEN first of free area
+ ELIF expansion alloweded
+ THEN allocate new dir space;
+ result := free location
+ ELSE error stop ("Directorytabelle voll")
+ FI;
+ result.
+
+pop:
+ result := dir.freelist.stack [top];
+ top DECR 1.
+
+top:
+ dir.freelist.stack top.
+
+free area empty:
+ dir.freelist.begin of free area > dir.freelist.end of dir.
+
+first of free area:
+ result := dir.freelist.begin of free area;
+ INCR dir.freelist.begin of free area.
+
+expansion alloweded:
+ dir.freelist.dir chain root >= 0.
+
+END PROC free location;
+
+PROC allocate new dir space:
+ enable stop;
+ INT VAR new cluster no := available fat entry;
+ IF new cluster no < 0
+ THEN error stop ("MS-DOS Datentraeger voll")
+ FI;
+ INT VAR last entry no;
+ search last entry of fat chain;
+ write fat entry (new cluster no, 4095);
+ write fat entry (last entry no, new cluster no);
+ copy fat to disk;
+ store begin of free area (loc (first new block, 0));
+ store end of dir (loc (last new block, dir entrys per block - 1));
+ init new dir cluster.
+
+search last entry of fat chain:
+ last entry no := dir.freelist.dir chain root;
+ WHILE fat entry (last entry no) < last entry of fat chain REP
+ last entry no := fat entry (last entry no)
+ PER.
+
+init new dir cluster:
+ FOR count FROM 0 UPTO dir entrys per block - 1 REP
+ write text 32 (block, ""0"" + 31 * ""246"", count)
+ PER;
+ disable stop;
+ FOR count FROM first new block UPTO last new block REP
+ write disk block (block ds, count);
+ PER.
+
+first new block:
+ firstblock no of cluster (new cluster no).
+
+last new block:
+ first block no of cluster (new cluster no) + sectors per cluster - 1.
+
+END PROC allocate new dir space;
+
+(*COND TEST
+PROC dump freelist:
+ command dialogue (FALSE);
+ FILE VAR f := sequential file (output, "freelistdump");
+ INT VAR i;
+ putline (f, "STACKTOP: " + text (fl.stacktop));
+ putline (f, "STACK:");
+ FOR i FROM 1 UPTO 16 * number of dir sectors REP
+ putline (f, " " + text (i, 4) + ": " +
+ text (fl.stack [i].msdos block no) + ", " +
+ text (fl.stack [i].block entry no))
+ PER;
+ line (f);
+ putline (f, "BEGIN OF FREE: " + text (fl.begin of free area.msdos block no) +
+ ", " + text (fl.begin of free area.block entry no));
+ putline (f, "END OF DIR: " + text (fl.end of dir.msdos block no) +
+ ", " + text (fl.end of dir.block entry no)).
+
+fl:
+ dir.freelist.
+
+END PROC dump free list;
+ENDCOND*)
+
+END PACKET dos fat and dir;
diff --git a/system/dos/1986/src/fetch b/system/dos/1986/src/fetch
new file mode 100644
index 0000000..ad00ab6
--- /dev/null
+++ b/system/dos/1986/src/fetch
@@ -0,0 +1,333 @@
+PACKET fetch DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ (* 07.05.86 *)
+ fetch filemode,
+ fetch rowtextmode,
+ fetch dsmode,
+ check file:
+
+LET ascii = 1,
+ ascii german = 2,
+ transparent = 3,
+ ebcdic = 4,
+ atari st = 10;
+
+LET row text mode length = 4000,
+ row text type = 1000,
+
+ ctrl z = ""26"",
+ tab = ""9"",
+ page cmd = "#page#";
+
+CLUSTER VAR cluster;
+
+DATASPACE VAR cluster space;
+
+BOUND STRUCT (INT size,
+ ROW row text mode length TEXT cluster row) VAR cluster struct;
+
+INT VAR next cluster no;
+REAL VAR file rest;
+
+FILE VAR file;
+
+PROC fetch filemode (DATASPACE VAR file space,
+ TEXT CONST name, INT CONST code type):
+ disable stop;
+ cluster space := nilspace;
+ cluster := cluster space;
+ enabled fetch filemode (file space, name, code type);
+ forget (cluster space).
+
+END PROC fetch filemode;
+
+PROC enabled fetch filemode (DATASPACE VAR file space,
+ TEXT CONST name,
+ INT CONST code type):
+ enable stop;
+ initialize fetch filemode;
+ open fetch (name, file rest, next cluster no);
+ WHILE (next cluster no >= 0) AND (file rest > 0.0) REP
+ get text of act cluster;
+ write lines;
+(***************************************)
+ IF lines (file) > 3950
+ THEN putline (file, ">>> FREMDDATEI FUER EUMEL ZU LANG. ES KNNEN DATEN FEHLEN <<<");
+ LEAVE enabled fetch filemode
+ FI;
+(***************************************)
+ PER;
+ write last line if necessary.
+
+initialize fetch filemode:
+ REAL VAR real cluster size := real (cluster size);
+ TEXT VAR buffer := "";
+ forget (file space);
+ file space := nilspace;
+ file := sequential file (output, file space);
+ init cr lf ff const.
+
+init cr lf ff const:
+ TEXT VAR cr, lf, ff;
+ SELECT codetype OF
+ CASE ascii, ascii german, atari st: cr := ""13""; lf := ""10""; ff := ""12""
+ CASE transparent: cr := ""13""; lf := ""10""; ff := ""12""
+ CASE ebcdic: cr := ""13""; lf := "%"; ff := ""12""
+ END SELECT;
+ TEXT CONST select buffer := cr + lf + ff;
+ TEXT CONST min line end char := code (min (code (cr), min (code (lf), code (ff)))),
+ max line end char := code (max (code (cr), max (code (lf), code (ff)))).
+
+get text of act cluster:
+ fetch next cluster (cluster space, first non dummy ds page);
+ buffer CAT text (cluster, 1, valid buffer length);
+ file rest DECR real cluster size;
+ IF seven bit code
+ THEN cancel bit 8
+ FI;
+ IF ctrl z end
+ THEN test ctrl z
+ FI;
+ INT CONST bufferlength := LENGTH buffer.
+
+ctrl z end:
+ (code type = ascii) OR (code type = ascii german).
+
+seven bit code:
+ code type = ascii OR code type = ascii german.
+
+valid buffer length:
+ int (min (file rest, real cluster size)).
+
+cancel bit 8:
+ INT VAR set pos := pos (buffer, "", ""255"", 1);
+ WHILE set pos > 0 REP
+ replace (buffer, set pos, seven bit char);
+ set pos := pos (buffer, "", ""255"", set pos + 1)
+ PER.
+
+seven bit char:
+ code (code (buffer SUB set pos) AND 127).
+
+test ctrl z:
+ IF pos (buffer, ctrl z) > 0
+ THEN file rest := 0.0;
+ buffer := subtext (buffer, 1, pos (buffer, ctrl z) - 1)
+ FI.
+
+write lines:
+ INT VAR begin pos := 1, end pos;
+ next cr lf ff pos;
+ WHILE end pos > 0 REP
+ execute char and get new pos pointer;
+ next cr lf ff pos
+ PER;
+ compress buffer.
+
+next cr lf ff pos:
+ end pos := pos (buffer, min line end char, max line end char, begin pos);
+ WHILE no line end char REP
+ end pos := pos (buffer, min line end char, max line end char, end pos + 1)
+ PER.
+
+no line end char:
+ (end pos > 0) AND (pos (select buffer, buffer SUB end pos) = 0).
+
+compress buffer:
+ buffer := subtext (buffer, begin pos).
+
+execute char and get new pos pointer:
+ SELECT pos (select buffer, buffer SUB end pos) OF
+ CASE 1: execute cr
+ CASE 2: execute lf
+ CASE 3: execute ff
+ END SELECT.
+
+execute cr:
+ IF (end pos = bufferlength) AND (file rest > 0.0)
+ THEN compress buffer;
+ LEAVE write lines
+ FI;
+ write line (subtext (buffer, begin pos, end pos - 1), code type);
+ IF (buffer SUB (end pos + 1)) = lf
+ THEN begin pos := end pos + 2
+ ELSE begin pos := end pos + 1
+ FI.
+
+execute ff:
+ write line (subtext (buffer, begin pos, end pos - 1), code type);
+ putline (file, page cmd);
+ begin pos := end pos + 1.
+
+execute lf:
+ IF (end pos = bufferlength) AND (file rest > 0.0)
+ THEN compress buffer;
+ LEAVE write lines
+ FI;
+ write line (subtext (buffer, begin pos, end pos - 1), code type);
+ IF (buffer SUB (end pos + 1)) = cr
+ THEN begin pos := end pos + 2
+ ELSE begin pos := end pos + 1
+ FI.
+
+write last line if necessary:
+ IF buffer <> ""
+ THEN end pos := LENGTH buffer + 1;
+ write line (subtext (buffer, begin pos, end pos - 1), code type)
+ FI.
+
+END PROC enabled fetch filemode;
+
+PROC write line (TEXT CONST line, INT CONST code type):
+ TEXT VAR result;
+ SELECT code type OF
+ CASE ascii: ascii conversion
+ CASE ascii german: ascii german conversion
+ CASE atari st: atari st conversion
+ CASE transparent: putline (file, line)
+ CASE ebcdic: ebcdic conversion
+ END SELECT.
+
+ascii conversion:
+ expand tabs;
+ replace steuerzeichen;
+ putline (file, result).
+
+ascii german conversion:
+ expand tabs;
+ replace steuerzeichen;
+ replace ascii german umlaute;
+ putline (file, result).
+
+atari st conversion:
+ expand tabs;
+ replace steuerzeichen;
+ replace atari st umlaute;
+ putline (file, result).
+
+replace ascii german umlaute:
+ change all (result, "[", "");
+ change all (result, "\", "");
+ change all (result, "]", "");
+ change all (result, "{", "");
+ change all (result, "|", "");
+ change all (result, "}", "");
+ change all (result, "~", "").
+
+replace atari st umlaute:
+ change all (result, ""142"", "");
+ change all (result, ""153"", "");
+ change all (result, ""154"", "");
+ change all (result, ""132"", "");
+ change all (result, ""148"", "");
+ change all (result, ""129"", "");
+ change all (result, ""158"", "").
+
+expand tabs:
+ result := line;
+ INT VAR tab pos := pos (result, tab);
+ WHILE tab pos > 0 REP
+ expand tab;
+ tab pos := pos (result, tab)
+ PER.
+
+expand tab:
+ result := subtext (result, 1, tab pos - 1) + (8 - ((tab pos - 1)) MOD 8) * " "
+ + subtext (result, tab pos + 1).
+
+replace steuerzeichen:
+ INT VAR position := pos (result, ""0"", ""31"", 1);
+ WHILE position > 0 REP
+ TEXT VAR char := result SUB position;
+ change all (result, char, "#" + int code + "#");
+ position := pos (result, ""0"", ""31"", position)
+ PER.
+
+ebcdic conversion:
+ result := line;
+ ebcdic to eumel with substitution (result);
+ putline (file, result).
+
+int code:
+ (3 - LENGTH text (code (char))) * "0" + text (code (char)).
+
+END PROC write line;
+
+PROC fetch rowtextmode (DATASPACE VAR file space,
+ TEXT CONST name):
+ disable stop;
+ cluster space := nilspace;
+ cluster := cluster space;
+ enabled fetch rowtextmode (file space, name);
+ forget (cluster space).
+
+END PROC fetch rowtextmode;
+
+PROC enabled fetch rowtextmode (DATASPACE VAR file space,
+ TEXT CONST name):
+ enable stop;
+ open fetch (name, file rest, next cluster no);
+ initialize fetch rowtext mode;
+ WHILE next cluster no >= 0 REP
+ fetch next cluster (cluster space, first non dummy ds page);
+ cluster struct.size INCR 1;
+ IF file rest < real cluster size
+ THEN cluster struct.cluster row [cluster struct.size]
+ := text (cluster, 1, int (file rest));
+ file rest := 0.0
+ ELSE cluster struct.cluster row [cluster struct.size] := text (cluster, 1, cluster size);
+ file rest DECR real cluster size
+ FI
+ PER.
+
+initialize fetch row text mode:
+ forget (file space);
+ file space := nilspace;
+ cluster struct := file space;
+ type (file space, row text type);
+ REAL VAR real cluster size := real (cluster size);
+ cluster struct.size := 0.
+
+END PROC enabled fetch rowtext mode;
+
+PROC fetch ds mode (DATASPACE VAR ds, TEXT CONST name):
+ enable stop;
+ open fetch (name, file rest, next cluster no);
+ init fetch dsmode;
+ WHILE next cluster no >= 0 REP
+ fetch next cluster (ds, ds block no);
+ ds block no INCR sectors per cluster;
+ PER.
+
+init fetch dsmode:
+ forget (ds);
+ ds := nilspace;
+ INT VAR ds block no := 2.
+
+END PROC fetch ds mode;
+
+PROC check file (TEXT CONST name):
+ disable stop;
+ cluster space := nilspace;
+ cluster := cluster space;
+ enabled check file (name);
+ forget (cluster space).
+
+END PROC check file;
+
+PROC enabled check file (TEXT CONST name):
+ enable stop;
+ open fetch (name, file rest, next cluster no);
+ WHILE next cluster no >= 0 REP
+ fetch next cluster (cluster space, first non dummy ds page)
+ PER.
+
+END PROC enabled check file;
+
+PROC fetch next cluster (DATASPACE VAR fetch space, INT CONST first page):
+ read disk cluster (fetch space, first page, next cluster no);
+ next cluster no := next fetch cluster no.
+
+END PROC fetch next cluster;
+
+END PACKET fetch;
diff --git a/system/dos/1986/src/files.dos b/system/dos/1986/src/files.dos
new file mode 100644
index 0000000..0dd792f
--- /dev/null
+++ b/system/dos/1986/src/files.dos
@@ -0,0 +1,23 @@
+eumel-ebcdic + sub
+open
+block i/o
+cluster
+name conversion
+eu disk descriptor.fd
+disk descriptor.dos.fd
+fat and dir.dos.fd
+eu disk descriptor.hd
+disk descriptor.dos.hd
+fat and dir.dos.hd
+fetch
+save
+disk manager
+manager/M.dos.fd
+manager/M.dos.hd
+table thes.dos
+252
+253
+254
+255
+shard interface
+
diff --git a/system/dos/1986/src/gen.dos b/system/dos/1986/src/gen.dos
new file mode 100644
index 0000000..5493272
--- /dev/null
+++ b/system/dos/1986/src/gen.dos
@@ -0,0 +1,99 @@
+(* 28.02.88, DOS Inserter HD/FD *)
+TASK VAR fd, hd ;
+IF NOT exists ("files.dos") THEN fetch ("files.dos", archive) FI ;
+IF highest entry (ALL "files.dos" - all) > 0
+ THEN fetch (ALL "files.dos" - all, archive) ;
+FI ;
+forget ("files.dos", quiet) ;
+forget ("gen.dos", quiet) ;
+release (archive) ;
+ins ("eumel-ebcdic + sub") ;
+ins ("open") ;
+ins ("name conversion") ;
+begin ("FD", PROC fd start, fd) ;
+begin ("HD", PROC hd start, hd) ;
+globalmanager ;
+
+PROC ins (TEXT CONST name) :
+ insert (name) ;
+ forget (name, quiet)
+ENDPROC ins ;
+
+PROC hd start :
+ command dialogue (FALSE) ;
+
+ fetch ("eu disk descriptor.hd") ;
+ erase ("eu disk descriptor.hd") ;
+ fetch ("disk descriptor.dos.hd") ;
+ erase ("disk descriptor.dos.hd") ;
+ fetch ("cluster") ;
+ fetch ("block i/o") ;
+ fetch ("fat and dir.dos.hd") ;
+ erase ("fat and dir.dos.hd") ;
+ fetch ("fetch") ;
+ fetch ("save") ;
+ fetch ("disk manager") ;
+ fetch ("manager/M.dos.hd") ;
+ erase ("manager/M.dos.hd") ; (* fetch beendet signalieren *)
+
+ IF NOT exists ("manager/M.dos.fd", father) (* FD auch fertig ? *)
+ THEN erase ("block i/o") ;
+ erase ("cluster") ;
+ erase ("fetch") ;
+ erase ("save") ;
+ erase ("disk manager")
+ FI ;
+
+ ins ("eu disk descriptor.hd") ;
+ ins ("disk descriptor.dos.hd") ;
+ ins ("cluster") ;
+ ins ("block i/o") ;
+ ins ("fat and dir.dos.hd") ;
+ ins ("fetch") ;
+ ins ("save") ;
+ ins ("disk manager") ;
+ ins ("manager/M.dos.hd") ;
+ do ("dos manager")
+ENDPROC hd start ;
+
+PROC fd start :
+ disablestop ;
+ command dialogue (FALSE) ;
+ fetch ("table thes.dos") ;
+ erase ("table thes.dos") ;
+ fetch (ALL "table thes.dos") ;
+ erase (ALL "table thes.dos") ;
+ fetch ("eu disk descriptor.fd") ;
+ erase ("eu disk descriptor.fd") ;
+ fetch ("disk descriptor.dos.fd") ;
+ erase ("disk descriptor.dos.fd") ;
+ fetch ("cluster") ;
+ fetch ("block i/o") ;
+ fetch ("fat and dir.dos.fd") ;
+ erase ("fat and dir.dos.fd") ;
+ fetch ("fetch") ;
+ fetch ("save") ;
+ fetch ("disk manager") ;
+ fetch ("manager/M.dos.fd") ;
+ erase ("manager/M.dos.fd") ; (* fetch beendet signalieren *)
+
+ IF NOT exists ("manager/M.dos.hd", father) (* HD auch fertig ? *)
+ THEN erase ("block i/o") ;
+ erase ("cluster") ;
+ erase ("fetch") ;
+ erase ("save") ;
+ erase ("disk manager")
+ FI ;
+
+ ins ("eu disk descriptor.fd") ;
+ ins ("disk descriptor.dos.fd") ;
+ ins ("cluster") ;
+ ins ("block i/o") ;
+ ins ("fat and dir.dos.fd") ;
+ ins ("fetch") ;
+ ins ("save") ;
+ ins ("disk manager") ;
+ ins ("manager/M.dos.fd") ;
+ do ("dos manager")
+ENDPROC fd start ;
+
diff --git a/system/dos/1986/src/manager-M.dos.fd b/system/dos/1986/src/manager-M.dos.fd
new file mode 100644
index 0000000..601d521
--- /dev/null
+++ b/system/dos/1986/src/manager-M.dos.fd
@@ -0,0 +1,198 @@
+PACKET dos manager multi DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ provide channel, (* 25.03.86 *)
+ 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,
+
+ quote = """";
+
+BOUND STRUCT (TEXT name, pass) VAR msg;
+
+TASK VAR order task;
+
+INT VAR dos channel;
+
+REAL VAR last access time := 0.0;
+
+TASK VAR disk owner := niltask;
+
+PROC provide channel (INT CONST channel):
+ dos channel := channel
+
+END PROC provide channel;
+
+(*COND FLOPPY*)
+provide channel (std archive channel);
+(*ENDCOND*)
+
+(*COND HDU
+provide channel (29)
+ENDCOND*)
+
+PROC dos manager:
+ dos manager (dos channel)
+
+END PROC dos manager;
+
+PROC dos manager (INT CONST channel):
+(*COND FLOPPY*)
+ load shard interface table;
+(*ENDCOND*)
+ 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;
+ 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
+ OTHERWISE errorstop ("unbekannter Auftrag fr Task: " + name (myself))
+ END SELECT.
+
+fetch file:
+ disk fetch (msg.name, ds);
+ manager ok (ds).
+
+check:
+ disk check (msg.name);
+ manager message (expanded name (msg.name, TRUE) + " ohne Fehler gelesen").
+
+save file:
+ IF phase = 1
+ THEN save first phase
+ ELSE save second phase
+ FI.
+
+save first phase:
+ BOOL VAR overwrite question;
+ disk save first phase (msg.name, overwrite question);
+ IF overwrite question
+ THEN manager question (expanded name (msg.name, FALSE) + " auf der MS-DOS Disk ueberschreiben")
+ ELSE send (order task, second phase ack, ds)
+ FI.
+
+save second phase:
+ disable stop;
+ disk save second phase (ds);
+ forget (ds) ;
+ ds := nilspace ;
+ enable stop;
+ manager ok (ds).
+
+clear disk:
+ IF NOT (from task = disk owner)
+ THEN error stop ("DOS nicht angemeldet")
+ FI;
+ IF phase = 1
+ THEN manager question ("Diskette loeschen")
+ ELSE disk clear;
+ manager ok (ds)
+ FI.
+
+erase file:
+ IF disk exists (msg.name)
+ THEN IF phase = 1
+ THEN manager question (expanded name (msg.name, TRUE) + " auf der MS-DOS Disk loeschen")
+ ELSE disk erase (msg.name);
+ 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 disk exists (msg.name)
+ THEN manager ok (ds)
+ ELSE send (order task, false code, ds)
+ FI.
+
+list disk:
+ disk list (ds);
+ manager ok (ds).
+
+deliver directory:
+ forget (ds);
+ ds := nilspace;
+ BOUND THESAURUS VAR all names := ds;
+ all names := disk all;
+ manager ok (ds).
+
+reserve:
+ IF reserve or free permitted
+ THEN do continue channel;
+ disk owner := from task;
+ disk reserve (msg.name);
+ manager ok (ds)
+ ELSE errorstop ("Archivlaufwerk wird von Task """+ name (disk owner) + """ benutzt")
+ FI.
+
+do continue channel:
+ IF channel <> dos channel
+ THEN continue channel (dos channel)
+ 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 disk free;
+ 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 + adapted name (name, status) + quote, 14)
+
+END PROC expanded name;
+
+END PACKET dos manager multi;
diff --git a/system/dos/1986/src/manager-M.dos.hd b/system/dos/1986/src/manager-M.dos.hd
new file mode 100644
index 0000000..5eb97c7
--- /dev/null
+++ b/system/dos/1986/src/manager-M.dos.hd
@@ -0,0 +1,198 @@
+PACKET dos manager multi DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ provide channel, (* 25.03.86 *)
+ 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,
+
+ quote = """";
+
+BOUND STRUCT (TEXT name, pass) VAR msg;
+
+TASK VAR order task;
+
+INT VAR dos channel;
+
+REAL VAR last access time := 0.0;
+
+TASK VAR disk owner := niltask;
+
+PROC provide channel (INT CONST channel):
+ dos channel := channel
+
+END PROC provide channel;
+
+(*COND FLOPPY
+provide channel (std archive channel);
+ENDCOND*)
+
+(*COND HDU*)
+provide channel (29)
+(*ENDCOND*)
+
+PROC dos manager:
+ dos manager (dos channel)
+
+END PROC dos manager;
+
+PROC dos manager (INT CONST channel):
+(*COND FLOPPY
+ load shard interface table;
+ENDCOND*)
+ 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;
+ 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
+ OTHERWISE errorstop ("unbekannter Auftrag fr Task: " + name (myself))
+ END SELECT.
+
+fetch file:
+ disk fetch (msg.name, ds);
+ manager ok (ds).
+
+check:
+ disk check (msg.name);
+ manager message (expanded name (msg.name, TRUE) + " ohne Fehler gelesen").
+
+save file:
+ IF phase = 1
+ THEN save first phase
+ ELSE save second phase
+ FI.
+
+save first phase:
+ BOOL VAR overwrite question;
+ disk save first phase (msg.name, overwrite question);
+ IF overwrite question
+ THEN manager question (expanded name (msg.name, FALSE) + " auf der MS-DOS Disk ueberschreiben")
+ ELSE send (order task, second phase ack, ds)
+ FI.
+
+save second phase:
+ disable stop;
+ disk save second phase (ds);
+ forget (ds) ;
+ ds := nilspace ;
+ enable stop;
+ manager ok (ds).
+
+clear disk:
+ IF NOT (from task = disk owner)
+ THEN error stop ("DOS nicht angemeldet")
+ FI;
+ IF phase = 1
+ THEN manager question ("Diskette loeschen")
+ ELSE disk clear;
+ manager ok (ds)
+ FI.
+
+erase file:
+ IF disk exists (msg.name)
+ THEN IF phase = 1
+ THEN manager question (expanded name (msg.name, TRUE) + " auf der MS-DOS Disk loeschen")
+ ELSE disk erase (msg.name);
+ 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 disk exists (msg.name)
+ THEN manager ok (ds)
+ ELSE send (order task, false code, ds)
+ FI.
+
+list disk:
+ disk list (ds);
+ manager ok (ds).
+
+deliver directory:
+ forget (ds);
+ ds := nilspace;
+ BOUND THESAURUS VAR all names := ds;
+ all names := disk all;
+ manager ok (ds).
+
+reserve:
+ IF reserve or free permitted
+ THEN do continue channel;
+ disk owner := from task;
+ disk reserve (msg.name);
+ manager ok (ds)
+ ELSE errorstop ("Archivlaufwerk wird von Task """+ name (disk owner) + """ benutzt")
+ FI.
+
+do continue channel:
+ IF channel <> dos channel
+ THEN continue channel (dos channel)
+ 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 disk free;
+ 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 + adapted name (name, status) + quote, 14)
+
+END PROC expanded name;
+
+END PACKET dos manager multi;
diff --git a/system/dos/1986/src/name conversion b/system/dos/1986/src/name conversion
new file mode 100644
index 0000000..1f9a797
--- /dev/null
+++ b/system/dos/1986/src/name conversion
@@ -0,0 +1,77 @@
+PACKET name conversion DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ adapted name: (* 20.02.86 *)
+
+LET upper case chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$#&@!(){}",
+ lower case chars = "abcdefghijklmnopqrstuvwxyz";
+
+TEXT VAR name pre,
+ name post,
+ new,
+ char;
+
+INT VAR point pos,
+ count;
+
+TEXT PROC adapted name (TEXT CONST eu name, BOOL CONST read modus):
+ enable stop;
+ 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:
+ 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 modus)
+ ELSE new name (name pre, read modus) + "."
+ + new name (name post, read modus)
+ FI.
+
+changed name without extension:
+ IF LENGTH eu name > 8 OR LENGTH euname < 1
+ THEN error
+ FI;
+ new name (eu name, read modus).
+
+error:
+ errorstop ("Unzulssiger Name").
+
+END PROC adapted name;
+
+TEXT PROC new name (TEXT CONST old name, BOOL CONST read modus):
+ new := "";
+ FOR count FROM 1 UPTO LENGTH old name REP
+ convert char
+ PER;
+ new.
+
+convert char:
+ 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 modus
+ THEN new CAT char
+ ELSE error stop ("Unzulssiger 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/1986/src/open b/system/dos/1986/src/open
new file mode 100644
index 0000000..92e81e9
--- /dev/null
+++ b/system/dos/1986/src/open
@@ -0,0 +1,51 @@
+PACKET open DEFINES (* Copyright (C) 1986 *)
+ (* Frank Klapper *)
+ open action, (* 20.03.86 *)
+ close action,
+ action opened,
+ action closed,
+ init check rerun,
+ check rerun:
+
+BOOL VAR open;
+INT VAR old session;
+
+INITFLAG VAR packet := FALSE;
+
+PROC open action:
+ open := TRUE
+
+END PROC open action;
+
+PROC close action:
+ open := FALSE
+
+END PROC close action;
+
+BOOL PROC action opened:
+ IF NOT initialized (packet)
+ THEN close action
+ FI;
+ open
+
+END PROC action opened;
+
+BOOL PROC action closed:
+ NOT action opened
+
+END PROC action closed;
+
+PROC init check rerun:
+ old session := session
+
+END PROC init check rerun;
+
+PROC check rerun:
+ IF session <> old session
+ THEN close action;
+ error stop ("Diskettenzugriff im RERUN")
+ FI.
+
+END PROC check rerun;
+
+END PACKET open;
diff --git a/system/dos/1986/src/save b/system/dos/1986/src/save
new file mode 100644
index 0000000..89d1108
--- /dev/null
+++ b/system/dos/1986/src/save
@@ -0,0 +1,273 @@
+PACKET save DEFINES (* Copyright (C) 1985 *)
+ (* Frank Klapper *)
+ (* 07.05.86 *)
+ save filemode,
+ save rowtextmode,
+ save dsmode:
+
+LET ascii = 1,
+ ascii german = 2,
+ transparent = 3,
+ ebcdic = 4,
+ atari st = 10;
+
+LET ascii ctrl z = ""26"";
+
+LET row text mode length = 4000;
+
+CLUSTER VAR cluster;
+
+DATASPACE VAR cluster space;
+
+BOUND STRUCT (INT size,
+ ROW row text mode length TEXT cluster row) VAR cluster struct;
+
+REAL VAR storage;
+TEXT VAR cr lf, ff;
+TEXT VAR buffer;
+
+PROC save filemode (DATASPACE CONST file space,
+ TEXT CONST name,
+ INT CONST code type):
+ disable stop;
+ cluster space := nilspace;
+ cluster := cluster space;
+ enable save filemode (file space, name, code type);
+ buffer := "";
+ forget (cluster space).
+
+END PROC save filemode;
+
+PROC enable save filemode (DATASPACE CONST file space,
+ TEXT CONST name,
+ INT CONST code type):
+ enable stop;
+ open save (name);
+ init save filemode;
+ 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
+ copy buffer to cluster;
+ write disk cluster (cluster space, first non dummy ds page, next save cluster no);
+ remember rest
+ PER
+ PER;
+ cat ctrl z if necessary;
+ write rest;
+ close save (storage).
+
+init save filemode:
+ storage := 0.0;
+ FILE VAR file := sequential file (modify, file space);
+ SELECT code type OF
+ CASE ascii, ascii german, atari st, transparent: cr lf := ""13""10""; ff := ""12""
+ CASE ebcdic: cr lf := ""13"%"; ff := ""12""
+ END SELECT;
+ buffer := "".
+
+buffer cat file line:
+ exec (PROC (TEXT CONST, INT CONST) cat adapted line, file, code type).
+
+copy buffer to cluster:
+ write text (cluster, buffer);
+ storage INCR real (min (cluster size, LENGTH buffer)).
+
+remember rest:
+ buffer := subtext (buffer, cluster size + 1).
+
+write rest:
+ WHILE buffer <> ""
+ REP copy buffer to cluster;
+ write disk cluster (cluster space, first non dummy ds page, next save cluster no);
+ remember rest
+ PER.
+
+cat ctrl z if necessary:
+ IF code type <> ebcdic
+ THEN buffer CAT ascii ctrl z
+ FI.
+
+END PROC enable save filemode;
+
+PROC cat adapted line (TEXT VAR line, INT CONST code type):
+ IF subtext (line, 1, 6) = "#page#"
+ THEN buffer CAT ff;
+ LEAVE cat adapted line
+ FI;
+ SELECT code type OF
+ CASE transparent: (* no operation *)
+ CASE ascii: change eumel print chars; ascii change
+ CASE ascii german: change eumel print chars; ascii german change
+ CASE atari st: change eumel print chars; atari st change
+ CASE ebcdic: change eumel print chars; eumel to ebcdic with substitution (line)
+ END SELECT;
+ buffer CAT line;
+ buffer CAT cr lf.
+
+change eumel print chars:
+ INT VAR char pos := pos (line, ""220"", ""223"", 1);
+ WHILE char pos > 0 REP
+ replace (line, char pos, std char);
+ char pos := pos (line, ""220"", ""223"", char pos + 1)
+ PER.
+
+std char:
+ SELECT code (line SUB char pos) OF
+ CASE 220: "k"
+ CASE 221: "-"
+ CASE 222: "#"
+ CASE 223: " "
+ OTHERWISE ""
+ END SELECT.
+
+ascii change:
+ change all (line, ""251"", "#251#");
+ char pos := pos (line, "", "", 1);
+ WHILE char pos > 0 REP
+ line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1);
+ char pos := pos (line, "", "", char pos + 1)
+ PER.
+
+ascii german change:
+ char pos := pos (line, "[", "]", 1);
+ WHILE char pos > 0 REP
+ line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1);
+ char pos := pos (line, "[", "]", char pos + 1)
+ PER;
+ char pos := pos (line, "{", "}", 1);
+ WHILE char pos > 0 REP
+ line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1);
+ char pos := pos (line, "{", "}", char pos + 1)
+ PER;
+ change all (line, ""251"", "~");
+ char pos := pos (line, "", "", 1);
+ WHILE char pos > 0 REP
+ replace (line, char pos, umlaut in ascii german);
+ char pos := pos (line, "", "", char pos + 1)
+ PER.
+
+atari st change:
+ change all (line, "", ""158"");
+ char pos := pos (line, "", "", 1);
+ WHILE char pos > 0 REP
+ replace (line, char pos, umlaut in atari st);
+ char pos := pos (line, "", "", char pos + 1)
+ PER.
+
+ersatzdarstellung:
+ TEXT VAR char code := text (code (line SUB char pos));
+ "#" + (3 - LENGTH char code) * "0" + char code + "#".
+
+umlaut in ascii german:
+ SELECT code (line SUB char pos) OF
+ CASE 214: "["
+ CASE 215: "\"
+ CASE 216: "]"
+ CASE 217: "{"
+ CASE 218: "|"
+ CASE 219: "}"
+ OTHERWISE ""
+ END SELECT.
+
+umlaut in atari st:
+ SELECT code (line SUB char pos) OF
+ CASE 214: ""142""
+ CASE 215: ""153""
+ CASE 216: ""154""
+ CASE 217: ""132""
+ CASE 218: ""148""
+ CASE 219: ""129""
+ OTHERWISE ""
+ END SELECT.
+
+END PROC cat adapted line;
+
+PROC save rowtextmode (DATASPACE CONST space,
+ TEXT CONST name):
+ disable stop;
+ cluster space := nilspace;
+ cluster := cluster space;
+ enable save rowtext mode (space, name);
+ forget (cluster space).
+
+END PROC save rowtextmode;
+
+PROC enable save rowtextmode (DATASPACE CONST space,
+ TEXT CONST name):
+ enable stop;
+ open save (name);
+ init save row textmode;
+ WHILE line no < cluster struct.size REP
+ fill buffer;
+ copy buffer to cluster;
+ write disk cluster (cluster space, first non dummy ds page, next save cluster no);
+ remember rest
+ PER;
+ write rest;
+ close save (storage).
+
+init save rowtextmode:
+ storage := 0.0;
+ cluster struct := space;
+ INT VAR line no := 0;
+ TEXT VAR buffer := "".
+
+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.
+
+copy buffer to cluster:
+ write text (cluster, buffer);
+ storage INCR real (min (cluster size, LENGTH buffer)).
+
+remember rest:
+ buffer := subtext (buffer, cluster size + 1).
+
+write rest:
+ WHILE buffer <> ""
+ REP copy buffer to cluster;
+ write disk cluster (cluster space, first non dummy ds page, next save cluster no);
+ remember rest
+ PER.
+
+END PROC enable save rowtextmode;
+
+PROC save ds mode (DATASPACE CONST ds,
+ TEXT CONST name):
+ disable stop;
+ enable save ds mode (ds, name).
+
+END PROC save ds mode;
+
+PROC enable save ds mode (DATASPACE CONST ds,
+ TEXT CONST name):
+ enable stop;
+ open save (name);
+ INT VAR page no := first non dummy ds page;
+ get last allocated ds page;
+ WHILE page no <= last allocated ds page REP
+ write disk cluster (ds, page no, next save cluster no);
+ page no INCR sectors per cluster
+ PER;
+ close save (size).
+
+get last allocated ds page:
+ INT VAR last allocated ds page := -1,
+ i;
+ FOR i FROM 1 UPTO ds pages (ds) REP
+ last allocated ds page := next ds page (ds, last allocated ds page)
+ PER.
+
+size:
+ real (last allocated ds page - first non dummy ds page + 1) * 512.0.
+
+END PROC enable save ds mode;
+
+END PACKET save;
diff --git a/system/dos/1986/src/shard interface b/system/dos/1986/src/shard interface
new file mode 100644
index 0000000..67bf654
--- /dev/null
+++ b/system/dos/1986/src/shard interface
@@ -0,0 +1,19 @@
+; ';' in Spalte 1 kennzeichnet eine Kommentarzeile
+; alle Werte mssen durch Blanks getrennt werden
+;
+;heads: Anzahl der Kpfe, positiv fr cylinderorientiertes Lesen
+; negativ fr 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/dos/1986/src/table thes.dos b/system/dos/1986/src/table thes.dos
new file mode 100644
index 0000000..8b254cf
--- /dev/null
+++ b/system/dos/1986/src/table thes.dos
@@ -0,0 +1,5 @@
+shard interface
+252
+253
+254
+255
diff --git a/system/eumel0-z80/data/EUMEL0.DS b/system/eumel0-z80/data/EUMEL0.DS
new file mode 100644
index 0000000..8b53d98
--- /dev/null
+++ b/system/eumel0-z80/data/EUMEL0.DS
Binary files differ
diff --git a/system/eumel0-z80/src/DISEUMEL.ELA b/system/eumel0-z80/src/DISEUMEL.ELA
new file mode 100644
index 0000000..b1039dc
--- /dev/null
+++ b/system/eumel0-z80/src/DISEUMEL.ELA
@@ -0,0 +1,607 @@
+PROC arith 16 :
+
+ EXTERNAL 92
+
+ENDPROC arith 16 ;
+
+BOOL OP ULSEQ (INT CONST left, right) :
+
+ (left MINUS right) <= 0
+
+ENDOP ULSEQ ;
+
+LET max words minus 1 = 32767 ; (* = max : 64K *)
+
+TEXT VAR source name , instr, parameter , t ;
+INT VAR addr , start addr, end addr , file nr , laenge, i , offset ;
+FILE VAR source file ;
+
+BOUND STRUCT (ALIGN align, ROW max words minus 1 INT word) VAR space ;
+
+TEXT VAR a, b, c;
+BOOL VAR screen mode := yes ("Bildschirmausgabe zusaetzlich") ;
+put ("Startaddr:") ;
+getline (a) ;
+put ("Endaddr :") ;
+getline (b) ;
+put ("Offset :") ;
+getline (c) ;
+resource ("eumel0", "eumel0.prt", a, b, c) ;
+edit ("eumel0.prt") ;
+
+
+PROC resource (TEXT CONST code space name, source file name,
+ TEXT CONST from, to, offs) :
+
+ space := old (code space name) ;
+ start addr := integer (from) ;
+ end addr := integer (to) ;
+ offset := integer (offs) ;
+ source name := source file name ;
+ file nr := 1 ;
+ forget (source name, quiet) ;
+ source file := sequential file (output, source name) ;
+
+ source putline ("ADDR B1 B2 B3 B4 ASCII INSTR PARAMETER COMMENT") ;
+ put tabs (source file, 40 * ""2"" + "^") ;
+ addr := start addr ;
+ line ;
+ WHILE addr ULSEQ end addr REP
+ IF online THEN out (hex16 (addr)) ;
+ out (""13"") ;
+ FI ;
+ source put (hex16 (addr)) ;
+ disass ;
+ FOR i FROM 1 UPTO laenge REP
+ source put (hex8 (zugriff (addr PLUS (i-1))))
+ PER ;
+ FOR i FROM laenge UPTO 3 REP
+ source put (" ")
+ PER ;
+ t := "" ;
+ FOR i FROM 1 UPTO laenge REP
+ t CAT ascii (zugriff (addr PLUS (i-1)))
+ PER ;
+ source put (t, 5) ;
+ source put (instr, 5) ;
+ source put (parameter, 10) ;
+ source line ;
+ addr := addr PLUS laenge ;
+ PER ;
+ENDPROC resource ;
+
+INT OP PLUS (INT CONST left, right) :
+ arith16 ;
+ left + right
+ENDOP PLUS ;
+
+INT OP MINUS (INT CONST left, right) :
+ arith16 ;
+ left - right
+ENDOP MINUS ;
+
+PROC source line :
+ check file overflow ;
+ line (source file) ;
+ IF screen mode AND online THEN line FI
+ENDPROC source line ;
+
+PROC source put (TEXT CONST text) :
+ put (source file, text) ;
+ IF screen mode AND online THEN put (text) FI
+ENDPROC source put ;
+
+PROC source out (TEXT CONST text) :
+ write (source file, text) ;
+ IF screen mode AND online THEN write (text) FI
+ENDPROC source out ;
+
+PROC source putline (TEXT CONST text) :
+ check file overflow ;
+ putline (source file, text) ;
+ IF screen mode AND online THEN putline (text) FI
+ENDPROC source putline ;
+
+PROC source put (TEXT CONST text, INT CONST laenge) :
+ source put (text + (laenge - length (text)) * " ") ;
+ENDPROC source put ;
+
+PROC check file overflow :
+ TEXT VAR new name ;
+ IF lines (source file) > 4000 THEN
+ file nr INCR 1 ;
+ new name := source name + "." + text (file nr) ;
+ line (source file) ;
+ putline (source file," - Fortsetzung in Datei """ + new name + """ -");
+ IF screen mode AND online THEN putline ("New FILE:" + new name) FI ;
+ modify (source file) ;
+ to first record (source file) ;
+ forget (new name, quiet) ;
+ source file := sequentialfile (output, new name) ;
+ source putline ("ADDR B1 B2 B3 B4 ASCII INSTR PARAMETER COMMENT") ;
+ put tabs (source file, 40 * ""2"" + "^")
+ FI
+ENDPROC check file overflow ;
+
+TEXT PROC hex16 (INT CONST nr) :
+ INT VAR i, var := nr ;
+ TEXT VAR result := "" ;
+ FOR i FROM 1 UPTO 4 REP
+ rotate (var, 4) ;
+ result CAT hex4 (var AND 15)
+ PER ;
+ result
+ENDPROC hex16 ;
+
+TEXT PROC hex8 (INT CONST nr) :
+ hex4 (nr DIV 16) + hex4 (nr AND 15)
+ENDPROC hex8 ;
+
+TEXT PROC hex4 (INT CONST nr) :
+ "0123456789ABCDEF" SUB (nr+1)
+ENDPROC hex4 ;
+
+TEXT PROC ascii (INT CONST nr) :
+ IF nr < 32 OR nr > 126 THEN "."
+ ELSE code (nr)
+ FI
+ENDPROC ascii ;
+
+INT PROC zugriff (INT CONST adr) :
+ TEXT VAR t := " " ;
+ INT VAR index := offset PLUS adr MINUS startaddr ;
+ rotate (index, -1) ; (* Signed DIV 2 *)
+ index := index AND maxint ;
+ BOOL CONST low byte :: ((adr MINUS start addr) AND 1) = 0 ;
+ replace (t, 1, space.word (index PLUS 1)) ;
+ IF low byte THEN code (t SUB 1)
+ ELSE code (t SUB 2)
+ FI
+ENDPROC zugriff ;
+
+INT PROC integer (TEXT CONST hex addr) :
+ INT VAR i, summe := 0 ;
+ FOR i FROM 1 UPTO length (hex addr) REP
+ rotate (summe, 4) ;
+ summe INCR digit
+ PER ;
+ summe .
+
+digit :
+ TEXT CONST char := hex addr SUB i ;
+ IF char >= "a" THEN code (char) - 87
+ ELIF char >= "A" THEN code (char) - 55
+ ELSE code (char) - 48
+ FI
+ENDPROC integer ;
+
+INT VAR byte,
+ div 8,
+ and 7,
+ and f,
+ div 10,
+ int addr ;
+
+TEXT VAR index, c byte ;
+
+TEXT PROC arith log :
+ SELECT div 8 OF
+ CASE 0 : "ADD"
+ CASE 1 : "ADC"
+ CASE 2 : "SUB"
+ CASE 3 : "SBC"
+ CASE 4 : "AND"
+ CASE 5 : "XOR"
+ CASE 6 : "OR"
+ CASE 7 : "CP"
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC arith log;
+
+TEXT PROC reg1 :
+ SELECT div8 OF
+ CASE 0 : "B"
+ CASE 1 : "C"
+ CASE 2 : "D"
+ CASE 3 : "E"
+ CASE 4 : "H"
+ CASE 5 : "L"
+ CASE 6 : "(HL)"
+ CASE 7 : "A"
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC reg1;
+
+TEXT PROC reg2 :
+ SELECT and7 OF
+ CASE 0 : "B"
+ CASE 1 : "C"
+ CASE 2 : "D"
+ CASE 3 : "E"
+ CASE 4 : "H"
+ CASE 5 : "L"
+ CASE 6 : "(HL)"
+ CASE 7 : "A"
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC reg2;
+
+TEXT PROC rp:
+ SELECT div10 AND 3 OF
+ CASE 0 : "BC"
+ CASE 1 : "DE"
+ CASE 2 : "HL"
+ CASE 3 : IF byte > 127 THEN "AF"
+ ELSE "SP" FI
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC rp;
+
+
+PROC bitmanipulation :
+ parameter := text (div8) + "," + reg2 ;
+ laenge := 2 ;
+ SELECT byte DIV 64 OF
+ CASE 1 : instr := "BIT"
+ CASE 2 : instr := "RES"
+ CASE 3 : instr := "SET"
+ OTHERWISE laenge := 1 ;
+ parameter := ""
+ ENDSELECT
+
+ENDPROC bitmanipulation;
+
+
+PROC disass :
+ laenge := 1 ;
+ instr := "" ;
+ parameter := "" ;
+ int addr := addr ;
+ byte := zugriff (int addr) ;
+ c byte := code (byte) ;
+ and 7 := byte AND 7 ;
+ and f := byte AND 15 ;
+ div 10:= byte DIV 16 ;
+ div 8 := (byte DIV 8) AND 7 ;
+ IF is special instruction
+ THEN disass special instruction
+ ELIF div 10 < 4
+ THEN lower case instruction
+ ELIF byte < 128
+ THEN ld instruction
+ ELIF byte < 192
+ THEN arith log instruction
+ ELSE higher case instruction
+ FI.
+
+is special instruction :
+ pos (special instruction codes, c byte) > 0 .
+
+special instruction codes :
+ ""0""2""7""8""10""15""16""18""23""24""26""31""32""34""39""40""42""47""48""50
+ ""55""56""58""63""118""195""198""201""203""205""206""211""214""217""219
+ ""221""222""227""230""233""235""237""238""243""246""249""251""253""254"".
+
+arith log instruction :
+ instr := arith log ;
+ parameter := reg 2 .
+
+ld instruction :
+ instr := "LD" ;
+ parameter := reg 1 + "," + reg 2 .
+
+condition code :
+ SELECT div8 OF
+ CASE 0 : "NZ"
+ CASE 1 : "Z"
+ CASE 2 : "NC"
+ CASE 3 : "C"
+ CASE 4 : "PO"
+ CASE 5 : "PE"
+ CASE 6 : "P"
+ CASE 7 : "M"
+ OTHERWISE "??"
+ ENDSELECT.
+
+lower case instruction :
+ IF and f = 1 THEN instr := "LD" ;
+ parameter := rp + "," + next word ;
+ laenge := 3
+ ELIF and f = 3 THEN instr := "INC" ;
+ parameter := rp ;
+ ELIF and 7 = 4 THEN instr := "INC" ;
+ parameter := reg1
+ ELIF and 7 = 5 THEN instr := "DEC" ;
+ parameter := reg1
+ ELIF and 7 = 6 THEN instr := "LD" ;
+ parameter := reg1 + "," + next byte ;
+ laenge := 2
+ ELIF and f = 9 THEN instr := "ADD" ;
+ parameter := "HL," + rp ;
+ ELIF and f =11 THEN instr := "DEC" ;
+ parameter := rp
+ FI.
+
+higher case instruction :
+ SELECT and 7 OF
+ CASE 0 : instr := "RET" ;
+ parameter := condition code
+ CASE 1 : instr := "POP" ;
+ parameter := rp
+ CASE 2 : instr := "JP" ;
+ parameter := condition code + "," + next word ;
+ laenge := 3
+ CASE 4 : instr := "CALL" ;
+ parameter := condition code + "," + next word ;
+ laenge := 3
+ CASE 5 : instr := "PUSH" ;
+ parameter := rp
+ CASE 7 : instr := "RST" ;
+ parameter := hex8 (8 * div 8)
+ ENDSELECT.
+
+
+branchaddress :
+ hex16 (addr PLUS displacement) .
+
+displacement :
+ IF zugriff (int addr PLUS 1) < 128
+ THEN zugriff (int addr PLUS 1) + 2
+ ELSE zugriff (int addr PLUS 1) - 254
+ FI.
+
+cb instructions :
+ byte := zugriff (addr PLUS 1) ;
+ and 7 := byte AND 7 ;
+ and f := byte AND 15 ;
+ div 10:= byte DIV 16 ;
+ div 8 := (byte DIV 8) AND 7 ;
+ laenge := 2 ;
+ parameter := reg 2 ;
+ IF byte < 64 THEN
+ SELECT div 8 OF
+ CASE 0 : instr := "RLC"
+ CASE 1 : instr := "RRC"
+ CASE 2 : instr := "RL"
+ CASE 3 : instr := "RR"
+ CASE 4 : instr := "SLA"
+ CASE 5 : instr := "SRA"
+ CASE 6 : instr := "" ; parameter := "" ; laenge := 1
+ CASE 7 : instr := "SLR"
+ OTHERWISE laenge := 1 ; parameter := ""
+ ENDSELECT
+ ELSE
+ bitmanipulation
+ FI .
+
+
+disass special instruction :
+ SELECT byte OF
+ CASE 0 : instr := "NOP"
+ CASE 2 : instr := "LD" ; parameter := "(BC),A"
+ CASE 7 : instr := "RLCA"
+ CASE 8 : instr := "EX" ; parameter := "AF,AF'"
+ CASE 10 : instr := "LD" ; parameter := "A,(BC)"
+ CASE 15 : instr := "RRCA"
+ CASE 16 : instr := "DJNZ" ; parameter := branchaddress ; laenge:=2
+ CASE 18 : instr := "LD" ; parameter := "(DE),A"
+ CASE 23 : instr := "RLA"
+ CASE 24 : instr := "JR" ; parameter := branchaddress ; laenge:=2
+ CASE 26 : instr := "LD" ; parameter := "A,(DE)"
+ CASE 31 : instr := "RRA"
+ CASE 32 : instr := "JR" ; parameter := "NZ," + branchaddress;laenge:=2
+ CASE 34 : instr := "LD" ; parameter := "("+nextword+"),HL"; laenge:=3
+ CASE 39 : instr := "DAA"
+ CASE 40 : instr := "JR" ; parameter := "Z," + branchaddress; laenge:=2
+ CASE 42 : instr := "LD" ; parameter := "HL,("+nextword+")"; laenge:=3
+ CASE 47 : instr := "CPL"
+ CASE 48 : instr := "JR" ; parameter := "NC," + branchaddress;laenge:=2
+ CASE 50 : instr := "LD" ; parameter := "("+nextword+"),A"; laenge:=3
+ CASE 55 : instr := "SCF"
+ CASE 56 : instr := "JR" ; parameter := "C," + branchaddress; laenge:=2
+ CASE 58 : instr := "LD" ; parameter := "A,("+nextword+")"; laenge:=3
+ CASE 63 : instr := "CCF"
+ CASE 118: instr := "HALT"
+ CASE 195: instr := "JP" ; parameter := next word ; laenge:=3
+ CASE 198: instr := "ADD" ; parameter := "A,"+next byte; laenge:=2
+ CASE 201: instr := "RET"
+ CASE 203: cb instructions
+ CASE 205: instr := "CALL" ; parameter := next word; laenge := 3
+ CASE 206: instr := "ADC" ; parameter := "A," + next byte ; laenge := 2
+ CASE 211: instr := "OUT" ; parameter := "("+next byte+"),A";laenge:=2
+ CASE 214: instr := "SUB" ; parameter := "A,"+next byte;laenge := 2
+ CASE 217: instr := "EXX"
+ CASE 219: instr := "IN" ; parameter := "A,(" + next byte+")";laenge := 2
+ CASE 221: index := "IX"; dd and fd instructions
+ CASE 222: instr := "SBC" ; parameter := "A," + next byte ;laenge := 2
+ CASE 227: instr := "EX"; parameter := "(SP),HL"
+ CASE 230: instr := "AND" ; parameter := next byte; laenge := 2
+ CASE 233: instr := "JP" ; parameter := "(HL)"
+ CASE 235: instr := "EX" ; parameter := "DE,HL"
+ CASE 237: ed instructions
+ CASE 238: instr := "XOR" ; parameter := next byte ; laenge := 2
+ CASE 243: instr := "DI"
+ CASE 246: instr := "OR" ; parameter := next byte ; laenge := 2
+ CASE 249: instr := "LD" ; parameter := "SP,HL"
+ CASE 251: instr := "EI"
+ CASE 253: index := "IY"; dd and fd instructions
+ CASE 254: instr := "CP" ; parameter := next byte ; laenge := 2
+ ENDSELECT.
+
+ENDPROC disass ;
+
+PROC dd and fd instructions :
+ laenge := 2 ;
+ int addr := addr PLUS 1 ;
+ byte := zugriff (int addr) ;
+ c byte := code (byte) ;
+ and 7 := byte AND 7 ;
+ and f := byte AND 15 ;
+ div 10:= byte DIV 16 ;
+ div 8 := (byte DIV 8) AND 7 ;
+ SELECT byte OF
+ CASE 33 : instr := "LD" ; parameter := index+","+next word;laenge:=4
+ CASE 34 : instr := "LD" ; parameter:="("+next word+"),"+index;laenge:=4
+ CASE 35 : instr := "INC" ; parameter := index
+ CASE 42 : instr := "LD" ; parameter:=index+",("+next word+")";laenge:=4
+ CASE 43 : instr := "DEC" ; parameter := index
+ CASE 52 : instr := "INC";parameter:="("+index+"+"+nextbyte+")";laenge:=3
+ CASE 53 : instr := "DEC";parameter:="("+index+"+"+nextbyte+")";laenge:=3;
+ CASE 54 : instr := "LD" ; parameter :="("+index+"+"+next byte+"),"+
+ hex8(zugriff (addr PLUS 3));laenge := 4
+ CASE 203: dd and fd cb instructions
+ CASE 225: instr := "POP" ; parameter := index
+ CASE 227: instr := "EX" ; parameter := "(SP)," + index
+ CASE 229: instr := "PUSH" ; parameter := index
+ CASE 233: instr := "JP" ; parameter := "(" + index + ")"
+ CASE 249: instr := "LD" ; parameter := "SP," + index
+ OTHERWISE calculated dd and fd instructions
+ ENDSELECT.
+
+calculated dd and fd instructions :
+ parameter := "(" + index + "+" + next byte + ")" ;
+ laenge := 3 ;
+ IF andf = 9 THEN instr := "ADD" ; parameter := index+","+rp;laenge:=2
+ ELIF and7 = 6 AND div 10 > 3 AND div 10 < 8
+ THEN instr := "LD" ; parameter := reg1 + "," + parameter
+ ELIF div 10 = 7 AND byte <> 118
+ THEN instr := "LD" ; parameter CAT "," + reg2
+ ELIF and7 = 6 AND div 10 > 7 AND div 10 < 12
+ THEN instr := arith log
+ ELSE laenge := 1 ;
+ parameter := ""
+ FI.
+
+dd and fd cb instructions :
+ int addr := addr PLUS 3 ;
+ byte := zugriff (int addr) ;
+ c byte := code (byte) ;
+ and 7 := byte AND 7 ;
+ and f := byte AND 15 ;
+ div 10:= byte DIV 16 ;
+ div 8 := (byte DIV 8) AND 7 ;
+ IF byte < 64 AND and7 = 6 THEN
+ laenge := 4 ;
+ parameter := "("+index + "+" + hex8 (zugriff (addr PLUS 2)) + ")" ;
+ SELECT div 8 OF
+ CASE 0 : instr := "RLC"
+ CASE 1 : instr := "RRC"
+ CASE 2 : instr := "RL"
+ CASE 3 : instr := "RR"
+ CASE 4 : instr := "SLA"
+ CASE 5 : instr := "SRA"
+ CASE 7 : instr := "SRL"
+ OTHERWISE instr := "" ; parameter := "" ;laenge := 1
+ ENDSELECT
+ ELIF and7 = 6 THEN laenge := 4 ; parameter := "(" + index + "+"
+ + hex8 (zugriff (addr PLUS 2)) + ")" ;
+ dd and fd bitmanipulation
+ ELSE laenge := 1 ;
+ parameter := ""
+ FI.
+
+dd and fd bitmanipulation :
+ parameter := text (div8) + "," + parameter ;
+ SELECT byte DIV 64 OF
+ CASE 1 : instr := "BIT"
+ CASE 2 : instr := "RES"
+ CASE 3 : instr := "SET"
+ OTHERWISE laenge := 1 ;
+ parameter := ""
+ ENDSELECT.
+
+ENDPROC dd and fd instructions ;
+
+PROC ed instructions :
+ int addr := addr PLUS 1 ;
+ byte := zugriff (int addr) ;
+ c byte := code (byte) ;
+ and 7 := byte AND 7 ;
+ and f := byte AND 15 ;
+ div 10:= byte DIV 16 ;
+ div 8 := (byte DIV 8) AND 7 ;
+ laenge := 2 ;
+ SELECT byte OF
+ CASE 52 : instr := "TST" ; parameter := "(HL)"
+ CASE 68 : instr := "NEG"
+ CASE 69 : instr := "RETN"
+ CASE 70 : instr := "IM" ; parameter := "0"
+ CASE 71 : instr := "LD" ; parameter := "I,A"
+ CASE 77 : instr := "RETI"
+ CASE 79 : instr := "LD" ; parameter := "R,A"
+ CASE 86 : instr := "IM" ; parameter := "1"
+ CASE 87 : instr := "LD" ; parameter := "A,I"
+ CASE 94 : instr := "IM" ; parameter := "2"
+ CASE 95 : instr := "LD" ; parameter := "A,R"
+ CASE 100: instr := "TST" ; parameter := next byte ; laenge := 3
+ CASE 103: instr := "RRD"
+ CASE 111: instr := "RLD"
+ CASE 116: instr := "TSTIO" ; parameter := next byte ; laenge := 3
+ CASE 118: instr := "SLP"
+ CASE 131: instr := "OTIM"
+ CASE 139: instr := "OTDM"
+ CASE 147: instr := "OTIMR"
+ CASE 155: instr := "OTDMR"
+ CASE 171: instr := "OUTD"
+ CASE 163: instr := "OUTI"
+ CASE 179: instr := "OTIR"
+ CASE 187: instr := "OTDR"
+ OTHERWISE calculate ed instruction
+ ENDSELECT.
+
+calculate ed instruction :
+ IF is 40 to 7f THEN
+ IF and7 = 0 THEN instr := "IN" ; parameter := reg1 + ",(C)"
+ ELIF and7 = 1 THEN instr := "OUT" ; parameter := "(C)," + reg1
+ ELIF andf = 2 THEN instr := "SBC" ; parameter := "HL," + rp
+ ELIF andf = 3 THEN instr := "LD" ; parameter := "("+nextword+"),"+rp;
+ laenge := 4
+ ELIF andf =11 THEN instr := "LD" ; parameter := rp+",("+nextword+")";
+ laenge := 4
+ ELIF andf =10 THEN instr := "ADC" ; parameter := "HL," + rp
+ ELIF andf =12 THEN instr := "MLT" ; parameter := rp
+ ELSE laenge := 1
+ FI
+ ELIF byte < 64 THEN
+ IF and7 = 0 THEN instr := "IN0" ; parameter := reg1 + ",(" + next
+ byte + ")" ; laenge := 3
+ ELIF and7 = 1 THEN instr := "OUT0" ; parameter := "(" + next word +
+ ")," + reg1 ; laenge := 3
+ ELIF and7 = 4 THEN instr := "TST" ; parameter := reg1
+ ELSE laenge := 1
+ FI
+ ELIF div10 = 10 OR div10 = 11 THEN
+ IF and7 = 0 THEN instr := "LD" + modification
+ ELIF and7 = 1 THEN instr := "CP" + modification
+ ELIF and7 = 2 THEN instr := "IN" + modification
+ ELSE laenge := 1
+ FI
+ ELSE laenge := 1
+ FI.
+
+is 40 to 7f :
+ div 10 < 8 AND div 10 > 3.
+
+modification :
+ SELECT div8 - 4 OF
+ CASE 0 : "I"
+ CASE 1 : "D"
+ CASE 2 : "IR"
+ CASE 3 : "DR"
+ OTHERWISE "???"
+ ENDSELECT.
+
+ENDPROC ed instructions ;
+
+TEXT PROC next word :
+ hex8 (zugriff (int addr PLUS 2)) + hex8 (zugriff (int addr PLUS 1))
+ENDPROC next word ;
+
+TEXT PROC next byte :
+ hex8 (zugriff (int addr PLUS 1))
+ENDPROC next byte
+
diff --git a/system/eumel0-z80/src/eumel0.prt.1 b/system/eumel0-z80/src/eumel0.prt.1
new file mode 100644
index 0000000..244dcbe
--- /dev/null
+++ b/system/eumel0-z80/src/eumel0.prt.1
@@ -0,0 +1,3948 @@
+ADDR B1 B2 B3 B4 ASCII INSTR PARAMETER COMMENT
+
+1400 45 E LD B,L ; "EUMEL " (16 chars)
+1401 55 U LD D,L
+1402 4D M LD C,L
+1403 45 E LD B,L
+1404 4C L LD C,H
+1405 20 20 JR NZ,1427
+1407 20 20 JR NZ,1429
+1409 20 20 JR NZ,142B
+140B 20 20 JR NZ,142D
+140D 20 20 JR NZ,142F
+140F 20
+1410 3A 00 ; eumel0blocks (58)
+1412 D6 06 .. SUB A,06 ; mind. hgversion (1750) ID(0)
+1414 01 00 ; cputype: z80 (1) ID(1)
+ ; 3=8086, 4=68000, 5=80286
+1416 65 00 ..e LD BC,6500 ; urladerversion (101) ID(2)
+1418 00 00 ; reserviert (0) ID(3)
+141A 05 00 ; mind shard version (5)
+141C 08 00 . NOP ; max shard version (8)
+ ; ----------- 175 Leiste ---------
+141E C3 D4 28 ..( JP 28D4 ; Systemstart 175
+1421 C3 71 1F .q. JP 1F71 ; inputinterrupt
+1424 C3 35 6E .5n JP 6E35 ; timerinterrupt
+1427 C3 E2 6D ..m JP 6DE2 ; EUMEL0 Warte aufruefen
+142A C3 5B 5E .[^ JP 5E5B ; grab Blocks
+142D C3 21 60 .!` JP 6021 ; free Blocks
+1430 C3 1C 29 ..) JP 291C ; Shutup ausfuehren
+1433 C3 09 29 ..) JP 2909 ; Info " shard" Ansprungaddresse
+1436 00 . NOP ; 1500 00 7F FF
+1437 15 . DEC D ; etc. wie 1.7.3
+1438 FF . RST 38
+1439 7F . LD A,A
+143A 00 . NOP
+143B 80 . ADD B
+143C 15 . DEC D
+143D 02 . LD (BC),A
+143E 7F . LD A,A
+143F 00 . NOP
+1440 00 . NOP
+1441 16 FD .. LD D,FD
+1443 7F . LD A,A
+1444 00 . NOP
+1445 80 . ADD B
+1446 16 FF .. LD D,FF
+1448 7F . LD A,A
+1449 00 . NOP
+144A 00 . NOP
+144B 17 . RLA
+144C 00 . NOP
+144D 7F . LD A,A
+144E 01 80 18 ... LD BC,1880
+1451 FF . RST 38
+1452 7F . LD A,A
+1453 00 . NOP
+1454 00 . NOP
+1455 19 . ADD HL,DE
+1456 00 . NOP
+1457 FF . RST 38
+1458 04 . INC B
+1459 00 . NOP
+145A 00 . NOP
+145B 31 37 35 175 LD SP,3537 ; "175 hwtest 7 (!)"
+145E 20 68 h JR NZ,14C8
+1460 77 w LD (HL),A
+1461 74 t LD (HL),H
+1462 65 e LD H,L
+1463 73 s LD (HL),E
+1464 74 t LD (HL),H
+1465 20 20 JR NZ,1487
+1467 20 37 7 JR NZ,14A0
+1469 20 28 ( JR NZ,1493
+146B 21 29 !). LD HL,CD29
+146D CD EB 6D CALL 6DEB ;---- EUMEL0-Ram Tabellen init ---
+1470 2A 36 14 *6. LD HL,(1436)
+1473 E5 . PUSH HL
+1474 21 36 14 !6. LD HL,1436
+1477 97 . SUB A
+1478 5E ^ LD E,(HL)
+1479 23 # INC HL
+147A 56 V LD D,(HL)
+147B 14 . INC D
+147C 15 . DEC D
+147D 28 09 (. JR Z,1488
+147F 23 # INC HL
+1480 01 03 00 ... LD BC,0003
+1483 ED B0 .. LDIR
+1485 3C < INC A
+1486 18 F0 .. JR 1478
+1488 D1 . POP DE
+1489 62 b LD H,D
+148A 6B k LD L,E
+148B 23 # INC HL
+148C 4E N LD C,(HL)
+148D 23 # INC HL
+148E 46 F LD B,(HL)
+148F 2B + DEC HL
+1490 EB . EX DE,HL
+1491 ED B0 .. LDIR
+1493 3D = DEC A
+1494 20 F3 . JR NZ,1489 ; Miniprozess endlosschleife
+1496 C3 A0 6D ..m JP 6DA0 ; ====== Allgemeiner Systemstart ===
+1499 31 00 A1 1.. LD SP,A100 ; Stackpointer vorlaefig setzen
+149C CD A0 28 ..( CALL 28A0 ; Limit holen
+149F ED 53 3D 1D .S=. LD (1D3D),DE
+14A3 ED 7B 3D 1D .{=. LD SP,(1D3D)
+14A7 CD FE 6D ..m CALL 6DFE
+14AA FB . EI
+14AB 3A 6E 28 :n( LD A,(286E) ; Vortest durchfuehren ?
+14AE CB 4F .O BIT 1,A
+14B0 C2 BF 15 ... JP NZ,15BF
+14B3 21 AF 82 !.. LD HL,82AF ; "EUMEL-Vortest"
+14B6 CD CA 6E ..n CALL 6ECA ; Text ausgeben
+14B9 3E 02 >. LD A,02 ; Terminalkanaele anzeigen
+14BB F5 . PUSH AF
+14BC CD 71 1E .q. CALL 1E71 ; Typ erfragen
+14BF 38 16 8. JR C,14D7
+14C1 F1 . POP AF
+14C2 F5 . PUSH AF
+14C3 16 00 .. LD D,00
+14C5 5F _ LD E,A
+14C6 21 1B 1D !.. LD HL,1D1B
+14C9 FE 0A .. CP 0A
+14CB 30 01 0. JR NC,14CE
+14CD 23 # INC HL
+14CE CD 00 4E ..N CALL 4E00
+14D1 21 19 1D !.. LD HL,1D19
+14D4 CD CA 6E ..n CALL 6ECA
+14D7 F1 . POP AF
+14D8 3C < INC A
+14D9 FE 21 .! CP 21 ; 31 Kanaele
+14DB 38 DE 8. JR C,14BB
+14DD CD E0 1C ... CALL 1CE0
+14E0 CD 8A 28 ..( CALL 288A
+14E3 22 11 1D ".. LD (1D11),HL
+14E6 ED 43 0F 1D .C.. LD (1D0F),BC
+14EA CB B8 .. RES 7,B
+14EC CB 70 .p BIT 6,B
+14EE 50 P LD D,B
+14EF 59 Y LD E,C
+14F0 28 03 (. JR Z,14F5
+14F2 01 00 00 ... LD BC,0000
+14F5 CB 21 .! SLA C
+14F7 CB 10 .. RL B
+14F9 ED 43 0D 1D .C.. LD (1D0D),BC
+14FD CB B2 .. RES 6,D
+14FF 21 40 00 !@. LD HL,0040
+1502 19 . ADD HL,DE
+1503 EB . EX DE,HL
+1504 21 00 85 !.. LD HL,8500
+1507 CD 00 4E ..N CALL 4E00
+150A 21 E8 84 !.. LD HL,84E8
+150D CD CA 6E ..n CALL 6ECA
+1510 CD A0 28 ..( CALL 28A0
+1513 21 97 82 !.. LD HL,8297
+1516 EB . EX DE,HL
+1517 B7 . OR A
+1518 ED 52 .R SBC HL,DE
+151A CB 3C .< SLR H
+151C CB 3C .< SLR H
+151E 5C \ LD E,H
+151F 16 00 .. LD D,00
+1521 21 70 85 !p. LD HL,8570
+1524 CD 00 4E ..N CALL 4E00
+1527 21 57 85 !W. LD HL,8557
+152A CD CA 6E ..n CALL 6ECA
+152D 97 . SUB A
+152E 01 05 00 ... LD BC,0005
+1531 11 00 00 ... LD DE,0000
+1534 CD A8 28 ..( CALL 28A8
+1537 CB 28 .( SRA B
+1539 CB 19 .. RR C
+153B 59 Y LD E,C
+153C 50 P LD D,B
+153D 21 1F 85 !.. LD HL,851F
+1540 3E E7 >. LD A,E7
+1542 93 . SUB E
+1543 3E 03 >. LD A,03
+1545 9A . SBC D
+1546 38 01 8. JR C,1549
+1548 23 # INC HL
+1549 CD 00 4E ..N CALL 4E00
+154C 21 08 85 !.. LD HL,8508
+154F CD CA 6E ..n CALL 6ECA
+1552 3A 6E 28 :n( LD A,(286E)
+1555 CB 47 .G BIT 0,A
+1557 20 0C . JR NZ,1565
+1559 21 DD 82 !.. LD HL,82DD
+155C CD CA 6E ..n CALL 6ECA
+155F CD F0 17 ... CALL 17F0
+1562 CD E0 1C ... CALL 1CE0
+1565 01 00 00 ... LD BC,0000
+1568 ED A1 .. CPI
+156A EA 68 15 .h. JP PE,1568
+156D 3E 01 >. LD A,01
+156F CD 06 1F ... CALL 1F06
+1572 38 4B 8K JR C,15BF
+1574 ED 7B 3D 1D .{=. LD SP,(1D3D) ; ----- Menue ausgeben --------
+1578 97 . SUB A
+1579 32 30 1D 20. LD (1D30),A
+157C 21 EE 82 !.. LD HL,82EE ; Menuetext
+157F CD CA 6E ..n CALL 6ECA ; Ausgeben
+1582 CD 9B 1C ... CALL 1C9B ; AUf Taste warten
+1585 FE 31 .1 CP 31 ; "1" Systemstart
+1587 28 36 (6 JR Z,15BF
+1589 FE 32 .2 CP 32 ; "2" Neuen HG laden
+158B CA 16 16 ... JP Z,1616
+158E FE 33 .3 CP 33 ; "3" Hardwaretest
+1590 CA 9D 16 ... JP Z,169D
+1593 FE 34 .4 CP 34 ; "4" neuen Urlader vom Archiv
+1595 28 35 (5 JR Z,15CC
+1597 FE 53 .S CP 53 ; "S" Systemstart ohne Block 0
+1599 CA 6D 14 .m. JP Z,146D ; Zur Miniprozess Schleife
+159C FE 49 .I CP 49 ; "I" Info aufrufen
+159E 20 D4 . JR NZ,1574
+15A0 DD 21 31 1D .!1. LD IX,1D31
+15A4 CD C0 1A ... CALL 1AC0
+15A7 21 46 A0 !F. LD HL,A046
+15AA 11 19 7D ..} LD DE,7D19
+15AD 01 0A 00 ... LD BC,000A
+15B0 ED B0 .. LDIR
+15B2 CD 1F 70 ..p CALL 701F ; Info aufrufen
+15B5 18 06 .. JR 15BD ; " start"
+15B7 20 73 s JR NZ,162C
+15B9 74 t LD (HL),H
+15BA 61 a LD H,C
+15BB 72 r LD (HL),D
+15BC 74 t LD (HL),H
+15BD 18 B5 .. JR 1574 ; ------- Vortest Ende -----------
+15BF DD 21 31 1D .!1. LD IX,1D31 ; Systemstart
+15C3 CD C0 1A ... CALL 1AC0 ; Block 0 laden
+15C6 CD 66 1C .f. CALL 1C66 ; Etikett testen
+15C9 C3 6D 14 .m. JP 146D ; Zur Miniprozess Schleife
+15CC DD 21 36 1D .!6. LD IX,1D36 ;-- Neuen Urlader laden ------
+15D0 CD 9F 1A ... CALL 1A9F
+15D3 21 0A 00 !.. LD HL,000A
+15D6 22 32 1D "2. LD (1D32),HL
+15D9 22 37 1D "7. LD (1D37),HL
+15DC CD 03 16 ... CALL 1603
+15DF DD 21 31 1D .!1. LD IX,1D31
+15E3 CD 03 16 ... CALL 1603
+15E6 ED 4B 10 A0 .K.. LD BC,(A010)
+15EA 21 3A 00 !:. LD HL,003A
+15ED 37 7 SCF
+15EE ED 42 .B SBC HL,BC
+15F0 30 08 0. JR NC,15FA
+15F2 21 44 00 !D. LD HL,0044
+15F5 22 3B 1D ";. LD (1D3B),HL
+15F8 18 4E .N JR 1648
+15FA 21 D4 85 !.. LD HL,85D4
+15FD CD CA 6E ..n CALL 6ECA
+1600 C3 74 15 .t. JP 1574 ; Zum Vortest Menue
+1603 CD F2 1A ... CALL 1AF2
+1606 21 00 A0 !.. LD HL,A000
+1609 11 2A 1D .*. LD DE,1D2A
+160C 01 05 00 ... LD BC,0005
+160F CD 92 1C ... CALL 1C92
+1612 C2 74 15 .t. JP NZ,1574 ; Zum Vortest Menue
+1615 C9 . RET ;-------- Neuen HG vom ARchiv ----
+1616 21 C9 84 !.. LD HL,84C9 ; "ALten HG ueberschreiben (j/n) ?"
+1619 CD CA 6E ..n CALL 6ECA
+161C CD 9B 1C ... CALL 1C9B
+161F FE 79 .y CP 79 ; "y" oder
+1621 28 05 (. JR Z,1628
+1623 FE 6A .j CP 6A ; "j" erlaubt
+1625 C2 74 15 .t. JP NZ,1574
+1628 DD 21 31 1D .!1. LD IX,1D31 ; Ueberschreiben
+162C CD 9F 1A ... CALL 1A9F
+162F CD C0 1A ... CALL 1AC0
+1632 DD 21 36 1D .!6. LD IX,1D36
+1636 CD 9F 1A ... CALL 1A9F
+1639 CD C0 1A ... CALL 1AC0
+163C CD 66 1C .f. CALL 1C66
+163F 2A 24 A0 *$. LD HL,(A024)
+1642 29 ) ADD HL,HL
+1643 29 ) ADD HL,HL
+1644 29 ) ADD HL,HL
+1645 22 3B 1D ";. LD (1D3B),HL
+1648 CD B6 1C ... CALL 1CB6
+164B DD 21 31 1D .!1. LD IX,1D31
+164F CD D1 1B ... CALL 1BD1
+1652 DD 21 36 1D .!6. LD IX,1D36
+1656 CD F2 1A ... CALL 1AF2
+1659 DD 21 31 1D .!1. LD IX,1D31
+165D CD 08 1C ... CALL 1C08
+1660 CD BA 1B ... CALL 1BBA
+1663 2A 3B 1D *;. LD HL,(1D3B)
+1666 ED 5B 32 1D .[2. LD DE,(1D32)
+166A B7 . OR A
+166B ED 52 .R SBC HL,DE
+166D CA 8F 16 ... JP Z,168F
+1670 DD 21 36 1D .!6. LD IX,1D36
+1674 CD BA 1B ... CALL 1BBA
+1677 20 CF . JR NZ,1648
+1679 21 43 84 !C. LD HL,8443
+167C CD CA 6E ..n CALL 6ECA
+167F CD 9B 1C ... CALL 1C9B
+1682 FE 79 .y CP 79 ; "y" oder
+1684 28 04 (. JR Z,168A
+1686 FE 6A .j CP 6A ; "j" erlaubt
+1688 20 EF . JR NZ,1679
+168A CD 9F 1A ... CALL 1A9F
+168D 18 B9 .. JR 1648
+168F CD E0 1C ... CALL 1CE0
+1692 CD E0 1C ... CALL 1CE0
+1695 21 B5 84 !.. LD HL,84B5
+1698 CD CA 6E ..n CALL 6ECA
+169B 18 FE .. JR 169B
+169D 3E 01 >. LD A,01 ; ------ Hardwaretest
+169F 32 30 1D 20. LD (1D30),A
+16A2 21 6C 83 !l. LD HL,836C
+16A5 CD CA 6E ..n CALL 6ECA ; Hardwaretest Menue
+16A8 21 00 00 !.. LD HL,0000
+16AB 22 F3 1C ".. LD (1CF3),HL
+16AE CD 9B 1C ... CALL 1C9B
+16B1 FE 31 .1 CP 31 ; "1" Speichertest
+16B3 CA C6 16 ... JP Z,16C6
+16B6 FE 32 .2 CP 32 ; "2" Kanaltest
+16B8 CA 7C 17 .|. JP Z,177C
+16BB FE 33 .3 CP 33
+16BD 28 12 (. JR Z,16D1 ; "3" HG Test
+16BF FE 34 .4 CP 34 ; "4" Archivtest
+16C1 28 14 (. JR Z,16D7
+16C3 C3 74 15 .t. JP 1574
+16C6 CD C2 1C ... CALL 1CC2 ; ----Speichertest
+16C9 CD F0 17 ... CALL 17F0
+16CC CD B6 1C ... CALL 1CB6
+16CF 18 F5 .. JR 16C6 ; Wiederholen
+16D1 DD 21 31 1D .!1. LD IX,1D31 ; ------- HG Test
+16D5 18 04 .. JR 16DB
+16D7 DD 21 36 1D .!6. LD IX,1D36 ; -------- Archivtest
+16DB 21 C1 83 !.. LD HL,83C1
+16DE CD CA 6E ..n CALL 6ECA
+16E1 CD 9B 1C ... CALL 1C9B
+16E4 FE 31 .1 CP 31 ; "1" Lesetest
+16E6 28 0C (. JR Z,16F4
+16E8 FE 32 .2 CP 32 ; "2" Schreiblesetest
+16EA 28 21 (! JR Z,170D
+16EC FE 33 .3 CP 33 ; "3" Positioniertest
+16EE CA 60 17 .`. JP Z,1760
+16F1 C3 74 15 .t. JP 1574 ; Zum Vortest Menue
+16F4 CD C2 1C ... CALL 1CC2
+16F7 CD E0 1C ... CALL 1CE0
+16FA CD 9F 1A ... CALL 1A9F
+16FD CD B6 1C ... CALL 1CB6
+1700 CD D1 1B ... CALL 1BD1
+1703 CD F2 1A ... CALL 1AF2
+1706 CD BA 1B ... CALL 1BBA
+1709 20 F2 . JR NZ,16FD
+170B 18 E7 .. JR 16F4
+170D CD C2 1C ... CALL 1CC2
+1710 CD E0 1C ... CALL 1CE0
+1713 CD 9F 1A ... CALL 1A9F
+1716 CD B6 1C ... CALL 1CB6
+1719 CD D1 1B ... CALL 1BD1
+171C CD F2 1A ... CALL 1AF2
+171F 21 00 A0 !.. LD HL,A000
+1722 11 00 A2 ... LD DE,A200
+1725 01 00 02 ... LD BC,0200
+1728 ED B0 .. LDIR
+172A 3E 55 >U LD A,55
+172C CD 31 1C .1. CALL 1C31
+172F 3E AA >. LD A,AA
+1731 CD 31 1C .1. CALL 1C31
+1734 21 00 A2 !.. LD HL,A200
+1737 11 00 A0 ... LD DE,A000
+173A 01 00 02 ... LD BC,0200
+173D ED B0 .. LDIR
+173F CD 08 1C ... CALL 1C08
+1742 3E 55 >U LD A,55
+1744 CD 59 1C .Y. CALL 1C59
+1747 CD ED 1B ... CALL 1BED
+174A 21 00 A0 !.. LD HL,A000
+174D 11 00 A2 ... LD DE,A200
+1750 01 00 02 ... LD BC,0200
+1753 CD 92 1C ... CALL 1C92
+1756 C4 27 1C .'. CALL NZ,1C27
+1759 CD BA 1B ... CALL 1BBA
+175C 20 B8 . JR NZ,1716
+175E 18 AD .. JR 170D
+1760 CD C2 1C ... CALL 1CC2
+1763 CD E0 1C ... CALL 1CE0
+1766 CD 9F 1A ... CALL 1A9F
+1769 CD B6 1C ... CALL 1CB6
+176C CD C0 1A ... CALL 1AC0
+176F CD D1 1B ... CALL 1BD1
+1772 CD F2 1A ... CALL 1AF2
+1775 CD BA 1B ... CALL 1BBA
+1778 20 EF . JR NZ,1769
+177A 18 E4 .. JR 1760
+177C CD C2 1C ... CALL 1CC2
+177F CD E0 1C ... CALL 1CE0
+1782 CD B6 1C ... CALL 1CB6
+1785 3E 20 > LD A,20
+1787 32 30 85 20. LD (8530),A
+178A 3E 02 >. LD A,02
+178C F5 . PUSH AF
+178D 5F _ LD E,A
+178E CD 71 1E .q. CALL 1E71
+1791 38 53 8S JR C,17E6
+1793 F1 . POP AF
+1794 F5 . PUSH AF
+1795 CD 59 1E .Y. CALL 1E59
+1798 FE 1E .. CP 1E
+179A 38 20 8 JR C,17BC
+179C 16 00 .. LD D,00
+179E 21 31 85 !1. LD HL,8531
+17A1 36 20 6 LD (HL),20
+17A3 2B + DEC HL
+17A4 CD 00 4E ..N CALL 4E00
+17A7 21 28 85 !(. LD HL,8528
+17AA 4E N LD C,(HL)
+17AB 23 # INC HL
+17AC 06 00 .. LD B,00
+17AE F1 . POP AF
+17AF F5 . PUSH AF
+17B0 59 Y LD E,C
+17B1 CD 88 21 ..! CALL 2188
+17B4 38 06 8. JR C,17BC
+17B6 09 . ADD HL,BC
+17B7 7B { LD A,E
+17B8 91 . SUB C
+17B9 4F O LD C,A
+17BA 18 F2 .. JR 17AE
+17BC F1 . POP AF
+17BD F5 . PUSH AF
+17BE CD 06 1F ... CALL 1F06
+17C1 38 23 8# JR C,17E6
+17C3 5F _ LD E,A
+17C4 16 00 .. LD D,00
+17C6 21 20 20 ! LD HL,2020
+17C9 22 55 85 "U. LD (8555),HL
+17CC 21 54 85 !T. LD HL,8554
+17CF CD 00 4E ..N CALL 4E00
+17D2 F1 . POP AF
+17D3 F5 . PUSH AF
+17D4 5F _ LD E,A
+17D5 16 00 .. LD D,00
+17D7 21 42 85 !B. LD HL,8542
+17DA 36 20 6 LD (HL),20
+17DC 2B + DEC HL
+17DD CD 00 4E ..N CALL 4E00
+17E0 21 34 85 !4. LD HL,8534
+17E3 CD CA 6E ..n CALL 6ECA
+17E6 F1 . POP AF
+17E7 3C < INC A
+17E8 FE 20 . CP 20
+17EA DA 8C 17 ... JP C,178C
+17ED C3 7C 17 .|. JP 177C
+17F0 CD A0 28 ..( CALL 28A0
+17F3 15 . DEC D
+17F4 21 DE 85 !.. LD HL,85DE
+17F7 22 E7 1C ".. LD (1CE7),HL
+17FA EB . EX DE,HL
+17FB B7 . OR A
+17FC ED 52 .R SBC HL,DE
+17FE 22 E9 1C ".. LD (1CE9),HL
+1801 EB . EX DE,HL
+1802 CB 3A .: SLR D
+1804 CB 1B .. RR E
+1806 21 03 00 !.. LD HL,0003
+1809 CD 3D 4D .=M CALL 4D3D
+180C CB 23 .# SLA E
+180E CB 12 .. RL D
+1810 ED 53 EB 1C .S.. LD (1CEB),DE
+1814 21 DE 85 !.. LD HL,85DE
+1817 11 3F 1D .?. LD DE,1D3F
+181A B7 . OR A
+181B ED 52 .R SBC HL,DE
+181D 22 ED 1C ".. LD (1CED),HL
+1820 EB . EX DE,HL
+1821 21 03 00 !.. LD HL,0003
+1824 CD 3D 4D .=M CALL 4D3D
+1827 ED 53 EF 1C .S.. LD (1CEF),DE
+182B 21 FF FF !.. LD HL,FFFF
+182E 22 F1 1C ".. LD (1CF1),HL
+1831 2A E7 1C *.. LD HL,(1CE7)
+1834 CD 12 19 ... CALL 1912
+1837 21 00 00 !.. LD HL,0000
+183A 5C \ LD E,H
+183B E5 . PUSH HL
+183C CD C9 19 ... CALL 19C9
+183F 30 0D 0. JR NC,184E
+1841 CD 12 19 ... CALL 1912
+1844 E1 . POP HL
+1845 7C | LD A,H
+1846 C6 40 .@ ADD A,40
+1848 67 g LD H,A
+1849 30 01 0. JR NC,184C
+184B 1C . INC E
+184C 18 ED .. JR 183B
+184E E1 . POP HL ; Testmuster fuer Speichertest
+184F 11 01 55 ..U LD DE,5501
+1852 CD 22 19 .". CALL 1922
+1855 11 02 55 ..U LD DE,5502
+1858 CD 22 19 .". CALL 1922
+185B 11 00 AA ... LD DE,AA00
+185E CD 22 19 .". CALL 1922
+1861 11 01 55 ..U LD DE,5501
+1864 CD 7A 19 .z. CALL 197A
+1867 11 01 AA ... LD DE,AA01
+186A CD 22 19 .". CALL 1922
+186D 11 02 55 ..U LD DE,5502
+1870 CD 7A 19 .z. CALL 197A
+1873 11 00 AA ... LD DE,AA00
+1876 CD 7A 19 .z. CALL 197A
+1879 11 01 AA ... LD DE,AA01
+187C CD 7A 19 .z. CALL 197A
+187F 11 00 55 ..U LD DE,5500
+1882 CD 22 19 .". CALL 1922
+1885 11 00 55 ..U LD DE,5500
+1888 CD 7A 19 .z. CALL 197A
+188B 11 02 AA ... LD DE,AA02
+188E CD 22 19 .". CALL 1922
+1891 11 02 AA ... LD DE,AA02
+1894 CD 7A 19 .z. CALL 197A
+1897 2A E9 1C *.. LD HL,(1CE9)
+189A ED 5B ED 1C .[.. LD DE,(1CED)
+189E B7 . OR A
+189F ED 52 .R SBC HL,DE
+18A1 38 5D 8] JR C,1900
+18A3 F3 . DI
+18A4 21 3F 1D !?. LD HL,1D3F
+18A7 ED 5B E7 1C .[.. LD DE,(1CE7)
+18AB CD 1B 1A ... CALL 1A1B
+18AE 11 01 55 ..U LD DE,5501
+18B1 CD 07 1A ... CALL 1A07
+18B4 11 02 55 ..U LD DE,5502
+18B7 CD 07 1A ... CALL 1A07
+18BA 11 00 AA ... LD DE,AA00
+18BD CD 07 1A ... CALL 1A07
+18C0 11 01 55 ..U LD DE,5501
+18C3 CD 11 1A ... CALL 1A11
+18C6 11 01 AA ... LD DE,AA01
+18C9 CD 07 1A ... CALL 1A07
+18CC 11 02 55 ..U LD DE,5502
+18CF CD 11 1A ... CALL 1A11
+18D2 11 00 AA ... LD DE,AA00
+18D5 CD 11 1A ... CALL 1A11
+18D8 11 01 AA ... LD DE,AA01
+18DB CD 11 1A ... CALL 1A11
+18DE 11 00 55 ..U LD DE,5500
+18E1 CD 07 1A ... CALL 1A07
+18E4 11 00 55 ..U LD DE,5500
+18E7 CD 11 1A ... CALL 1A11
+18EA 11 02 AA ... LD DE,AA02
+18ED CD 07 1A ... CALL 1A07
+18F0 11 02 AA ... LD DE,AA02
+18F3 CD 11 1A ... CALL 1A11
+18F6 2A E7 1C *.. LD HL,(1CE7)
+18F9 11 3F 1D .?. LD DE,1D3F
+18FC CD 1B 1A ... CALL 1A1B
+18FF FB . EI
+1900 CD E0 1C ... CALL 1CE0
+1903 3A E6 1C :.. LD A,(1CE6)
+1906 B7 . OR A
+1907 C8 . RET Z
+1908 ED 7B 3D 1D .{=. LD SP,(1D3D)
+190C CD E0 1C ... CALL 1CE0
+190F C3 2B 18 .+. JP 182B
+1912 06 05 .. LD B,05
+1914 97 . SUB A
+1915 57 W LD D,A
+1916 77 w LD (HL),A
+1917 7E ~ LD A,(HL)
+1918 BA . CP D
+1919 C4 31 1A .1. CALL NZ,1A31
+191C 3C < INC A
+191D 20 F6 . JR NZ,1915
+191F 10 F3 .. DJNZ 1914
+1921 C9 . RET
+1922 2A E7 1C *.. LD HL,(1CE7)
+1925 ED 4B EB 1C .K.. LD BC,(1CEB)
+1929 CD 51 19 .Q. CALL 1951
+192C 26 00 &. LD H,00
+192E 6B k LD L,E
+192F 1E 00 .. LD E,00
+1931 E5 . PUSH HL
+1932 CD C9 19 ... CALL 19C9
+1935 30 0F 0. JR NC,1946
+1937 7D } LD A,L
+1938 72 r LD (HL),D
+1939 C6 03 .. ADD A,03
+193B 6F o LD L,A
+193C 30 FA 0. JR NC,1938
+193E E1 . POP HL
+193F 6F o LD L,A
+1940 24 $ INC H
+1941 20 EE . JR NZ,1931
+1943 1C . INC E
+1944 18 EB .. JR 1931
+1946 CD 6D 19 .m. CALL 196D
+1949 21 0B 1D !.. LD HL,1D0B
+194C CD CA 6E ..n CALL 6ECA
+194F E1 . POP HL
+1950 C9 . RET
+1951 D5 . PUSH DE
+1952 79 y LD A,C
+1953 B7 . OR A
+1954 28 01 (. JR Z,1957
+1956 04 . INC B
+1957 79 y LD A,C
+1958 48 H LD C,B
+1959 47 G LD B,A
+195A 7A z LD A,D
+195B 16 00 .. LD D,00
+195D 19 . ADD HL,DE
+195E 11 03 00 ... LD DE,0003
+1961 77 w LD (HL),A
+1962 19 . ADD HL,DE
+1963 10 FC .. DJNZ 1961
+1965 0D . DEC C
+1966 20 F9 . JR NZ,1961
+1968 D1 . POP DE
+1969 CD 6D 19 .m. CALL 196D
+196C C9 . RET
+196D F5 . PUSH AF
+196E C5 . PUSH BC
+196F 3E 00 >. LD A,00
+1971 06 64 .d LD B,64
+1973 ED 4F .O LD R,A
+1975 10 FC .. DJNZ 1973
+1977 C1 . POP BC
+1978 F1 . POP AF
+1979 C9 . RET
+197A 2A E7 1C *.. LD HL,(1CE7)
+197D ED 4B EB 1C .K.. LD BC,(1CEB)
+1981 CD A1 19 ... CALL 19A1
+1984 26 00 &. LD H,00
+1986 6B k LD L,E
+1987 5C \ LD E,H
+1988 E5 . PUSH HL
+1989 CD C9 19 ... CALL 19C9
+198C 30 B8 0. JR NC,1946
+198E 7E ~ LD A,(HL)
+198F BA . CP D
+1990 C4 31 1A .1. CALL NZ,1A31
+1993 7D } LD A,L
+1994 C6 03 .. ADD A,03
+1996 6F o LD L,A
+1997 30 F5 0. JR NC,198E
+1999 E1 . POP HL
+199A 6F o LD L,A
+199B 24 $ INC H
+199C 20 EA . JR NZ,1988
+199E 1C . INC E
+199F 18 E7 .. JR 1988
+19A1 D5 . PUSH DE
+19A2 79 y LD A,C
+19A3 B7 . OR A
+19A4 28 01 (. JR Z,19A7
+19A6 04 . INC B
+19A7 79 y LD A,C
+19A8 48 H LD C,B
+19A9 47 G LD B,A
+19AA 7A z LD A,D
+19AB 16 00 .. LD D,00
+19AD 19 . ADD HL,DE
+19AE 11 FF FF ... LD DE,FFFF
+19B1 ED 53 F1 1C .S.. LD (1CF1),DE
+19B5 57 W LD D,A
+19B6 7E ~ LD A,(HL)
+19B7 BA . CP D
+19B8 C4 31 1A .1. CALL NZ,1A31
+19BB 7D } LD A,L
+19BC C6 03 .. ADD A,03
+19BE 6F o LD L,A
+19BF 30 01 0. JR NC,19C2
+19C1 24 $ INC H
+19C2 10 F2 .. DJNZ 19B6
+19C4 0D . DEC C
+19C5 20 EF . JR NZ,19B6
+19C7 D1 . POP DE
+19C8 C9 . RET
+19C9 E5 . PUSH HL
+19CA 6C l LD L,H
+19CB 63 c LD H,E
+19CC 24 $ INC H
+19CD 22 F1 1C ".. LD (1CF1),HL
+19D0 25 % DEC H
+19D1 D5 . PUSH DE
+19D2 55 U LD D,L
+19D3 CB 3C .< SLR H
+19D5 CB 1D .. RR L
+19D7 E5 . PUSH HL
+19D8 ED 4B 0D 1D .K.. LD BC,(1D0D)
+19DC B7 . OR A
+19DD ED 42 .B SBC HL,BC
+19DF E1 . POP HL
+19E0 30 08 0. JR NC,19EA
+19E2 CD EE 19 ... CALL 19EE
+19E5 7A z LD A,D
+19E6 E6 01 .. AND 01
+19E8 B4 . OR H
+19E9 37 7 SCF
+19EA D1 . POP DE
+19EB E1 . POP HL
+19EC 67 g LD H,A
+19ED C9 . RET
+19EE 3A 10 1D :.. LD A,(1D10)
+19F1 CB 7F .. BIT 7,A
+19F3 C2 8D 28 ..( JP NZ,288D
+19F6 CB 3C .< SLR H
+19F8 CB 1D .. RR L
+19FA 7D } LD A,L
+19FB 2A 11 1D *.. LD HL,(1D11)
+19FE 30 02 0. JR NC,1A02
+1A00 CB CC .. SET 1,H
+1A02 2E 00 .. LD L,00
+1A04 C3 8D 28 ..( JP 288D
+1A07 21 3F 1D !?. LD HL,1D3F
+1A0A ED 4B EF 1C .K.. LD BC,(1CEF)
+1A0E C3 51 19 .Q. JP 1951
+1A11 21 3F 1D !?. LD HL,1D3F
+1A14 ED 4B EF 1C .K.. LD BC,(1CEF)
+1A18 C3 A1 19 ... JP 19A1
+1A1B ED 4B ED 1C .K.. LD BC,(1CED)
+1A1F ED B0 .. LDIR
+1A21 2B + DEC HL
+1A22 1B . DEC DE
+1A23 ED 4B ED 1C .K.. LD BC,(1CED)
+1A27 1A . LD A,(DE)
+1A28 ED A9 .. CPD
+1A2A 20 FE . JR NZ,1A2A
+1A2C 1B . DEC DE
+1A2D EA 27 1A .'. JP PE,1A27
+1A30 C9 . RET
+1A31 F5 . PUSH AF
+1A32 C5 . PUSH BC
+1A33 D5 . PUSH DE
+1A34 E5 . PUSH HL
+1A35 42 B LD B,D
+1A36 4F O LD C,A
+1A37 ED 5B F1 1C .[.. LD DE,(1CF1)
+1A3B CB 7A .z BIT 7,D
+1A3D 28 25 (% JR Z,1A64
+1A3F E5 . PUSH HL
+1A40 EB . EX DE,HL
+1A41 2A E7 1C *.. LD HL,(1CE7)
+1A44 B7 . OR A
+1A45 ED 52 .R SBC HL,DE
+1A47 E1 . POP HL
+1A48 38 16 8. JR C,1A60
+1A4A E5 . PUSH HL
+1A4B C5 . PUSH BC
+1A4C 11 3F 1D .?. LD DE,1D3F
+1A4F 2A E7 1C *.. LD HL,(1CE7)
+1A52 CD 1B 1A ... CALL 1A1B
+1A55 C1 . POP BC
+1A56 E1 . POP HL
+1A57 FB . EI
+1A58 3E 00 >. LD A,00
+1A5A CD 66 1A .f. CALL 1A66
+1A5D C3 08 19 ... JP 1908
+1A60 3E 00 >. LD A,00
+1A62 18 02 .. JR 1A66
+1A64 7A z LD A,D
+1A65 63 c LD H,E
+1A66 F5 . PUSH AF
+1A67 3E 01 >. LD A,01
+1A69 32 E6 1C 2.. LD (1CE6),A
+1A6C 11 D2 85 ... LD DE,85D2
+1A6F 79 y LD A,C
+1A70 CD F5 1C ... CALL 1CF5
+1A73 11 CA 85 ... LD DE,85CA
+1A76 78 x LD A,B
+1A77 CD F5 1C ... CALL 1CF5
+1A7A F1 . POP AF
+1A7B 11 BE 85 ... LD DE,85BE
+1A7E CD F5 1C ... CALL 1CF5
+1A81 7C | LD A,H
+1A82 CD F5 1C ... CALL 1CF5
+1A85 7D } LD A,L
+1A86 CD F5 1C ... CALL 1CF5
+1A89 21 B0 85 !.. LD HL,85B0
+1A8C CD CA 6E ..n CALL 6ECA
+1A8F 3E 01 >. LD A,01
+1A91 CD 06 1F ... CALL 1F06
+1A94 38 F9 8. JR C,1A8F
+1A96 FE 0D .. CP 0D
+1A98 20 F5 . JR NZ,1A8F
+1A9A E1 . POP HL
+1A9B D1 . POP DE
+1A9C C1 . POP BC
+1A9D F1 . POP AF
+1A9E C9 . RET
+1A9F DD 7E 00 .~. LD A,(IX+00)
+1AA2 01 05 00 ... LD BC,0005
+1AA5 DD E5 .. PUSH IX
+1AA7 D5 . PUSH DE
+1AA8 11 00 00 ... LD DE,0000
+1AAB CD A8 28 ..( CALL 28A8
+1AAE D1 . POP DE
+1AAF DD E1 .. POP IX
+1AB1 DD 71 03 .q. LD (IX+03),C
+1AB4 DD 70 04 .p. LD (IX+04),B
+1AB7 DD 36 01 00 .6.. LD (IX+01),00
+1ABB DD 36 02 00 .6.. LD (IX+02),00
+1ABF C9 . RET
+1AC0 21 00 A0 !.. LD HL,A000
+1AC3 11 00 00 ... LD DE,0000
+1AC6 01 00 00 ... LD BC,0000
+1AC9 DD 7E 00 .~. LD A,(IX+00)
+1ACC DD E5 .. PUSH IX
+1ACE CD 7E 28 .~( CALL 287E
+1AD1 DD E1 .. POP IX
+1AD3 0C . INC C
+1AD4 0D . DEC C
+1AD5 C8 . RET Z
+1AD6 21 00 A0 !.. LD HL,A000
+1AD9 DD 7E 00 .~. LD A,(IX+00)
+1ADC 01 00 00 ... LD BC,0000
+1ADF DD E5 .. PUSH IX
+1AE1 CD 7E 28 .~( CALL 287E
+1AE4 DD E1 .. POP IX
+1AE6 0C . INC C
+1AE7 0D . DEC C
+1AE8 C8 . RET Z
+1AE9 21 A4 84 !.. LD HL,84A4
+1AEC CD CA 6E ..n CALL 6ECA
+1AEF C3 74 15 .t. JP 1574
+1AF2 21 00 A0 !.. LD HL,A000
+1AF5 06 40 .@ LD B,40
+1AF7 3E 1E >. LD A,1E
+1AF9 77 w LD (HL),A
+1AFA 23 # INC HL
+1AFB 10 FC .. DJNZ 1AF9
+1AFD DD 5E 01 .^. LD E,(IX+01)
+1B00 DD 56 02 .V. LD D,(IX+02)
+1B03 3E 14 >. LD A,14
+1B05 F5 . PUSH AF
+1B06 21 00 A0 !.. LD HL,A000
+1B09 01 00 00 ... LD BC,0000
+1B0C DD 7E 00 .~. LD A,(IX+00)
+1B0F DD E5 .. PUSH IX
+1B11 CD 7E 28 .~( CALL 287E
+1B14 21 00 A0 !.. LD HL,A000
+1B17 06 40 .@ LD B,40
+1B19 3E 1E >. LD A,1E
+1B1B BE . CP (HL)
+1B1C 20 05 . JR NZ,1B23
+1B1E 23 # INC HL
+1B1F 10 FA .. DJNZ 1B1B
+1B21 0E 1E .. LD C,1E
+1B23 DD E1 .. POP IX
+1B25 F1 . POP AF
+1B26 0D . DEC C
+1B27 F2 32 1B .2. JP P,1B32
+1B2A FE 14 .. CP 14
+1B2C C8 . RET Z
+1B2D 21 27 84 !'. LD HL,8427
+1B30 18 4C .L JR 1B7E
+1B32 FE 0A .. CP 0A
+1B34 20 14 . JR NZ,1B4A
+1B36 D5 . PUSH DE
+1B37 F5 . PUSH AF
+1B38 21 00 A0 !.. LD HL,A000
+1B3B DD 7E 00 .~. LD A,(IX+00)
+1B3E 11 00 00 ... LD DE,0000
+1B41 DD E5 .. PUSH IX
+1B43 CD 7E 28 .~( CALL 287E
+1B46 DD E1 .. POP IX
+1B48 F1 . POP AF
+1B49 D1 . POP DE
+1B4A 3D = DEC A
+1B4B 20 B8 . JR NZ,1B05
+1B4D 21 FD FF !.. LD HL,FFFD ; -3 ist Markierung f. defekten Bl.
+1B50 22 00 A0 ".. LD (A000),HL
+1B53 21 00 A0 !.. LD HL,A000
+1B56 11 02 A0 ... LD DE,A002
+1B59 01 FE 01 ... LD BC,01FE
+1B5C ED B0 .. LDIR
+1B5E 21 31 84 !1. LD HL,8431
+1B61 3A 30 1D :0. LD A,(1D30)
+1B64 B7 . OR A
+1B65 20 17 . JR NZ,1B7E
+1B67 CD CA 6E ..n CALL 6ECA
+1B6A 21 77 85 !w. LD HL,8577
+1B6D CD CA 6E ..n CALL 6ECA
+1B70 CD 9B 1C ... CALL 1C9B
+1B73 FE 6E .n CP 6E
+1B75 CA 74 15 .t. JP Z,1574
+1B78 CD E0 1C ... CALL 1CE0
+1B7B C3 F2 1A ... JP 1AF2
+1B7E 3A 30 1D :0. LD A,(1D30)
+1B81 B7 . OR A
+1B82 28 1B (. JR Z,1B9F
+1B84 CD A6 1B ... CALL 1BA6
+1B87 21 68 84 !h. LD HL,8468
+1B8A CD CA 6E ..n CALL 6ECA
+1B8D CD 9B 1C ... CALL 1C9B
+1B90 F5 . PUSH AF
+1B91 CD E0 1C ... CALL 1CE0
+1B94 F1 . POP AF
+1B95 FE 79 .y CP 79
+1B97 28 02 (. JR Z,1B9B
+1B99 FE 6A .j CP 6A
+1B9B CC 08 1C ... CALL Z,1C08
+1B9E C9 . RET
+1B9F CD A6 1B ... CALL 1BA6
+1BA2 CD E0 1C ... CALL 1CE0
+1BA5 C9 . RET
+1BA6 E5 . PUSH HL
+1BA7 21 91 85 !.. LD HL,8591
+1BAA DD 7E 00 .~. LD A,(IX+00)
+1BAD B7 . OR A
+1BAE 28 03 (. JR Z,1BB3
+1BB0 21 95 85 !.. LD HL,8595
+1BB3 CD CA 6E ..n CALL 6ECA
+1BB6 E1 . POP HL
+1BB7 C3 CA 6E ..n JP 6ECA
+1BBA DD 5E 01 .^. LD E,(IX+01)
+1BBD DD 56 02 .V. LD D,(IX+02)
+1BC0 DD 6E 03 .n. LD L,(IX+03)
+1BC3 DD 66 04 .f. LD H,(IX+04)
+1BC6 13 . INC DE
+1BC7 DD 73 01 .s. LD (IX+01),E
+1BCA DD 72 02 .r. LD (IX+02),D
+1BCD B7 . OR A
+1BCE ED 52 .R SBC HL,DE
+1BD0 C9 . RET
+1BD1 DD 5E 01 .^. LD E,(IX+01)
+1BD4 DD 56 02 .V. LD D,(IX+02)
+1BD7 21 20 20 ! LD HL,2020
+1BDA 22 26 1D "&. LD (1D26),HL
+1BDD 22 28 1D "(. LD (1D28),HL
+1BE0 21 25 1D !%. LD HL,1D25
+1BE3 CD 00 4E ..N CALL 4E00
+1BE6 21 22 1D !". LD HL,1D22
+1BE9 CD CA 6E ..n CALL 6ECA
+1BEC C9 . RET
+1BED DD 5E 01 .^. LD E,(IX+01)
+1BF0 DD 56 02 .V. LD D,(IX+02)
+1BF3 21 00 A0 !.. LD HL,A000
+1BF6 01 00 00 ... LD BC,0000
+1BF9 DD 7E 00 .~. LD A,(IX+00)
+1BFC DD E5 .. PUSH IX
+1BFE CD 7E 28 .~( CALL 287E
+1C01 DD E1 .. POP IX
+1C03 78 x LD A,B
+1C04 B1 . OR C
+1C05 20 20 JR NZ,1C27
+1C07 C9 . RET
+1C08 06 05 .. LD B,05
+1C0A C5 . PUSH BC
+1C0B 21 00 A0 !.. LD HL,A000
+1C0E DD 5E 01 .^. LD E,(IX+01)
+1C11 DD 56 02 .V. LD D,(IX+02)
+1C14 01 00 00 ... LD BC,0000
+1C17 DD 7E 00 .~. LD A,(IX+00)
+1C1A DD E5 .. PUSH IX
+1C1C CD 81 28 ..( CALL 2881
+1C1F DD E1 .. POP IX
+1C21 79 y LD A,C
+1C22 B0 . OR B
+1C23 C1 . POP BC
+1C24 C8 . RET Z
+1C25 10 E3 .. DJNZ 1C0A
+1C27 21 08 84 !.. LD HL,8408
+1C2A CD A6 1B ... CALL 1BA6
+1C2D CD E0 1C ... CALL 1CE0
+1C30 C9 . RET
+1C31 F5 . PUSH AF
+1C32 CD 59 1C .Y. CALL 1C59
+1C35 CD 08 1C ... CALL 1C08
+1C38 3E 0F >. LD A,0F
+1C3A CD 59 1C .Y. CALL 1C59
+1C3D CD ED 1B ... CALL 1BED
+1C40 F1 . POP AF
+1C41 21 00 A0 !.. LD HL,A000
+1C44 01 00 02 ... LD BC,0200
+1C47 ED A1 .. CPI
+1C49 20 04 . JR NZ,1C4F
+1C4B EA 92 1C ... JP PE,1C92
+1C4E C9 . RET
+1C4F 21 16 84 !.. LD HL,8416
+1C52 CD CA 6E ..n CALL 6ECA
+1C55 CD E0 1C ... CALL 1CE0
+1C58 C9 . RET
+1C59 21 00 A0 !.. LD HL,A000
+1C5C 11 01 A0 ... LD DE,A001
+1C5F 01 FF 01 ... LD BC,01FF
+1C62 77 w LD (HL),A
+1C63 ED B0 .. LDIR
+1C65 C9 . RET ; ---- Korrekten Block 0 testen
+1C66 21 00 A0 !.. LD HL,A000
+1C69 11 2A 1D .*. LD DE,1D2A ; "EUMEL-"
+1C6C 01 06 00 ... LD BC,0006
+1C6F CD 92 1C ... CALL 1C92
+1C72 20 12 . JR NZ,1C86 ; "HG-ungueltig"
+1C74 21 09 A0 !.. LD HL,A009
+1C77 11 86 82 ... LD DE,8286 ;
+1C7A 01 02 00 ... LD BC,0002
+1C7D CD 92 1C ... CALL 1C92 ; Versionsnummer
+1C80 C8 . RET Z
+1C81 21 93 84 !.. LD HL,8493 ; "Falsche Version"
+1C84 18 03 .. JR 1C89
+1C86 21 85 84 !.. LD HL,8485
+1C89 CD CA 6E ..n CALL 6ECA
+1C8C CD 9B 1C ... CALL 1C9B
+1C8F C3 74 15 .t. JP 1574 ; Zum Vortest Menue
+1C92 1A . LD A,(DE) ; Zeichenkette vergleichen
+1C93 13 . INC DE
+1C94 ED A1 .. CPI
+1C96 C0 . RET NZ
+1C97 EA 92 1C ... JP PE,1C92
+1C9A C9 . RET ;----------- Auf Taste warten > A --
+1C9B 3E 01 >. LD A,01 ; Kanal 1
+1C9D CD 06 1F ... CALL 1F06 ; Auf Taste warten
+1CA0 38 F9 8. JR C,1C9B ; Warten!
+1CA2 FE 1B .. CP 1B ; ESC
+1CA4 CA 74 15 .t. JP Z,1574 ; Zum Vortest Menue
+1CA7 FE 20 . CP 20 ;
+1CA9 D8 . RET C ; < Blank zurueck
+1CAA 32 1E 1D 2.. LD (1D1E),A
+1CAD F5 . PUSH AF
+1CAE 21 1D 1D !.. LD HL,1D1D ; CRLF
+1CB1 CD CA 6E ..n CALL 6ECA ; ausgeben
+1CB4 F1 . POP AF
+1CB5 C9 . RET ;----- incharety an Kanal 1
+1CB6 3E 01 >. LD A,01
+1CB8 CD 06 1F ... CALL 1F06 ;
+1CBB D8 . RET C ; Wenn nichts da ist
+1CBC FE 1B .. CP 1B
+1CBE CA 74 15 .t. JP Z,1574 ; ESC --> Zum Vortest Menue
+1CC1 C9 . RET ; -------- Zaehlpuffer loeschen
+1CC2 21 20 20 ! LD HL,2020
+1CC5 22 AA 85 ".. LD (85AA),HL
+1CC8 22 AC 85 ".. LD (85AC),HL
+1CCB ED 5B F3 1C .[.. LD DE,(1CF3)
+1CCF 13 . INC DE
+1CD0 ED 53 F3 1C .S.. LD (1CF3),DE
+1CD4 21 A9 85 !.. LD HL,85A9
+1CD7 CD 00 4E ..N CALL 4E00 ; Dezimal -- ASCII Konvertiereung
+1CDA 21 9D 85 !.. LD HL,859D ; Puffer ausgeben
+1CDD C3 CA 6E ..n JP 6ECA
+1CE0 21 16 1D !.. LD HL,1D16 ; CRLF ausgeben
+1CE3 C3 CA 6E ..n JP 6ECA
+1CE6 00 . NOP
+1CE7 00 . NOP
+1CE8 00 . NOP
+1CE9 00 . NOP
+1CEA 00 . NOP
+1CEB 00 . NOP
+1CEC 00 . NOP
+1CED 00 . NOP
+1CEE 00 . NOP
+1CEF 00 . NOP
+1CF0 00 . NOP
+1CF1 00 . NOP
+1CF2 00 . NOP
+1CF3 00 . NOP
+1CF4 00 . NOP
+1CF5 F5 . PUSH AF ;- Byte in A Hex --> (DE),(DE+1)
+1CF6 0F . RRCA
+1CF7 0F . RRCA
+1CF8 0F . RRCA
+1CF9 0F . RRCA
+1CFA CD FE 1C ... CALL 1CFE
+1CFD F1 . POP AF
+1CFE E6 0F .. AND 0F
+1D00 C6 30 .0 ADD A,30
+1D02 FE 3A .: CP 3A
+1D04 38 02 8. JR C,1D08
+1D06 C6 07 .. ADD A,07
+1D08 12 . LD (DE),A
+1D09 13 . INC DE
+1D0A C9 . RET ; ------ Zeichentexte ------
+1D0B 01 2A 00 .*. LD BC,002A ; "*" Laenge 1
+1D0E 00 . NOP
+1D0F 00 . NOP
+1D10 00 . NOP
+1D11 00 . NOP
+1D12 00 . NOP
+1D13 00 . NOP
+1D14 01 20 02 . . LD BC,0220 ; Blank
+1D17 0A . LD A,(BC) ; CRLF
+1D18 0D . DEC C
+1D19 03 . INC BC ; ", 1"
+1D1A 2C , INC L
+1D1B 20 31 1 JR NZ,1D4E
+1D1D 04 . INC B ; Blank, CR, LF,LF
+1D1E 20 0D . JR NZ,1D2D
+1D20 0A . LD A,(BC)
+1D21 0A . LD A,(BC)
+1D22 07 . RLCA ; CR, "# "
+1D23 0D . DEC C
+1D24 23 # INC HL
+1D25 20 20 JR NZ,1D47
+1D27 20 20 JR NZ,1D49
+1D29 20 45 E JR NZ,1D70 ; "EUMEL-" HG Kennzeichen
+1D2B 55 U LD D,L
+1D2C 4D M LD C,L
+1D2D 45 E LD B,L
+1D2E 4C L LD C,H
+1D2F 2D - DEC L
+1D30 00 . NOP
+1D31 00 . NOP ; Harddisk Descriptor
+1D32 00 . NOP
+1D33 00 . NOP
+1D34 00 . NOP
+1D35 00 . NOP
+1D36 1F . RRA ; Floppy Descriptor
+1D37 00 . NOP
+1D38 00 . NOP
+1D39 00 . NOP
+1D3A 00 . NOP
+1D3B 00 . NOP
+1D3C 00 . NOP
+1D3D 00 . NOP
+1D3E 00 . NOP
+1D3F FF . RST 38 ; ====== Ende des nichtresidenten
+1D40 FF . RST 38 ; EUMEL0 Teils ==================
+1D41 FF . RST 38
+1D42 FF . RST 38
+1D43 FF . RST 38
+1D44 FF . RST 38
+1D45 FF . RST 38
+1D46 FF . RST 38
+1D47 FF . RST 38
+1D48 FF . RST 38
+1D49 FF . RST 38
+1D4A FF . RST 38
+1D4B FF . RST 38
+1D4C FF . RST 38
+1D4D FF . RST 38
+1D4E FF . RST 38
+1D4F FF . RST 38
+1D50 FF . RST 38
+1D51 FF . RST 38
+1D52 FF . RST 38
+1D53 FF . RST 38
+1D54 FF . RST 38
+1D55 FF . RST 38
+1D56 FF . RST 38
+1D57 FF . RST 38
+1D58 FF . RST 38
+1D59 FF . RST 38
+1D5A FF . RST 38
+1D5B FF . RST 38
+1D5C FF . RST 38
+1D5D FF . RST 38
+1D5E FF . RST 38
+1D5F FF . RST 38
+1D60 FF . RST 38
+1D61 FF . RST 38
+1D62 FF . RST 38
+1D63 FF . RST 38
+1D64 FF . RST 38
+1D65 FF . RST 38
+1D66 FF . RST 38
+1D67 FF . RST 38
+1D68 FF . RST 38
+1D69 FF . RST 38
+1D6A FF . RST 38
+1D6B FF . RST 38
+1D6C FF . RST 38
+1D6D FF . RST 38
+1D6E FF . RST 38
+1D6F FF . RST 38
+1D70 FF . RST 38
+1D71 FF . RST 38
+1D72 FF . RST 38
+1D73 FF . RST 38
+1D74 FF . RST 38
+1D75 FF . RST 38
+1D76 FF . RST 38
+1D77 FF . RST 38
+1D78 FF . RST 38
+1D79 FF . RST 38
+1D7A FF . RST 38
+1D7B FF . RST 38
+1D7C FF . RST 38
+1D7D FF . RST 38
+1D7E FF . RST 38
+1D7F FF . RST 38
+1D80 FF . RST 38
+1D81 FF . RST 38
+1D82 FF . RST 38
+1D83 FF . RST 38
+1D84 FF . RST 38
+1D85 FF . RST 38
+1D86 FF . RST 38
+1D87 FF . RST 38
+1D88 FF . RST 38
+1D89 FF . RST 38
+1D8A FF . RST 38
+1D8B FF . RST 38
+1D8C FF . RST 38
+1D8D FF . RST 38
+1D8E FF . RST 38
+1D8F FF . RST 38
+1D90 FF . RST 38
+1D91 FF . RST 38
+1D92 FF . RST 38
+1D93 FF . RST 38
+1D94 FF . RST 38
+1D95 FF . RST 38
+1D96 FF . RST 38
+1D97 FF . RST 38
+1D98 FF . RST 38
+1D99 FF . RST 38
+1D9A FF . RST 38
+1D9B FF . RST 38
+1D9C FF . RST 38
+1D9D FF . RST 38
+1D9E FF . RST 38
+1D9F FF . RST 38
+1DA0 FF . RST 38
+1DA1 FF . RST 38
+1DA2 FF . RST 38
+1DA3 FF . RST 38
+1DA4 FF . RST 38
+1DA5 FF . RST 38
+1DA6 FF . RST 38
+1DA7 FF . RST 38
+1DA8 FF . RST 38
+1DA9 FF . RST 38
+1DAA FF . RST 38
+1DAB FF . RST 38
+1DAC FF . RST 38
+1DAD FF . RST 38
+1DAE FF . RST 38
+1DAF FF . RST 38
+1DB0 FF . RST 38
+1DB1 FF . RST 38
+1DB2 FF . RST 38
+1DB3 FF . RST 38
+1DB4 FF . RST 38
+1DB5 FF . RST 38
+1DB6 FF . RST 38
+1DB7 FF . RST 38
+1DB8 FF . RST 38
+1DB9 FF . RST 38
+1DBA FF . RST 38
+1DBB FF . RST 38
+1DBC FF . RST 38
+1DBD FF . RST 38
+1DBE FF . RST 38
+1DBF FF . RST 38
+1DC0 FF . RST 38
+1DC1 FF . RST 38
+1DC2 FF . RST 38
+1DC3 FF . RST 38
+1DC4 FF . RST 38
+1DC5 FF . RST 38
+1DC6 FF . RST 38
+1DC7 FF . RST 38
+1DC8 FF . RST 38
+1DC9 FF . RST 38
+1DCA FF . RST 38
+1DCB FF . RST 38
+1DCC FF . RST 38
+1DCD FF . RST 38
+1DCE FF . RST 38
+1DCF FF . RST 38
+1DD0 FF . RST 38
+1DD1 FF . RST 38
+1DD2 FF . RST 38
+1DD3 FF . RST 38
+1DD4 FF . RST 38
+1DD5 FF . RST 38
+1DD6 FF . RST 38
+1DD7 FF . RST 38
+1DD8 FF . RST 38
+1DD9 FF . RST 38
+1DDA FF . RST 38
+1DDB FF . RST 38
+1DDC FF . RST 38
+1DDD FF . RST 38
+1DDE FF . RST 38
+1DDF FF . RST 38
+1DE0 FF . RST 38
+1DE1 FF . RST 38
+1DE2 FF . RST 38
+1DE3 FF . RST 38
+1DE4 FF . RST 38
+1DE5 FF . RST 38
+1DE6 FF . RST 38
+1DE7 FF . RST 38
+1DE8 FF . RST 38
+1DE9 FF . RST 38
+1DEA FF . RST 38
+1DEB FF . RST 38
+1DEC FF . RST 38
+1DED FF . RST 38
+1DEE FF . RST 38
+1DEF FF . RST 38
+1DF0 FF . RST 38
+1DF1 FF . RST 38
+1DF2 FF . RST 38
+1DF3 FF . RST 38
+1DF4 FF . RST 38
+1DF5 FF . RST 38
+1DF6 FF . RST 38
+1DF7 FF . RST 38
+1DF8 FF . RST 38
+1DF9 FF . RST 38
+1DFA FF . RST 38
+1DFB FF . RST 38
+1DFC FF . RST 38
+1DFD FF . RST 38
+1DFE FF . RST 38
+1DFF FF . RST 38
+1E00 FF . RST 38 ; ======= Residenter EUMEL0 =======
+1E01 FF . RST 38 ; DR EIntrag des DRDR
+1E02 FF . RST 38
+1E03 FF . RST 38
+1E04 FF . RST 38
+1E05 FF . RST 38
+1E06 FF . RST 38
+1E07 FF . RST 38
+1E08 FF . RST 38
+1E09 FF . RST 38
+1E0A FF . RST 38
+1E0B FF . RST 38
+1E0C FF . RST 38
+1E0D FF . RST 38
+1E0E FF . RST 38
+1E0F FF . RST 38 ; ---------- 173 Leiste ---------
+1E10 C3 DF 28 ..( JP 28DF ; systemstart 173
+1E13 C3 71 1F .q. JP 1F71 ; inputinterrupt
+1E16 C3 35 6E .5n JP 6E35 ; timerinterrupt
+1E19 C3 E2 6D ..m JP 6DE2 ; warte
+1E1C C3 22 1E .". JP 1E22 ; frei eumel0 (nur 173)
+1E1F C3 1F 70 ..p JP 701F ; info (Text uebergeben)
+1E22 3A 6D 28 :m( LD A,(286D) ;----------- frei eumel0 ---------
+1E25 CB C7 .. SET 0,A ; MODE Bit 0 setzen
+1E27 32 6D 28 2m( LD (286D),A
+1E2A C9 . RET ;--------------------------------
+1E2B FF . RST 38
+1E2C FF . RST 38
+1E2D FF . RST 38
+1E2E FF . RST 38
+1E2F FF . RST 38
+1E30 FF . RST 38
+1E31 FF . RST 38
+1E32 FF . RST 38
+1E33 FF . RST 38
+1E34 FF . RST 38
+1E35 FF . RST 38
+1E36 FF . RST 38
+1E37 FF . RST 38
+1E38 FF . RST 38
+1E39 FF . RST 38
+1E3A FF . RST 38
+1E3B FF . RST 38
+1E3C FF . RST 38
+1E3D FF . RST 38
+1E3E FF . RST 38
+1E3F FF . RST 38
+1E40 FF . RST 38
+1E41 FF . RST 38
+1E42 FF . RST 38
+1E43 FF . RST 38
+1E44 FF . RST 38
+1E45 FF . RST 38
+1E46 FF . RST 38
+1E47 FF . RST 38
+1E48 FF . RST 38
+1E49 FF . RST 38
+1E4A FF . RST 38
+1E4B 74 t LD (HL),H ; "trmnet 10 (!)"
+1E4C 72 r LD (HL),D
+1E4D 6D m LD L,L
+1E4E 6E n LD L,(HL)
+1E4F 65 e LD H,L
+1E50 74 t LD (HL),H
+1E51 20 20 JR NZ,1E73
+1E53 31 30 20 10 LD SP,2030
+1E56 28 21 (! JR Z,1E79
+1E58 29 ) ADD HL,HL ;---------- intern frout ---------
+1E59 FE 11 .. CP 11
+1E5B D0 . RET NC
+1E5C E5 . PUSH HL
+1E5D CD EB 23 ..# CALL 23EB
+1E60 CB 5E .^ BIT 3,(HL)
+1E62 E1 . POP HL
+1E63 28 02 (. JR Z,1E67
+1E65 97 . SUB A ; Ist Stop-Taste gedrueckt
+1E66 C9 . RET
+1E67 C5 . PUSH BC ; Weiter gedrueckt
+1E68 01 02 00 ... LD BC,0002 ; IOCONTROL frout
+1E6B CD A8 28 ..( CALL 28A8
+1E6E 79 y LD A,C
+1E6F C1 . POP BC
+1E70 C9 . RET ;-------- intern typ --------------
+1E71 32 B8 26 2.& LD (26B8),A
+1E74 C5 . PUSH BC
+1E75 01 01 00 ... LD BC,0001 ; IOCONTROL typ
+1E78 CD A8 28 ..( CALL 28A8
+1E7B 79 y LD A,C
+1E7C E6 03 .. AND 03
+1E7E FE 03 .. CP 03
+1E80 C1 . POP BC
+1E81 3A B8 26 :.& LD A,(26B8)
+1E84 C9 . RET ; ---------- cursorpos --> BC ---
+1E85 FE 11 .. CP 11
+1E87 D0 . RET NC
+1E88 E5 . PUSH HL
+1E89 CD EB 23 ..# CALL 23EB ; Kanaltabellenaddresse
+1E8C 01 02 00 ... LD BC,0002
+1E8F 09 . ADD HL,BC
+1E90 4E N LD C,(HL)
+1E91 23 # INC HL
+1E92 46 F LD B,(HL)
+1E93 E1 . POP HL
+1E94 B7 . OR A
+1E95 C9 . RET ;----------------------------------
+1E96 DD 7E 04 .~. LD A,(IX+04) ; Grosser Puffer leer ?
+1E99 D6 01 .. SUB A,01
+1E9B 30 0B 0. JR NC,1EA8
+1E9D DD 7E 0B .~. LD A,(IX+0B)
+1EA0 D6 01 .. SUB A,01
+1EA2 30 04 0. JR NC,1EA8
+1EA4 CD E4 1E ... CALL 1EE4 ; IOCONTROL weiter
+1EA7 37 7 SCF
+1EA8 C1 . POP BC
+1EA9 DD E1 .. POP IX
+1EAB E1 . POP HL
+1EAC C9 . RET ;---------------------------------
+1EAD FE 11 .. CP 11
+1EAF 3F ? CCF
+1EB0 D8 . RET C
+1EB1 E5 . PUSH HL
+1EB2 DD E5 .. PUSH IX
+1EB4 C5 . PUSH BC
+1EB5 32 AC 26 2.& LD (26AC),A
+1EB8 CD FA 23 ..# CALL 23FA
+1EBB 3A A9 26 :.& LD A,(26A9)
+1EBE B7 . OR A
+1EBF 28 11 (. JR Z,1ED2
+1EC1 F5 . PUSH AF
+1EC2 97 . SUB A
+1EC3 32 A9 26 2.& LD (26A9),A
+1EC6 F1 . POP AF
+1EC7 28 09 (. JR Z,1ED2
+1EC9 CD 1F 70 ..p CALL 701F
+1ECC 18 04 .. JR 1ED2
+1ECE 20 69 i JR NZ,1F39 ; Info aufrufen
+1ED0 6E n LD L,(HL) ; " int"
+1ED1 74 t LD (HL),H
+1ED2 DD 2A AD 26 .*.& LD IX,(26AD)
+1ED6 CB 6E .n BIT 5,(HL)
+1ED8 20 BC . JR NZ,1E96 ; Grosser Puffer
+1EDA DD 7E 04 .~. LD A,(IX+04) ; Kleiner Puffer leer ?
+1EDD FE 07 .. CP 07
+1EDF 28 15 (. JR Z,1EF6
+1EE1 B7 . OR A
+1EE2 18 51 .Q JR 1F35
+1EE4 3A AC 26 :.& LD A,(26AC) ;---------- intern weiter --------
+1EE7 01 04 00 ... LD BC,0004 ; IOCONTROL weiter
+1EEA C3 A8 28 ..( JP 28A8
+1EED C5 . PUSH BC ;---------- intern stop -----------
+1EEE 01 03 00 ... LD BC,0003
+1EF1 CD A8 28 ..( CALL 28A8 ; IOCONTORL stop
+1EF4 C1 . POP BC
+1EF5 C9 . RET ;----------------------------------
+1EF6 CD E4 1E ... CALL 1EE4 ; CALL weiter
+1EF9 DD 7E 04 .~. LD A,(IX+04) ;
+1EFC FE 07 .. CP 07
+1EFE 28 03 (. JR Z,1F03 ; Puffer leer ?
+1F00 B7 . OR A
+1F01 18 32 .2 JR 1F35 ; Routine mit CLC verlassen
+1F03 37 7 SCF
+1F04 18 2F ./ JR 1F35 ; ROutine mit SEC verlassen
+1F06 CD AD 1E ... CALL 1EAD ;---------------------------------
+1F09 D8 . RET C
+1F0A E5 . PUSH HL
+1F0B DD E5 .. PUSH IX
+1F0D C5 . PUSH BC
+1F0E DD 2A AD 26 .*.& LD IX,(26AD)
+1F12 DD 7E 07 .~. LD A,(IX+07)
+1F15 DD CB 00 6E ...n BIT 5,(IX+00)
+1F19 20 1F . JR NZ,1F3A
+1F1B 2A AD 26 *.& LD HL,(26AD)
+1F1E 01 07 00 ... LD BC,0007
+1F21 09 . ADD HL,BC
+1F22 D5 . PUSH DE
+1F23 54 T LD D,H
+1F24 5D ] LD E,L
+1F25 23 # INC HL
+1F26 01 0F 00 ... LD BC,000F
+1F29 F3 . DI
+1F2A ED B0 .. LDIR
+1F2C DD 35 .5 DEC (IX+04)
+1F2E 04 . INC B
+1F2F DD 35 .5 DEC (IX+05)
+1F31 05 . DEC B
+1F32 FB . EI
+1F33 D1 . POP DE
+1F34 B7 . OR A
+1F35 C1 . POP BC
+1F36 DD E1 .. POP IX
+1F38 E1 . POP HL
+1F39 C9 . RET
+1F3A 67 g LD H,A ; Pufferaddresse
+1F3B DD 6E 0C .n. LD L,(IX+0C) ; Pufferaddresse
+1F3E CD 81 5A ..Z CALL 5A81
+1F41 DD 7E 05 .~. LD A,(IX+05) ; Lowbyte Schreibzeiger
+1F44 3C < INC A
+1F45 DD 77 05 .w. LD (IX+05),A
+1F48 20 03 . JR NZ,1F4D
+1F4A DD 34 .4 INC (IX+0A) ; Highbyte Schreibzeiger
+1F4C 0A . LD A,(BC)
+1F4D 6F o LD L,A
+1F4E DD 7E 0A .~. LD A,(IX+0A)
+1F51 E6 01 .. AND 01
+1F53 84 . ADD H
+1F54 67 g LD H,A
+1F55 7E ~ LD A,(HL)
+1F56 F5 . PUSH AF
+1F57 CD 8C 5A ..Z CALL 5A8C
+1F5A F3 . DI
+1F5B DD 6E 04 .n. LD L,(IX+04) ; Jetzt darf kein Inputinter. komm.
+1F5E DD 66 0B .f. LD H,(IX+0B)
+1F61 2B + DEC HL
+1F62 DD 74 0B .t. LD (IX+0B),H
+1F65 DD 75 04 .u. LD (IX+04),L
+1F68 FB . EI
+1F69 7D } LD A,L
+1F6A B7 . OR A
+1F6B CC E4 1E ... CALL Z,1EE4 ; CALL weiter
+1F6E F1 . POP AF
+1F6F 18 C3 .. JR 1F34 ;=========== inputinterrupt =======
+1F71 FE 11 .. CP 11 ; B=Eingabezeichen
+1F73 D0 . RET NC ; C=Errorbits
+1F74 DD E5 .. PUSH IX
+1F76 E5 . PUSH HL
+1F77 F5 . PUSH AF
+1F78 CD EB 23 ..# CALL 23EB ; Kanaltabelleaddresse
+1F7B E5 . PUSH HL
+1F7C DD E1 .. POP IX
+1F7E CB B9 .. RES 7,C ;
+1F80 CB A9 .. RES 5,C ; Pufferoverflowbit
+1F82 DD 7E 01 .~. LD A,(IX+01)
+1F85 B1 . OR C ; Mit Bits vom Shard verodern
+1F86 DD 77 01 .w. LD (IX+01),A
+1F89 CB 7F .. BIT 7,A
+1F8B 28 0A (. JR Z,1F97
+1F8D E5 . PUSH HL
+1F8E DD CB 01 F6 .... SET 6,(IX+01)
+1F92 21 A9 26 !.& LD HL,26A9
+1F95 34 4 INC (HL)
+1F96 E1 . POP HL
+1F97 DD CB 01 FE .... SET 7,(IX+01)
+1F9B CB 6E .n BIT 5,(HL) ; Grosser Puffer ?
+1F9D 28 6F (o JR Z,200E
+1F9F DD 7E 0B .~. LD A,(IX+0B) ; ja
+1FA2 FE 01 .. CP 01
+1FA4 38 0E 8. JR C,1FB4 ; < 1 (=0) : Nicht voll
+1FA6 20 3A : JR NZ,1FE2 ; > 1 (=2) : Voll
+1FA8 DD 7E 04 .~. LD A,(IX+04) ; = 180 ,
+1FAB FE 80 .. CP 80 ; Puffer 3/4b voll Hysterese Stop
+1FAD 20 05 . JR NZ,1FB4
+1FAF F1 . POP AF
+1FB0 F5 . PUSH AF
+1FB1 CD ED 1E ... CALL 1EED ; CALL stop
+1FB4 DD 34 .4 INC (IX+04)
+1FB6 04 . INC B
+1FB7 20 03 . JR NZ,1FBC
+1FB9 DD 34 .4 INC (IX+0B)
+1FBB 0B . DEC BC
+1FBC DD 66 07 .f. LD H,(IX+07)
+1FBF DD 6E 0C .n. LD L,(IX+0C)
+1FC2 78 x LD A,B
+1FC3 C5 . PUSH BC
+1FC4 F5 . PUSH AF
+1FC5 CD 81 5A ..Z CALL 5A81
+1FC8 DD 7E 08 .~. LD A,(IX+08)
+1FCB 3C < INC A
+1FCC DD 77 08 .w. LD (IX+08),A
+1FCF 6F o LD L,A
+1FD0 20 03 . JR NZ,1FD5
+1FD2 DD 34 .4 INC (IX+09)
+1FD4 09 . ADD HL,BC
+1FD5 DD 7E 09 .~. LD A,(IX+09)
+1FD8 E6 01 .. AND 01
+1FDA 84 . ADD H
+1FDB 67 g LD H,A
+1FDC F1 . POP AF
+1FDD 77 w LD (HL),A
+1FDE CD 8C 5A ..Z CALL 5A8C
+1FE1 C1 . POP BC
+1FE2 DD CB 01 EE .... SET 5,(IX+01) ; Pufferoverflow setzen
+1FE6 F1 . POP AF
+1FE7 21 AB 26 !.& LD HL,26AB
+1FEA CB B6 .. RES 6,(HL)
+1FEC DD CB 01 BE .... RES 7,(IX+01)
+1FF0 FB . EI
+1FF1 DD CB 00 6E ...n BIT 5,(IX+00) ; Groer Puffer ?
+1FF5 20 09 . JR NZ,2000
+1FF7 3E 17 >. LD A,17 ; Pufferende-Lesezeiger
+1FF9 DD 96 04 ... SUB (IX+04) ; Platz im Puffer
+1FFC E1 . POP HL
+1FFD DD E1 .. POP IX
+1FFF C9 . RET ;----------- Ende von inputinterr.
+2000 DD 7E 0B .~. LD A,(IX+0B)
+2003 B7 . OR A
+2004 3E FF >. LD A,FF
+2006 28 F4 (. JR Z,1FFC
+2008 97 . SUB A
+2009 DD 96 04 ... SUB (IX+04)
+200C 18 EE .. JR 1FFC
+200E F1 . POP AF ;------ kleiner Puffer ------------
+200F F5 . PUSH AF
+2010 CD 95 26 ..& CALL 2695 ; Typtabellennummer
+2013 FE 7E .~ CP 7E ; psi ?
+2015 20 29 ) JR NZ,2040
+2017 78 x LD A,B ; info-Taste
+2018 FE 04 .. CP 04
+201A 28 18 (. JR Z,2034
+201C FE 07 .. CP 07 ; SV-Call
+201E 28 1A (. JR Z,203A
+2020 FE 11 .. CP 11 ; Stop
+2022 28 0A (. JR Z,202E
+2024 FE 17 .. CP 17 ; Weiter
+2026 20 18 . JR NZ,2040
+2028 DD CB 00 9E .... RES 3,(IX+00) ; Weiter gedrueckt
+202C 18 B8 .. JR 1FE6
+202E DD CB 00 DE .... SET 3,(IX+00) ; Stop gedrueckt
+2032 18 B2 .. JR 1FE6
+2034 F1 . POP AF ; info-taste gedrueckt
+2035 CD 33 6F .3o CALL 6F33
+2038 18 AD .. JR 1FE7
+203A F1 . POP AF ; SV-Call gedrueckt
+203B CD 93 4C ..L CALL 4C93 ; SV-Call zustellen
+203E 18 A7 .. JR 1FE7
+2040 C5 . PUSH BC ; nicht psi als tabelle
+2041 DD 7E 05 .~. LD A,(IX+05) ; Schreibzeiger >= 16H ?
+2044 FE 16 .. CP 16
+2046 D2 F2 20 .. JP NC,20F2 ; Pufferoverflow setzen
+2049 21 AB 26 !.& LD HL,26AB
+204C CB F6 .. SET 6,(HL)
+204E 4F O LD C,A
+204F 06 00 .. LD B,00
+2051 DD E5 .. PUSH IX
+2053 E1 . POP HL
+2054 09 . ADD HL,BC
+2055 C1 . POP BC
+2056 70 p LD (HL),B
+2057 23 # INC HL
+2058 36 FF 6. LD (HL),FF
+205A DD 34 .4 INC (IX+05) ; Schreibzeiger
+205C 05 . DEC B
+205D FE 0E .. CP 0E
+205F 20 0E . JR NZ,206F
+2061 F1 . POP AF
+2062 F5 . PUSH AF
+2063 CD 95 26 ..& CALL 2695
+2066 CB 7E .~ BIT 7,(HL)
+2068 28 05 (. JR Z,206F
+206A F1 . POP AF
+206B F5 . PUSH AF
+206C CD ED 1E ... CALL 1EED
+206F F1 . POP AF
+2070 F5 . PUSH AF
+2071 CD 95 26 ..& CALL 2695
+2074 FE 7E .~ CP 7E
+2076 D2 EB 20 .. JP NC,20EB
+2079 CD 1F 24 ..$ CALL 241F
+207C D5 . PUSH DE
+207D C5 . PUSH BC
+207E 01 80 01 ... LD BC,0180
+2081 09 . ADD HL,BC
+2082 E5 . PUSH HL
+2083 EB . EX DE,HL
+2084 DD E5 .. PUSH IX
+2086 E1 . POP HL
+2087 DD 4E 04 .N. LD C,(IX+04)
+208A 06 00 .. LD B,00
+208C 09 . ADD HL,BC
+208D 1A . LD A,(DE) ; Zeichen an Lesezeigerposition holen
+208E 13 . INC DE
+208F 3C < INC A
+2090 F5 . PUSH AF
+2091 20 04 . JR NZ,2097
+2093 1A . LD A,(DE) ; Zeichen = FF ?
+2094 3C < INC A
+2095 28 38 (8 JR Z,20CF
+2097 E5 . PUSH HL
+2098 EB . EX DE,HL
+2099 1A . LD A,(DE)
+209A ED A1 .. CPI
+209C 20 24 $ JR NZ,20C2
+209E 13 . INC DE
+209F 3C < INC A
+20A0 20 F7 . JR NZ,2099
+20A2 E1 . POP HL
+20A3 F1 . POP AF
+20A4 3D = DEC A
+20A5 FE 11 .. CP 11 ; Weiter
+20A7 CA 1C 21 ..! JP Z,211C
+20AA FE 04 .. CP 04 ; Info
+20AC 28 56 (V JR Z,2104
+20AE FE 07 .. CP 07 ; SV-Call
+20B0 28 5E (^ JR Z,2110
+20B2 FE 17 .. CP 17 ; Stop
+20B4 CA 22 21 ."! JP Z,2122
+20B7 77 w LD (HL),A ; Anderer Eingabecode
+20B8 DD 34 .4 INC (IX+04) ; Lese-Zeiger weitersetzen
+20BA 04 . INC B
+20BB 23 # INC HL
+20BC CD 2F 21 ./! CALL 212F
+20BF E1 . POP HL
+20C0 18 1B .. JR 20DD
+20C2 3C < INC A
+20C3 28 1C (. JR Z,20E1
+20C5 7E ~ LD A,(HL)
+20C6 23 # INC HL
+20C7 3C < INC A
+20C8 20 FB . JR NZ,20C5
+20CA EB . EX DE,HL
+20CB E1 . POP HL
+20CC F1 . POP AF
+20CD 18 BE .. JR 208D
+20CF F1 . POP AF
+20D0 E1 . POP HL
+20D1 DD 34 .4 INC (IX+04)
+20D3 04 . INC B
+20D4 DD 7E 04 .~. LD A,(IX+04) ; Lesezeiger = Schreibzeiger ?
+20D7 DD BE 05 ... CP (IX+05)
+20DA C2 82 20 .. JP NZ,2082
+20DD C1 . POP BC
+20DE D1 . POP DE
+20DF 18 0D .. JR 20EE
+20E1 3E 02 >. LD A,02
+20E3 32 AB 26 2.& LD (26AB),A
+20E6 E1 . POP HL
+20E7 F1 . POP AF
+20E8 E1 . POP HL
+20E9 18 F2 .. JR 20DD
+20EB DD 34 .4 INC (IX+04) ; Zeiger weitersetzen
+20ED 04 . INC B
+20EE F1 . POP AF
+20EF C3 E7 1F ... JP 1FE7
+20F2 DD CB 01 EE .... SET 5,(IX+01) ; Bit 5 : Puffer overflow
+20F6 DD 7E 04 .~. LD A,(IX+04) ; Schreibzeiger := Lesezeiger
+20F9 DD 77 05 .w. LD (IX+05),A
+20FC 3E 03 >. LD A,03
+20FE 32 AB 26 2.& LD (26AB),A
+2101 C1 . POP BC
+2102 18 EA .. JR 20EE ;-------------- Info-Taste --------
+2104 CD 2F 21 ./! CALL 212F
+2107 E1 . POP HL
+2108 C1 . POP BC
+2109 D1 . POP DE
+210A F1 . POP AF
+210B CD 33 6F .3o CALL 6F33
+210E 18 DF .. JR 20EF ;--------------- SV-Call ---------
+2110 CD 2F 21 ./! CALL 212F
+2113 E1 . POP HL
+2114 C1 . POP BC
+2115 D1 . POP DE
+2116 F1 . POP AF
+2117 CD 93 4C ..L CALL 4C93
+211A 18 D3 .. JR 20EF ;-------------- Weiter-Taste ------
+211C DD CB 00 DE .... SET 3,(IX+00) ; Weiterbit setzen
+2120 18 04 .. JR 2126 ;-------------- Stop-Taste --------
+2122 DD CB 00 9E .... RES 3,(IX+00) ;
+2126 CD 2F 21 ./! CALL 212F
+2129 E1 . POP HL
+212A C1 . POP BC
+212B D1 . POP DE
+212C F1 . POP AF
+212D 18 C0 .. JR 20EF
+212F DD 7E 04 .~. LD A,(IX+04) ; Schreibzeiger := Lesezeiger
+2132 DD 77 05 .w. LD (IX+05),A
+2135 3E FF >. LD A,FF ; Puffer bis zum Ende mit FF fuellen
+2137 77 w LD (HL),A
+2138 23 # INC HL
+2139 7B { LD A,E
+213A BD . CP L
+213B 20 F8 . JR NZ,2135
+213D C9 . RET ; ------ Test ob Puffer overflow
+213E F5 . PUSH AF
+213F E5 . PUSH HL
+2140 21 B2 26 !.& LD HL,26B2
+2143 CB 7E .~ BIT 7,(HL)
+2145 28 02 (. JR Z,2149
+2147 86 . ADD (HL)
+2148 77 w LD (HL),A
+2149 3A AB 26 :.& LD A,(26AB)
+214C 3D = DEC A
+214D FA 85 21 ..! JP M,2185
+2150 32 AB 26 2.& LD (26AB),A
+2153 20 30 0 JR NZ,2185
+2155 DD E5 .. PUSH IX
+2157 D5 . PUSH DE
+2158 C5 . PUSH BC
+2159 11 18 00 ... LD DE,0018
+215C 3E 01 >. LD A,01 ; Beginne mit Kanal 1
+215E CD EB 23 ..# CALL 23EB ; Zeiger auf Kanaltabelle --> HL
+2161 06 10 .. LD B,10 ; Fuer 16 Kanaele
+2163 E5 . PUSH HL
+2164 DD E1 .. POP IX
+2166 DD CB 00 6E ...n BIT 5,(IX+00) ; Groer Puffer
+216A 20 11 . JR NZ,217D ; kein overflow
+216C F3 . DI
+216D DD 7E 05 .~. LD A,(IX+05) ; Schreibzeiger >= 16H ?
+2170 FE 16 .. CP 16
+2172 38 05 8. JR C,2179
+2174 3E 13 >. LD A,13 ; zuruecksetzen auf 13
+2176 DD 77 05 .w. LD (IX+05),A
+2179 DD 77 04 .w. LD (IX+04),A
+217C FB . EI
+217D DD 19 .. ADD IX,DE ; Next entry
+217F 10 E5 .. DJNZ 2166
+2181 C1 . POP BC
+2182 D1 . POP DE
+2183 DD E1 .. POP IX
+2185 E1 . POP HL
+2186 F1 . POP AF
+2187 C9 . RET ;----------- OUTPUT ------------
+2188 FE 11 .. CP 11
+218A D2 7B 28 .{( JP NC,287B
+218D F5 . PUSH AF
+218E DD E5 .. PUSH IX
+2190 32 AC 26 2.& LD (26AC),A
+2193 E5 . PUSH HL
+2194 CD 95 26 ..& CALL 2695
+2197 D2 3A 22 .:" JP NC,223A
+219A 32 B1 26 2.& LD (26B1),A
+219D 3A AC 26 :.& LD A,(26AC)
+21A0 CD FA 23 ..# CALL 23FA
+21A3 DD 2A AD 26 .*.& LD IX,(26AD)
+21A7 7E ~ LD A,(HL)
+21A8 E6 0B .. AND 0B
+21AA 28 24 ($ JR Z,21D0
+21AC CB 5F ._ BIT 3,A
+21AE 20 0C . JR NZ,21BC
+21B0 CB 47 .G BIT 0,A
+21B2 28 13 (. JR Z,21C7
+21B4 3A AC 26 :.& LD A,(26AC)
+21B7 CD 59 1E .Y. CALL 1E59
+21BA 38 09 8. JR C,21C5
+21BC E1 . POP HL
+21BD DD E1 .. POP IX
+21BF F1 . POP AF
+21C0 01 00 00 ... LD BC,0000
+21C3 B7 . OR A
+21C4 C9 . RET
+21C5 CB 86 .. RES 0,(HL)
+21C7 3A B2 26 :.& LD A,(26B2)
+21CA CB 7F .. BIT 7,A
+21CC 20 EE . JR NZ,21BC
+21CE CB 8E .. RES 1,(HL)
+21D0 E1 . POP HL
+21D1 D5 . PUSH DE
+21D2 E5 . PUSH HL
+21D3 3A B1 26 :.& LD A,(26B1)
+21D6 CD 1F 24 ..$ CALL 241F
+21D9 54 T LD D,H
+21DA 5D ] LD E,L
+21DB E1 . POP HL
+21DC E5 . PUSH HL
+21DD C5 . PUSH BC
+21DE 78 x LD A,B
+21DF B1 . OR C
+21E0 20 08 . JR NZ,21EA
+21E2 C1 . POP BC
+21E3 E1 . POP HL
+21E4 D1 . POP DE
+21E5 DD E1 .. POP IX
+21E7 F1 . POP AF
+21E8 37 7 SCF
+21E9 C9 . RET
+21EA E5 . PUSH HL
+21EB 7E ~ LD A,(HL)
+21EC 2A AD 26 *.& LD HL,(26AD)
+21EF CB 56 .V BIT 2,(HL)
+21F1 28 0F (. JR Z,2202
+21F3 CB 66 .f BIT 4,(HL)
+21F5 CA 07 23 ..# JP Z,2307
+21F8 CB A6 .. RES 4,(HL)
+21FA 23 # INC HL
+21FB 23 # INC HL
+21FC 77 w LD (HL),A
+21FD E1 . POP HL
+21FE 23 # INC HL
+21FF 0B . DEC BC
+2200 18 DC .. JR 21DE
+2202 E1 . POP HL
+2203 E5 . PUSH HL
+2204 C5 . PUSH BC
+2205 3A B1 26 :.& LD A,(26B1)
+2208 FE 7E .~ CP 7E
+220A 28 35 (5 JR Z,2241
+220C E5 . PUSH HL
+220D 6E n LD L,(HL)
+220E 26 00 &. LD H,00
+2210 19 . ADD HL,DE
+2211 7E ~ LD A,(HL)
+2212 3C < INC A
+2213 20 38 8 JR NZ,224D
+2215 E1 . POP HL
+2216 ED A1 .. CPI
+2218 EA 0C 22 .." JP PE,220C
+221B C1 . POP BC
+221C E1 . POP HL
+221D C5 . PUSH BC
+221E 3A AC 26 :.& LD A,(26AC)
+2221 CD 7B 28 .{( CALL 287B
+2224 F5 . PUSH AF
+2225 DD 7E 03 .~. LD A,(IX+03) ; xpos INCR C
+2228 81 . ADD C
+2229 DD 77 03 .w. LD (IX+03),A
+222C F1 . POP AF
+222D D2 CE 23 ..# JP NC,23CE
+2230 09 . ADD HL,BC
+2231 E3 . EX (SP),HL
+2232 B7 . OR A
+2233 ED 42 .B SBC HL,BC
+2235 44 D LD B,H
+2236 4D M LD C,L
+2237 E1 . POP HL
+2238 18 A4 .. JR 21DE
+223A E1 . POP HL
+223B DD E1 .. POP IX
+223D F1 . POP AF
+223E C3 7B 28 .{( JP 287B
+2241 3E 0D >. LD A,0D
+2243 BE . CP (HL)
+2244 30 08 0. JR NC,224E
+2246 ED A1 .. CPI
+2248 EA 43 22 .C" JP PE,2243
+224B 18 CE .. JR 221B
+224D E1 . POP HL
+224E 7E ~ LD A,(HL)
+224F E1 . POP HL
+2250 E5 . PUSH HL
+2251 B7 . OR A
+2252 ED 42 .B SBC HL,BC
+2254 28 06 (. JR Z,225C
+2256 44 D LD B,H
+2257 4D M LD C,L
+2258 E1 . POP HL
+2259 E3 . EX (SP),HL
+225A 18 C2 .. JR 221E
+225C F5 . PUSH AF
+225D 3A AC 26 :.& LD A,(26AC)
+2260 C5 . PUSH BC
+2261 01 02 00 ... LD BC,0002 ; IOCONTROL frout
+2264 CD A8 28 ..( CALL 28A8
+2267 79 y LD A,C
+2268 C1 . POP BC
+2269 FE 10 .. CP 10
+226B DA E6 23 ..# JP C,23E6
+226E F1 . POP AF
+226F CD 79 22 .y" CALL 2279
+2272 C1 . POP BC
+2273 E1 . POP HL
+2274 0B . DEC BC
+2275 23 # INC HL
+2276 C3 DE 21 ..! JP 21DE ;-------- cursor mitfuehren ------
+2279 FE 06 .. CP 06
+227B CA FF 22 .." JP Z,22FF
+227E 38 54 8T JR C,22D4
+2280 FE 08 .. CP 08 ; Left
+2282 28 15 (. JR Z,2299
+2284 FE 07 .. CP 07 ; Bell: Keine Veraenderung
+2286 28 5B ([ JR Z,22E3
+2288 FE 0A .. CP 0A ; LF
+228A 28 12 (. JR Z,229E
+228C DD 34 .4 INC (IX+03) ; Alles andere wie right
+228E 03 . INC BC
+228F FE 0D .. CP 0D ; CR
+2291 20 50 P JR NZ,22E3
+2293 DD 36 03 00 .6.. LD (IX+03),00
+2297 18 4A .J JR 22E3
+2299 DD 35 .5 DEC (IX+03)
+229B 03 . INC BC
+229C 18 45 .E JR 22E3
+229E F5 . PUSH AF
+229F DD 7E 02 .~. LD A,(IX+02) ; ypos des cursors
+22A2 DD BE 06 ... CP (IX+06) ; max. ypos (wird mit ysize ges.)
+22A5 28 03 (. JR Z,22AA
+22A7 DD 34 .4 INC (IX+02) ; ypos +1
+22A9 02 . LD (BC),A
+22AA F1 . POP AF
+22AB 18 36 .6 JR 22E3
+22AD E5 . PUSH HL
+22AE 23 # INC HL
+22AF CD 5F 23 ._# CALL 235F
+22B2 E1 . POP HL
+22B3 7E ~ LD A,(HL)
+22B4 B7 . OR A
+22B5 C8 . RET Z
+22B6 2A AD 26 *.& LD HL,(26AD)
+22B9 CB C6 .. SET 0,(HL)
+22BB CB CE .. SET 1,(HL)
+22BD 3E 81 >. LD A,81
+22BF 32 B2 26 2.& LD (26B2),A
+22C2 C3 E0 23 ..# JP 23E0
+22C5 DD 36 02 00 .6.. LD (IX+02),00
+22C9 DD 36 03 00 .6.. LD (IX+03),00
+22CD 18 14 .. JR 22E3
+22CF DD 34 .4 INC (IX+03)
+22D1 03 . INC BC
+22D2 18 0F .. JR 22E3
+22D4 FE 01 .. CP 01 ; Home ?
+22D6 28 ED (. JR Z,22C5
+22D8 FE 02 .. CP 02 ; Right ?
+22DA 28 F3 (. JR Z,22CF
+22DC FE 03 .. CP 03 ; Up
+22DE 20 03 . JR NZ,22E3
+22E0 DD 35 .5 DEC (IX+02) ; ypos-1
+22E2 02 . LD (BC),A
+22E3 6F o LD L,A
+22E4 3A B1 26 :.& LD A,(26B1)
+22E7 FE 7E .~ CP 7E
+22E9 20 04 . JR NZ,22EF
+22EB 7D } LD A,L
+22EC C3 B8 23 ..# JP 23B8
+22EF 26 00 &. LD H,00
+22F1 19 . ADD HL,DE
+22F2 7E ~ LD A,(HL)
+22F3 FE 80 .. CP 80
+22F5 DA B8 23 ..# JP C,23B8
+22F8 D6 80 .. SUB A,80
+22FA 62 b LD H,D
+22FB 6F o LD L,A
+22FC 24 $ INC H
+22FD 18 AE .. JR 22AD ;---------- cursor (x,y) ----------
+22FF 2A AD 26 *.& LD HL,(26AD)
+2302 CB D6 .. SET 2,(HL)
+2304 CB E6 .. SET 4,(HL)
+2306 C9 . RET ;---------------------------------
+2307 23 # INC HL
+2308 23 # INC HL
+2309 23 # INC HL
+230A 77 w LD (HL),A
+230B 3A B1 26 :.& LD A,(26B1)
+230E FE 7E .~ CP 7E ; psi ?
+2310 20 11 . JR NZ,2323
+2312 3E 06 >. LD A,06 ; Code 6
+2314 CD B8 23 ..# CALL 23B8
+2317 2B + DEC HL
+2318 7E ~ LD A,(HL) ; y pos
+2319 CD B8 23 ..# CALL 23B8
+231C 23 # INC HL
+231D 7E ~ LD A,(HL) ; x pos
+231E CD B8 23 ..# CALL 23B8
+2321 18 31 .1 JR 2354
+2323 14 . INC D
+2324 1A . LD A,(DE)
+2325 15 . DEC D
+2326 3C < INC A
+2327 20 0E . JR NZ,2337
+2329 DD 7E 03 .~. LD A,(IX+03) ; alte xpos
+232C D6 50 .P SUB A,50 ; 80 Spalten Umbruch
+232E 38 07 8. JR C,2337
+2330 DD CB 02 F6 .... SET 6,(IX+02)
+2334 DD 77 03 .w. LD (IX+03),A
+2337 C5 . PUSH BC
+2338 21 06 00 !.. LD HL,0006 ; Cursorstringcode = 6
+233B 19 . ADD HL,DE
+233C 7E ~ LD A,(HL) ; Ist immer ein outstring
+233D CB BF .. RES 7,A
+233F 24 $ INC H ; Outstringpage
+2340 6F o LD L,A
+2341 2C , INC L ; keine wartezeit
+2342 CD 5F 23 ._# CALL 235F ; prestring ausgeben
+2345 23 # INC HL
+2346 CD 6C 23 .l# CALL 236C ; x/y pos ausgeben
+2349 CD 5F 23 ._# CALL 235F ; midstring ausgeben
+234C 23 # INC HL
+234D CD 6C 23 .l# CALL 236C ; x/y pos ausgeben
+2350 CD 5F 23 ._# CALL 235F ; poststring ausgeben
+2353 C1 . POP BC ; naechstes zeichen interpretieren
+2354 2A AD 26 *.& LD HL,(26AD)
+2357 CB 96 .. RES 2,(HL)
+2359 E1 . POP HL
+235A 23 # INC HL
+235B 0B . DEC BC
+235C C3 DE 21 ..! JP 21DE ; string ausgeben (mit 0 am ende)
+235F 06 46 .F LD B,46 ; max 70 zeichen
+2361 7E ~ LD A,(HL)
+2362 B7 . OR A
+2363 28 06 (. JR Z,236B
+2365 CD B8 23 ..# CALL 23B8 ; char out
+2368 23 # INC HL
+2369 10 F6 .. DJNZ 2361
+236B C9 . RET ;----------- x/y pos out ---------
+236C 7E ~ LD A,(HL) ; zeichen "x" oder "y"
+236D E5 . PUSH HL
+236E 2A AD 26 *.& LD HL,(26AD) ; zeiger auf x pos (26ad)+2
+2371 23 # INC HL
+2372 23 # INC HL
+2373 FE 79 .y CP 79 ; "y" Kennzeichen
+2375 28 01 (. JR Z,2378
+2377 23 # INC HL ; ypos
+2378 46 F LD B,(HL) ; neue position --> B
+2379 FD E5 .. PUSH IY
+237B 14 . INC D ;
+237C D5 . PUSH DE
+237D FD E1 .. POP IY
+237F 15 . DEC D
+2380 FE 79 .y CP 79 ; "y" Kennzeichen
+2382 28 02 (. JR Z,2386
+2384 FD 23 .# INC IY
+2386 FD 7E 02 .~. LD A,(IY+02) ; Offset + pos
+2389 80 . ADD B
+238A FD CB 00 56 ...V BIT 2,(IY+00) ; Keine Konvertierung
+238E 20 0C . JR NZ,239C
+2390 FD CB 00 46 ...F BIT 0,(IY+00) ; Dezimale ASCII-Ausgabe
+2394 20 0E . JR NZ,23A4
+2396 FE 0C .. CP 0C ; Elbit Cursor
+2398 38 02 8. JR C,239C
+239A C6 04 .. ADD A,04 ; ywert
+239C CD B8 23 ..# CALL 23B8 ; Byte ausgeben
+239F FD E1 .. POP IY
+23A1 E1 . POP HL
+23A2 23 # INC HL
+23A3 C9 . RET ;--------- Dezimal ausgeben -------
+23A4 D5 . PUSH DE
+23A5 5F _ LD E,A
+23A6 16 00 .. LD D,00
+23A8 21 A4 26 !.& LD HL,26A4 ; Zwischenspeicheraddresse
+23AB CD 00 4E ..N CALL 4E00 ; String uebertragen
+23AE 41 A LD B,C ; Laengebyte
+23AF 21 A4 26 !.& LD HL,26A4 ; Startaddresse des Strings
+23B2 CD 61 23 .a# CALL 2361 ; String ausgeben
+23B5 D1 . POP DE
+23B6 18 E7 .. JR 239F ; Return
+23B8 E5 . PUSH HL
+23B9 C5 . PUSH BC
+23BA 21 AA 26 !.& LD HL,26AA
+23BD 77 w LD (HL),A
+23BE 01 01 00 ... LD BC,0001
+23C1 3A AC 26 :.& LD A,(26AC)
+23C4 CD 7B 28 .{( CALL 287B
+23C7 78 x LD A,B
+23C8 B1 . OR C
+23C9 28 F3 (. JR Z,23BE
+23CB C1 . POP BC
+23CC E1 . POP HL
+23CD C9 . RET
+23CE E1 . POP HL
+23CF B7 . OR A
+23D0 ED 42 .B SBC HL,BC
+23D2 E3 . EX (SP),HL
+23D3 C1 . POP BC
+23D4 B7 . OR A
+23D5 ED 42 .B SBC HL,BC
+23D7 44 D LD B,H
+23D8 4D M LD C,L
+23D9 E1 . POP HL
+23DA D1 . POP DE
+23DB DD E1 .. POP IX
+23DD F1 . POP AF
+23DE B7 . OR A
+23DF C9 . RET
+23E0 C1 . POP BC
+23E1 E1 . POP HL
+23E2 2B + DEC HL
+23E3 C1 . POP BC
+23E4 18 EC .. JR 23D2
+23E6 E1 . POP HL
+23E7 E1 . POP HL
+23E8 C1 . POP BC
+23E9 18 E7 .. JR 23D2 ;----- Zeiger auf Kanaltabelle
+23EB D5 . PUSH DE
+23EC C5 . PUSH BC
+23ED 21 B1 26 !.& LD HL,26B1
+23F0 47 G LD B,A
+23F1 11 18 00 ... LD DE,0018 ; 24 Bytes lang ein entry
+23F4 19 . ADD HL,DE
+23F5 10 FD .. DJNZ 23F4
+23F7 C1 . POP BC
+23F8 D1 . POP DE
+23F9 C9 . RET
+23FA CD EB 23 ..# CALL 23EB
+23FD 22 AD 26 ".& LD (26AD),HL
+2400 C9 . RET ;--------- Typtabellennummeraddr->HL
+2401 FE 7E .~ CP 7E ; psi
+2403 C8 . RET Z
+2404 FE 05 .. CP 05 ; Tabellennummer >= 5 ?
+2406 38 0E 8. JR C,2416
+2408 CD 1F 70 ..p CALL 701F ; Info aufrufen
+240B 18 09 .. JR 2416 ; " lst ovfl"
+240D 20 6C l JR NZ,247B
+240F 73 s LD (HL),E
+2410 74 t LD (HL),H
+2411 20 6F o JR NZ,2482
+2413 76 v HALT
+2414 66 f LD H,(HL)
+2415 6C l LD L,H
+2416 21 B3 26 !.& LD HL,26B3
+2419 85 . ADD L
+241A 6F o LD L,A
+241B 30 01 0. JR NC,241E
+241D 24 $ INC H
+241E C9 . RET ;------ Addresse der Typtabelle --
+241F CD 01 24 ..$ CALL 2401
+2422 66 f LD H,(HL)
+2423 2E 00 .. LD L,00
+2425 C9 . RET ;--Typt.Block reservieren -------
+2426 E5 . PUSH HL
+2427 D5 . PUSH DE
+2428 CD 42 5E .B^ CALL 5E42 ; Block freimachen
+242B 7D } LD A,L
+242C 87 . ADD A ; * 2
+242D D1 . POP DE
+242E E1 . POP HL
+242F 77 w LD (HL),A ; Pufferaddresse (Block)eintragen
+2430 C9 . RET
+2431 F1 . POP AF
+2432 01 FF FF ... LD BC,FFFF ; Returncode -1
+2435 C9 . RET ; ---- 173/175 Shard-IOCONTROL -----
+2436 F5 . PUSH AF
+2437 3A 6B 28 :k( LD A,(286B) ; Shardversion
+243A FE 06 .. CP 06 ; 173 Shard
+243C 38 F3 8. JR C,2431 ; < 6 : control geht nicht
+243E FE 08 .. CP 08
+2440 30 0A 0. JR NC,244C ; >= 8 : keine Registerverlagerung
+2442 F1 . POP AF ; 173: Register umdrehen
+2443 61 a LD H,C ; H = Schlssel (>=8: HL=Schlssel)
+2444 42 B LD B,D ; BC = Funktionsnummer
+2445 4B K LD C,E ; L war schon addressierter Kanal
+2446 11 00 00 ... LD DE,0000 ; DE = Funktionscode 1 (nicht in <8)
+2449 C3 A8 28 ..( JP 28A8 ; IOCONTROL an Shard geben
+244C F1 . POP AF ; --- 175 Shard-IOCONTROL ----------
+244D C5 . PUSH BC
+244E 42 B LD B,D ; Funktionsnummer nach BC
+244F 4B K LD C,E
+2450 54 T LD D,H ; Code 1 nach DE
+2451 5D ] LD E,L
+2452 E1 . POP HL ; Code 2 nach HL
+2453 C3 A8 28 ..( JP 28A8 ; ---- CONTROL (DE,HL,BC,res BC) ----
+2456 CB 7A .z BIT 7,D
+2458 20 F3 . JR NZ,244D
+245A F5 . PUSH AF
+245B 7B { LD A,E ; Control 6: flow (kanal.
+245C FE 06 .. CP 06
+245E CA 24 25 .$% JP Z,2524
+2461 FE 08 .. CP 08 ; Control 8: baud (kanal,schlssl,res)
+2463 28 D2 (. JR Z,2437
+2465 FE 09 .. CP 09 ; Control 9: bits (kanal,schlssl,res)
+2467 28 CE (. JR Z,2437
+2469 FE 0A .. CP 0A ; Control 10: calendar (field,0,bcd)
+246B 28 1B (. JR Z,2488
+246D FE 0C .. CP 0C ; Control 12: xmiterror (0,0,err)
+246F 20 1E . JR NZ,248F ;--------- IOCONTROL 12 ----------
+2471 0E 3F .? LD C,3F
+2473 3A 6B 28 :k( LD A,(286B)
+2476 FE 08 .. CP 08 ; Shard Version >= 8 ?
+2478 30 02 0. JR NC,247C
+247A 0E 20 . LD C,20 ; Nur Puffer uebergelaufen
+247C F1 . POP AF
+247D CD EB 23 ..# CALL 23EB ; Zeiger auf Kanaltabelle
+2480 23 # INC HL
+2481 7E ~ LD A,(HL)
+2482 A1 . AND C
+2483 4F O LD C,A
+2484 06 00 .. LD B,00
+2486 70 p LD (HL),B
+2487 C9 . RET ; ----- IOCONTROL calendar ---------
+2488 3A 6B 28 :k( LD A,(286B)
+248B FE 08 .. CP 08 ; Shard Vers >= 8 ?
+248D 38 A2 8. JR C,2431 ; nein, Return -1
+248F F1 . POP AF ; ------
+2490 FE 20 . CP 20 ; Parameterkanal ?
+2492 28 0E (. JR Z,24A2
+2494 F5 . PUSH AF ; Kein Parameterkanal
+2495 7B { LD A,E
+2496 FE 05 .. CP 05 ; Funktion 5: size
+2498 28 04 (. JR Z,249E
+249A FE 07 .. CP 07 ; Funktion 7: format
+249C 20 AE . JR NZ,244C
+249E F1 . POP AF
+249F C3 2A 64 .*d JP 642A ; bergeben an PROZ ARCH
+24A2 7B { LD A,E ; Am Parameterkanal
+24A3 FE 01 .. CP 01 ; Funktion 1: typtab(kanal,typnr,res)
+24A5 28 65 (e JR Z,250C
+24A7 FE 02 .. CP 02 ; Funktion 2: inbuffsize(kanal,size,res)
+24A9 28 06 (. JR Z,24B1
+24AB FE 0B .. CP 0B ; Funktion 11: ysize(kanal,ysize,res)
+24AD CA 3C 25 .<% JP Z,253C
+24B0 C9 . RET ;--- CONTROL inputbuffersize ------
+24B1 7D } LD A,L ; Funktion 2 :
+24B2 FE 11 .. CP 11
+24B4 D0 . RET NC ; Kanal < 17 ?
+24B5 CD EB 23 ..# CALL 23EB ; Zeiger auf Kanaltabelle berechnen
+24B8 78 x LD A,B ; > 255 ?
+24B9 FE 01 .. CP 01
+24BB 30 22 0" JR NC,24DF
+24BD CB 6E .n BIT 5,(HL) ; inputbuffersize < 256
+24BF C8 . RET Z ; schon eingestellt
+24C0 DD E5 .. PUSH IX
+24C2 E5 . PUSH HL
+24C3 DD E1 .. POP IX
+24C5 DD 66 07 .f. LD H,(IX+07) ; 7 = Blockaddresse
+24C8 DD 6E 0C .n. LD L,(IX+0C)
+24CB CD 0B 5E ..^ CALL 5E0B ; Alten Pufferblock freigeben
+24CE F3 . DI
+24CF DD 36 00 00 .6.. LD (IX+00),00 ; Jetzt kleiner Puffer ohne Flussk.
+24D3 DD 36 04 07 .6.. LD (IX+04),07 ; Zeiger auf Pufferanfang
+24D7 FB . EI
+24D8 DD 36 05 07 .6.. LD (IX+05),07
+24DC DD E1 .. POP IX
+24DE C9 . RET ;---- Grosser Puffer --------------
+24DF CB 6E .n BIT 5,(HL)
+24E1 C0 . RET NZ ; war schon > 255 eingestellt
+24E2 DD E5 .. PUSH IX
+24E4 E5 . PUSH HL
+24E5 CD 18 5E ..^ CALL 5E18 ; Block freimachen fuer Puffer
+24E8 DD E1 .. POP IX
+24EA F3 . DI
+24EB DD CB 00 EE .... SET 5,(IX+00) ; Grosser Puffer
+24EF DD 74 07 .t. LD (IX+07),H ; Pufferaddresse setzen
+24F2 DD 75 0C .u. LD (IX+0C),L
+24F5 97 . SUB A ; Puffer leeren
+24F6 DD 77 04 .w. LD (IX+04),A ; Lese- und Schreibzeiger jetzt 16Bit
+24F9 DD 77 08 .w. LD (IX+08),A ; Auf Blockanfang
+24FC DD 77 05 .w. LD (IX+05),A
+24FF DD 77 0B .w. LD (IX+0B),A
+2502 DD 77 09 .w. LD (IX+09),A
+2505 DD 77 0A .w. LD (IX+0A),A
+2508 FB . EI
+2509 DD E1 .. POP IX
+250B C9 . RET ;------ CONTROL typtabelle -------
+250C 79 y LD A,C ; Typtabelle einstellen
+250D FE FE .. CP FE ; >= 254: psi o. transparent
+250F 30 05 0. JR NC,2516 ;
+2511 FE 05 .. CP 05
+2513 D2 3F 26 .?& JP NC,263F ; >= 5: falsche Nummer
+2516 7D } LD A,L
+2517 FE 11 .. CP 11
+2519 D2 5A 26 .Z& JP NC,265A
+251C CD 95 26 ..& CALL 2695 ; Kanaltyptabellenaddresse holen
+251F 71 q LD (HL),C ; Nummer eintragen
+2520 01 00 00 ... LD BC,0000 ; ok
+2523 C9 . RET ;------ IOCONTROL flow ----------
+2524 F1 . POP AF ; Eigener Kanal
+2525 C5 . PUSH BC
+2526 E5 . PUSH HL
+2527 CD 36 24 .6$ CALL 2436 ; Shard IOCONTROL flow
+252A E1 . POP HL
+252B D1 . POP DE
+252C 7D } LD A,L ; Addressierter Kanal
+252D FE 11 .. CP 11 ; > 16: fertig
+252F D0 . RET NC
+2530 CD 95 26 ..& CALL 2695 ; Tytabellennummer holen --> A
+2533 CB BE .. RES 7,(HL) ; Erstmal keine Flukontrolle setzen
+2535 7B { LD A,E
+2536 B7 . OR A
+2537 28 02 (. JR Z,253B ; Wenn Flukontrolle, dann in Typ-
+2539 CB FE .. SET 7,(HL) ; tabellennummer vermerken
+253B C9 . RET ;------- IOCONTROL ysize -----------
+253C 7D } LD A,L ; Addressierter Kanal
+253D FE 11 .. CP 11 ; > 16: fertig
+253F D0 . RET NC
+2540 CD EB 23 ..# CALL 23EB ; Addresse der Kanaltabelle holen
+2543 DD E5 .. PUSH IX
+2545 E5 . PUSH HL
+2546 DD E1 .. POP IX
+2548 0D . DEC C ; ysize-1 (=ymax f. y=0..ymax)
+2549 DD 46 06 .F. LD B,(IX+06) ; Return = alte ysize
+254C 04 . INC B ; ymax + 1 = ysize
+254D DD 71 06 .q. LD (IX+06),C
+2550 DD E1 .. POP IX
+2552 48 H LD C,B ; Nur Werte 0..255
+2553 06 00 .. LD B,00
+2555 C9 . RET ;----------------------------------
+2556 CB 7C .| BIT 7,H
+2558 C2 DE 63 ..c JP NZ,63DE
+255B 32 AC 26 2.& LD (26AC),A
+255E 7C | LD A,H
+255F B5 . OR L
+2560 20 06 . JR NZ,2568
+2562 3A AC 26 :.& LD A,(26AC)
+2565 C3 DE 63 ..c JP 63DE
+2568 7C | LD A,H
+2569 E6 FE .. AND FE
+256B FE 02 .. CP 02
+256D 28 08 (. JR Z,2577
+256F C3 5E 26 .^& JP 265E
+2572 01 01 02 ... LD BC,0201
+2575 E1 . POP HL
+2576 C9 . RET
+2577 78 x LD A,B
+2578 B1 . OR C
+2579 C8 . RET Z
+257A 25 % DEC H
+257B 25 % DEC H
+257C E5 . PUSH HL
+257D 09 . ADD HL,BC
+257E 7C | LD A,H
+257F D6 02 .. SUB A,02
+2581 38 05 8. JR C,2588
+2583 20 ED . JR NZ,2572
+2585 B5 . OR L
+2586 20 EA . JR NZ,2572
+2588 3A AC 26 :.& LD A,(26AC)
+258B CD FA 23 ..# CALL 23FA
+258E E1 . POP HL
+258F 19 . ADD HL,DE
+2590 DD E5 .. PUSH IX
+2592 DD 2A AD 26 .*.& LD IX,(26AD)
+2596 DD CB 00 6E ...n BIT 5,(IX+00)
+259A 28 5E (^ JR Z,25FA
+259C C5 . PUSH BC
+259D E5 . PUSH HL
+259E DD 66 0B .f. LD H,(IX+0B)
+25A1 DD 6E 04 .n. LD L,(IX+04)
+25A4 B7 . OR A
+25A5 ED 42 .B SBC HL,BC
+25A7 DA 13 26 ..& JP C,2613
+25AA DD 66 07 .f. LD H,(IX+07)
+25AD DD 6E 0C .n. LD L,(IX+0C)
+25B0 CD 81 5A ..Z CALL 5A81
+25B3 ED 43 AF 26 .C.& LD (26AF),BC
+25B7 DD 6E 05 .n. LD L,(IX+05)
+25BA DD 7E 0A .~. LD A,(IX+0A)
+25BD E6 01 .. AND 01
+25BF 84 . ADD H
+25C0 67 g LD H,A
+25C1 D1 . POP DE
+25C2 C1 . POP BC
+25C3 C5 . PUSH BC
+25C4 23 # INC HL
+25C5 7D } LD A,L
+25C6 B7 . OR A
+25C7 20 06 . JR NZ,25CF
+25C9 CB 44 .D BIT 0,H
+25CB 20 02 . JR NZ,25CF
+25CD 25 % DEC H
+25CE 25 % DEC H
+25CF ED A0 .. LDI
+25D1 EA C5 25 ..% JP PE,25C5
+25D4 2B + DEC HL
+25D5 DD 75 05 .u. LD (IX+05),L
+25D8 DD 74 0A .t. LD (IX+0A),H
+25DB ED 4B AF 26 .K.& LD BC,(26AF)
+25DF CD 8C 5A ..Z CALL 5A8C
+25E2 C1 . POP BC
+25E3 F3 . DI
+25E4 DD 66 0B .f. LD H,(IX+0B)
+25E7 DD 6E 04 .n. LD L,(IX+04)
+25EA B7 . OR A
+25EB ED 42 .B SBC HL,BC
+25ED DD 74 0B .t. LD (IX+0B),H
+25F0 DD 75 04 .u. LD (IX+04),L
+25F3 FB . EI
+25F4 01 00 00 ... LD BC,0000
+25F7 DD E1 .. POP IX
+25F9 C9 . RET ;----------------------------------
+25FA 3A AC 26 :.& LD A,(26AC)
+25FD CD AD 1E ... CALL 1EAD
+2600 DC 1A 26 ..& CALL C,261A
+2603 DD E1 .. POP IX
+2605 3A AC 26 :.& LD A,(26AC)
+2608 CD 06 1F ... CALL 1F06
+260B D8 . RET C
+260C 77 w LD (HL),A
+260D ED A1 .. CPI
+260F EA 05 26 ..& JP PE,2605
+2612 C9 . RET
+2613 CD 1A 26 ..& CALL 261A
+2616 E1 . POP HL
+2617 C1 . POP BC
+2618 18 E9 .. JR 2603
+261A 2A AD 26 *.& LD HL,(26AD)
+261D 7E ~ LD A,(HL)
+261E EE 40 .@ XOR 40
+2620 77 w LD (HL),A
+2621 CB 77 .w BIT 6,A
+2623 C8 . RET Z
+2624 21 00 00 !.. LD HL,0000
+2627 C3 1A 6C ..l JP 6C1A
+262A CB 7C .| BIT 7,H
+262C C2 25 64 .%d JP NZ,6425
+262F 32 AC 26 2.& LD (26AC),A
+2632 F5 . PUSH AF
+2633 7C | LD A,H
+2634 B5 . OR L
+2635 20 2B + JR NZ,2662
+2637 F1 . POP AF
+2638 FE 20 . CP 20
+263A C2 25 64 .%d JP NZ,6425
+263D 18 04 .. JR 2643
+263F 01 02 00 ... LD BC,0002 ; Nummer der Typtabelle falsch
+2642 C9 . RET
+2643 79 y LD A,C
+2644 FE 05 .. CP 05
+2646 30 F7 0. JR NC,263F
+2648 CD 01 24 ..$ CALL 2401
+264B 7E ~ LD A,(HL)
+264C B7 . OR A
+264D CC 26 24 .&$ CALL Z,2426
+2650 67 g LD H,A
+2651 2E 00 .. LD L,00
+2653 EB . EX DE,HL
+2654 01 00 02 ... LD BC,0200 ; Typtabelle in Bereich uebertragen
+2657 ED B0 .. LDIR
+2659 C9 . RET
+265A 01 03 00 ... LD BC,0003
+265D C9 . RET
+265E 01 01 00 ... LD BC,0001
+2661 C9 . RET
+2662 F1 . POP AF
+2663 7C | LD A,H
+2664 E6 FE .. AND FE
+2666 FE 02 .. CP 02
+2668 28 02 (. JR Z,266C
+266A 18 F2 .. JR 265E
+266C 78 x LD A,B
+266D B1 . OR C
+266E C8 . RET Z
+266F C5 . PUSH BC
+2670 E5 . PUSH HL
+2671 01 02 00 ... LD BC,0002
+2674 3A AC 26 :.& LD A,(26AC)
+2677 CD A8 28 ..( CALL 28A8 ; IOCONTROL frout
+267A 21 1C 00 !.. LD HL,001C ; 28 Zeichen
+267D ED 42 .B SBC HL,BC ; Anzahl uebernommener Zeichen
+267F D4 1A 26 ..& CALL NC,261A
+2682 E1 . POP HL
+2683 C1 . POP BC
+2684 25 % DEC H
+2685 25 % DEC H
+2686 19 . ADD HL,DE
+2687 C5 . PUSH BC
+2688 3A AC 26 :.& LD A,(26AC)
+268B CD 88 21 ..! CALL 2188
+268E E1 . POP HL
+268F B7 . OR A
+2690 ED 42 .B SBC HL,BC
+2692 44 D LD B,H
+2693 4D M LD C,L
+2694 C9 . RET
+2695 21 B8 26 !.& LD HL,26B8
+2698 C5 . PUSH BC
+2699 4F O LD C,A
+269A 06 00 .. LD B,00
+269C 09 . ADD HL,BC
+269D C1 . POP BC
+269E 7E ~ LD A,(HL)
+269F CB BF .. RES 7,A
+26A1 FE 7F .. CP 7F
+26A3 C9 . RET
+26A4 FF . RST 38
+26A5 FF . RST 38
+26A6 FF . RST 38
+26A7 FF . RST 38
+26A8 FF . RST 38
+26A9 00 . NOP
+26AA 00 . NOP
+26AB 00 . NOP
+26AC 00 . NOP
+26AD 00 . NOP
+26AE 00 . NOP
+26AF 00 . NOP
+26B0 00 . NOP
+26B1 00 . NOP
+26B2 00 . NOP
+26B3 00 . NOP
+26B4 00 . NOP
+26B5 00 . NOP
+26B6 00 . NOP
+26B7 00 . NOP
+26B8 00 . NOP ; typtabellen nummern & Flusskontr.
+26B9 7E ~ LD A,(HL) ; Kanal 1 : psi ohne flow
+26BA FF . RST 38 ; kanal 2 : transparent mit flow
+26BB FF . RST 38 ; (Bit 7 = 1: Mit Flukontrolle)
+26BC FF . RST 38
+26BD FF . RST 38
+26BE FF . RST 38
+26BF FF . RST 38
+26C0 FF . RST 38
+26C1 FF . RST 38
+26C2 FF . RST 38
+26C3 FF . RST 38
+26C4 FF . RST 38
+26C5 FF . RST 38
+26C6 FF . RST 38
+26C7 FF . RST 38
+26C8 FF . RST 38 ; kanal 16
+ ; kanaltabelle fuer kanal 1
+26C9 00 . NOP 0 ; Bit 0 :
+ ; Bit 3 : 1=Stoptaste gedrueckt
+ ; Bit 5 : 1=Grosser Puffer (>255Byte)
+26CA 00 . NOP 1 ; Bits 0..5 : Errorbits
+26CB FF . RST 38 2 ; Cursorpos y
+26CC FF . RST 38 3 ; Cursorpos x
+26CD 07 . RLCA 4 ; Pufferzeiger schreiben
+26CE 07 . RLCA 5 ; Pufferzeiger lesen
+26CF 17 . RLA 6 ; ysize = 23
+26D0 FF . RST 38 7 ; Ab hier Eingabezeichen ...
+26D1 FF . RST 38 8 ;
+26D2 FF . RST 38 9 ;
+26D3 FF . RST 38 10 ;
+26D4 FF . RST 38 11 ;
+26D5 FF . RST 38 12 ;
+26D6 FF . RST 38
+26D7 FF . RST 38
+26D8 FF . RST 38
+26D9 FF . RST 38
+26DA FF . RST 38
+26DB FF . RST 38
+26DC FF . RST 38 ; I.d.R bis hier
+26DD FF . RST 38
+26DE FF . RST 38
+26DF FF . RST 38
+26E0 FF . RST 38
+26E1 00 . NOP ; kanal 2
+26E2 00 . NOP
+26E3 FF . RST 38
+26E4 FF . RST 38
+26E5 07 . RLCA
+26E6 07 . RLCA
+26E7 17 . RLA
+26E8 FF . RST 38
+26E9 FF . RST 38
+26EA FF . RST 38
+26EB FF . RST 38
+26EC FF . RST 38
+26ED FF . RST 38
+26EE FF . RST 38
+26EF FF . RST 38
+26F0 FF . RST 38
+26F1 FF . RST 38
+26F2 FF . RST 38
+26F3 FF . RST 38
+26F4 FF . RST 38
+26F5 FF . RST 38
+26F6 FF . RST 38
+26F7 FF . RST 38
+26F8 FF . RST 38
+26F9 00 . NOP ; kanal 3
+26FA 00 . NOP
+26FB FF . RST 38
+26FC FF . RST 38
+26FD 07 . RLCA
+26FE 07 . RLCA
+26FF 17 . RLA
+2700 FF . RST 38
+2701 FF . RST 38
+2702 FF . RST 38
+2703 FF . RST 38
+2704 FF . RST 38
+2705 FF . RST 38
+2706 FF . RST 38
+2707 FF . RST 38
+2708 FF . RST 38
+2709 FF . RST 38
+270A FF . RST 38
+270B FF . RST 38
+270C FF . RST 38
+270D FF . RST 38
+270E FF . RST 38
+270F FF . RST 38
+2710 FF . RST 38
+2711 00 . NOP ; kanal 4
+2712 00 . NOP
+2713 FF . RST 38
+2714 FF . RST 38
+2715 07 . RLCA
+2716 07 . RLCA
+2717 17 . RLA
+2718 FF . RST 38
+2719 FF . RST 38
+271A FF . RST 38
+271B FF . RST 38
+271C FF . RST 38
+271D FF . RST 38
+271E FF . RST 38
+271F FF . RST 38
+2720 FF . RST 38
+2721 FF . RST 38
+2722 FF . RST 38
+2723 FF . RST 38
+2724 FF . RST 38
+2725 FF . RST 38
+2726 FF . RST 38
+2727 FF . RST 38
+2728 FF . RST 38
+2729 00 . NOP ; kanal 5
+272A 00 . NOP
+272B FF . RST 38
+272C FF . RST 38
+272D 07 . RLCA
+272E 07 . RLCA
+272F 17 . RLA
+2730 FF . RST 38
+2731 FF . RST 38
+2732 FF . RST 38
+2733 FF . RST 38
+2734 FF . RST 38
+2735 FF . RST 38
+2736 FF . RST 38
+2737 FF . RST 38
+2738 FF . RST 38
+2739 FF . RST 38
+273A FF . RST 38
+273B FF . RST 38
+273C FF . RST 38
+273D FF . RST 38
+273E FF . RST 38
+273F FF . RST 38
+2740 FF . RST 38
+2741 00 . NOP ; kanal 6
+2742 00 . NOP
+2743 FF . RST 38
+2744 FF . RST 38
+2745 07 . RLCA
+2746 07 . RLCA
+2747 17 . RLA
+2748 FF . RST 38
+2749 FF . RST 38
+274A FF . RST 38
+274B FF . RST 38
+274C FF . RST 38
+274D FF . RST 38
+274E FF . RST 38
+274F FF . RST 38
+2750 FF . RST 38
+2751 FF . RST 38
+2752 FF . RST 38
+2753 FF . RST 38
+2754 FF . RST 38
+2755 FF . RST 38
+2756 FF . RST 38
+2757 FF . RST 38
+2758 FF . RST 38