summaryrefslogtreecommitdiff
path: root/app/diskettenmonitor
diff options
context:
space:
mode:
Diffstat (limited to 'app/diskettenmonitor')
-rw-r--r--app/diskettenmonitor/3.5/source-disk1
-rw-r--r--app/diskettenmonitor/3.5/src/basic menu handling 3.5.quelle53
-rw-r--r--app/diskettenmonitor/3.5/src/disk 3.5-m.quelle2192
-rw-r--r--app/diskettenmonitor/3.5/src/disk cmd 3.5.quelle36
-rw-r--r--app/diskettenmonitor/3.5/src/m.rename archive^2.c3
-rw-r--r--app/diskettenmonitor/3.5/src/read heap107
-rw-r--r--app/diskettenmonitor/3.7/source-disk1
-rw-r--r--app/diskettenmonitor/3.7/src/PAC digit conversion93
-rw-r--r--app/diskettenmonitor/3.7/src/basic menu handling 3.6.quelle53
-rw-r--r--app/diskettenmonitor/3.7/src/disk 3.7-m.quelle2218
-rw-r--r--app/diskettenmonitor/3.7/src/disk cmd 3.6.quelle48
11 files changed, 4805 insertions, 0 deletions
diff --git a/app/diskettenmonitor/3.5/source-disk b/app/diskettenmonitor/3.5/source-disk
new file mode 100644
index 0000000..10203de
--- /dev/null
+++ b/app/diskettenmonitor/3.5/source-disk
@@ -0,0 +1 @@
+debug/diskettenmonitor-3.5_1986-11-16.img
diff --git a/app/diskettenmonitor/3.5/src/basic menu handling 3.5.quelle b/app/diskettenmonitor/3.5/src/basic menu handling 3.5.quelle
new file mode 100644
index 0000000..f60101d
--- /dev/null
+++ b/app/diskettenmonitor/3.5/src/basic menu handling 3.5.quelle
@@ -0,0 +1,53 @@
+
+PACKET basic menu handling
+
+(************************************************************************)
+(* *)
+(* Basic Menu Handling Version 1.0 *)
+(* *)
+(* *)
+(* Autor : Ingo Siekmann *)
+(* Stand : Donnerstag, den 12. Juni 1986 *)
+(* *)
+(* Lauffähig ab EUMEL Version 1.7.3 *)
+(* *)
+(* (c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert *)
+(* *)
+(************************************************************************)
+
+ DEFINES menue monitor :
+
+
+
+LET info line x pos = 1 ,
+ info line y pos = 20 ,
+ command line x pos = 1 ,
+ command line y pos = 21 ;
+
+LET first mon line = "----------------------------------------------------------------------------" ,
+ command line = ">__________________________________________________________________________<" ;
+
+
+TEXT VAR char ;
+
+PROCEDURE menue monitor (TEXT CONST info line, chars, (* I. Siekmann *)
+ INT VAR command index) : (* 12.06.1986 *)
+ enable stop ;
+ cursor (1, 17) ;
+ command index := 0 ;
+ out (first mon line) ;
+ cursor (info line x pos, info line y pos) ;
+ out (info line) ;
+ cursor (command line x pos, command line y pos) ;
+ out (command line) ;
+ cursor (command line x pos + 1, command line y pos) ;
+ REPEAT
+ (* inchar (char) ; *)
+ get char (char) ;
+ command index := pos (chars, char)
+ UNTIL command index > 0 COR is error END REPEAT ;
+ out (char) .
+END PROCEDURE menue monitor ;
+
+ENDPACKET basic menu handling ;
+
diff --git a/app/diskettenmonitor/3.5/src/disk 3.5-m.quelle b/app/diskettenmonitor/3.5/src/disk 3.5-m.quelle
new file mode 100644
index 0000000..d081c8e
--- /dev/null
+++ b/app/diskettenmonitor/3.5/src/disk 3.5-m.quelle
@@ -0,0 +1,2192 @@
+(************************************************************************)
+(* *)
+(* DDDD IIIII SSSS K K 3333 55555 / M M *)
+(* D D I S K K 3 5 / MM MM *)
+(* D D I SSS KK 333 5555 / M M M M *)
+(* D D I S K K 3 5 / M M M *)
+(* DDDD IIIII SSSS K K 3333 O 5555 / M M *)
+(* *)
+(************************************************************************)
+(* *)
+(* Diskettenmonitor Version 3.5 Multi *)
+(* *)
+(* Autor : Ingo Siekmann unter freundlicher Mithilfe von Stefan Haase, *)
+(* Nils Ehnert, APu und Frank Lenniger *)
+(* *)
+(* Stand : Sonntag, den 16. November 1986 *)
+(* *)
+(* Lauffähig ab EUMEL Version 1.7.3 /M in Systemtasks *)
+(* *)
+(* *)
+(* (c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert *)
+(* *)
+(************************************************************************)
+(************************************************************************)
+(* *)
+(* Softwareaenderungen und Softwareneuerungen : *)
+(* *)
+(* 03.01.1986 3.3.2.8 : Block- Asciieditor ueberarbeitet, neuer Header- *)
+(* editor (V1.3), Helpfunktion, gib kommando, *)
+(* Fileaccess auch fuer 16-Files *)
+(* 15.01.1986 3.3.2.9 : Vorbereitung fuer den Suchmodus in 3.3.3.0, *)
+(* Notbremse ins globalmenue mit ctrl g, byte ops *)
+(* ueberarbeitet, pic dienste in vorbereitung *)
+(* Headereditor (V1.4) *)
+(* 16.01.1986 : halt from terminal --> ctrl g := true *)
+(* 16.01.1886 3.3.3.0 : Suchmodus ins Blockmenue (TEST), Blockeditor *)
+(* Byteposops fuer Suchmodus einbauen *)
+(* 21.01.1986 : inchar in get char umgewandelt *)
+(* 28.01.1986 : lernmodus eingebaut (???) *)
+(* 31.01.1986 3.3.3.1 : Suchmodus und Lernmodus wieder ausgebaut *)
+(* beim Datenraumschreiben nur belegte Bloecke raus*)
+(* 14.02.1986 3.3.3.2 : Fehler Überarbeitet *)
+(* 20.02.1986 : Suchmodus vorbereitet (2. Versuch ?) *)
+(* 06.03.1986 3.3.3.3 : Suchmodus eingebaut (Test) *)
+(* 10.03.1986 : Softwaretrennung zwischen Single und Multi *)
+(* 12.03.1986 : read next block cmd ins blockmenu eingebaut *)
+(* Fehler überarbeitet, Vorbereitung für besseren *)
+(* Suchmodus *)
+(* 17.03.1986 3.3.3.4 : configurator menü -> einstellen von disk type, *)
+(* i/o channel, disk info. TEXT/HEX search . *)
+(* 02.04.1986 : urflop ops mit versatzops *)
+(* 08.04.1986 : urflop menue mit versatz *)
+(* 30.04.1986 3.3.3.5 : Fehler ueberarbeitet *)
+(* 30.04.1986 3.3.3.6 : lab read/write ins space menue *)
+(* 05.05.1986 3.3.3.7 : hex / dez - get für alles, block editor über- *)
+(* arbeitet, fehler überarbeitet. auslieferung für *)
+(* HRZ ! *)
+(* 06.06.1986 3.4 : Fehler im search und menue monitor behoben *)
+(* 12.06.1986 : Fehler im Space/Header-Menue behoben *)
+(* 16.11.1986 3.5 : Fehler im Urflopmenue behoben *)
+(* *)
+(* A C H T U N G : Keine weitere Entwicklung von Version 3 !! *)
+(* *)
+(* Bielefeld, den 16.11.1986 ULES *)
+(* *)
+(* Ingo Siekmann *)
+(* *)
+(* *)
+(************************************************************************)
+
+PACKET byte operations and disk monitor version 35 multi
+
+ DEFINES BYTE ,
+ HEX ,
+ ASCII ,
+ DECRL ,
+ DECRH ,
+ INCRL ,
+ INCRH ,
+ := ,
+ - ,
+ + ,
+ $ ,
+ hint ,
+ zu byte ,
+ lower byte ,
+ higher byte ,
+ set lower byte ,
+ set higher byte ,
+ nil byte ,
+ put ,
+ get ,
+
+ block in ,
+ block out ,
+
+ HEADER ,
+ header ,
+ nil header ,
+ is start header ,
+ is end header ,
+ is file header ,
+ name ,
+ date ,
+ type ,
+ pass ,
+ header edit ,
+
+ show first ,
+ show second ,
+ block edit ,
+ ascii edit ,
+
+ set ctrl g ,
+ reset ctrl g ,
+
+ set channel ,
+ read block ,
+ write block ,
+ seek space ,
+ seek block ,
+ read space ,
+ write space ,
+ check archive error ,
+
+ space nr ,
+ header nr ,
+
+ urlader lesen ,
+ urlader schreiben ,
+ urlader lesen auf seite ,
+ urlader schreiben von seite ,
+
+ search ,
+
+ io control ,
+
+ central disk monitor process :
+
+
+
+LET start of volume = 1000 ,
+ end of volume = 1 ,
+ file header = 3 ;
+
+LET global info line = "** GLOBAL : b / s / a / c / u / k / q # stop --> ctrl g, help --> ""?"" **" ,
+ block info line = "** BLOCK : r / w / e / k / s / n / q # stop --> ctrl g, help --> ""?"" **" ,
+ search info line = "** SEARCH : a -> ascii / h -> hex / q -> quit / ctrl g -> stop **" ,
+ editor info line = "** EDITOR : f / s / d / e / k / p / q # stop --> ctrl g, help --> ""?"" **" ,
+ space info line = "** SPACE : r, R, w, W, e, E, s, l, k, q # stop --> ctrl g, help --> ""?"" **" ,
+ space header info = "** SPACE / HEADER : s -> read space / h -> read header / q -> quit **" ,
+ archiv info line = "** ARCHIV : a / r / l / f / s / k / q # stop --> ctrl g, help --> ""?"" **" ,
+ urflop info line = "** URFLOP : r / R / w / W / l / k / q # stop --> ctrl g, help --> ""?"" **" ,
+ conf info line = "** CONFIGURATOR : c / t / i / k / q # stop --> ctrl g, help --> ""?"" **" ,
+ first mon line = "----------------------------------------------------------------------------" ,
+ command line = ">__________________________________________________________________________<" ;
+
+LET global chars = "bsacuqk?"7"" ,
+ block chars = "rweqksn?"7"" ,
+ search chars = "ahdq"7"" ,
+ editor chars = "fsdeqk?"7"p" ,
+ space chars = "rRwWesqEkl?"7"" ,
+ archiv chars = "arlfsqk?"7"" ,
+ urflop chars = "rRwWlqk?"7"" ,
+ conf chars = "ctikq?"7"" ;
+
+LET info line x pos = 1 ,
+ info line y pos = 20 ,
+ info line x pos 2 = 1 ,
+ info line y pos 2 = 24 ,
+ command line x pos = 1 ,
+ command line y pos = 21 ,
+ error line x pos = 1 ,
+ error line y pos = 22 ,
+
+ file type = 1003 ,
+ file type 16 = 1002 ,
+
+ block 0 = 0 ,
+
+ std archive channel = 31 ,
+
+ type mode = 1 ,
+ size mode = 5 ,
+ std disk type = 0 ;
+
+LET software stand = "Sonntag, den 16.11.1986" ,
+ software version = "Version 3.5 /Multi" ,
+ software bemerkung = "*** Ende der Entwicklung der Version 3 ! ***" ,
+ software bemerkung1 = "" ;
+
+LET eumel 0 start block = 10 ,
+ eumel 0 end block = 65 ,
+ eumel 0 end block pic = 62 ,
+ eumel 0 end block 1758 = 67 ,
+ pic char table start block = 63 ,
+ pic char table end block = 65 ,
+ pic shard start block = 0 ,
+ pic shard end block = 79 ,
+
+ read write impossible error = 101 ,
+ read error = 102 ,
+ write error = 103 ,
+ block number error = 104 ,
+ undef archive error = 105 ;
+
+LET ibm 720 format 5 = 1440 ,
+ ibm 360 format 5 = 720 ,
+ pic 400 format 5 = 1600 ,
+ soft sd 8 = 1232 ,
+ soft dd 8 = 2464 ,
+ hard ss sd = 616 ,
+ hard ds sd = 1232 ;
+
+LET home = ""1"" ,
+ left = ""8"" ,
+ right = ""2"" ,
+ up = ""3"" ,
+ down = ""10"" ,
+ return = ""13"" ,
+ tab = ""9"" ,
+ esc = ""27"" ,
+ cl eol = ""5"" ,
+ cl eop = ""4"" ;
+
+LET hex chars = "0123456789ABCDEF" ,
+ hex marker = "h" ;
+
+LET start pos = 479 ,
+ heap page nr = 2 ;
+
+
+TYPE HEADER = STRUCT (TEXT name, date, INT type, TEXT pass) ;
+
+TYPE BYTE = STRUCT (INT lower byte , higher byte) ;
+
+
+HEADER CONST nil header := HEADER : ("", "", 0, "") ;
+BOUND HEADER VAR bound header ;
+BOUND TEXT VAR bound text ;
+
+INITFLAG VAR this packet := false ;
+
+ROW 256 BYTE VAR block ;
+ROW 32 TEXT VAR text block ;
+ROW 256 INT VAR block int ;
+
+DATASPACE VAR ds :: nilspace ; forget (ds) ;
+DATASPACE VAR afds :: nilspace ; forget (afds) ;
+DATASPACE VAR lds :: nilspace ; forget (lds) ;
+DATASPACE VAR uds :: nilspace ; forget (uds) ;
+DATASPACE VAR blkinds :: nilspace ; forget (blkinds) ;
+
+FILE VAR af, f, lf ;
+
+INT VAR command index, block nummer, space nummer, x, y, i, i1, xx, yy,
+ archive channel := std archive channel, user channel, error answer,
+ header nummer, first sp block, integer, archiv size, error, block nr,
+ stpos, s, e, fb, fp, cx, cy, disk type := std disk type, ver ;
+
+TEXT VAR c, hex line :: "", tc, char, t, archive name, dummy,
+ stb1, stb2, own command line ;
+
+REAL VAR po ;
+
+BOOL VAR first := true, ende, list file ok, block shown, ctrl g, result ;
+
+
+(********************** PACKET bytes ok : ****************************)
+
+
+BYTE PROC nil byte :
+ BYTE : (0,0)
+END PROC nil byte ;
+
+OP := (BYTE VAR byte , BYTE CONST old byte) :
+ byte.lower byte := old byte.lower byte ;
+ byte.higher byte := old byte.higher byte.
+END OP := ;
+
+OP := (BYTE VAR byte , INT CONST int byte) :
+ byte.lower byte := int byte MOD 256 ;
+ byte.higher byte := (int byte AND -256) DIV 256 AND 255 .
+END OP := ;
+
+OP := (ROW 256 BYTE VAR byte, ROW 256 INT CONST int byte) :
+ INT VAR i ;
+ FOR i FROM 1 UPTO 256 REPEAT
+ byte (i) := int byte (i)
+ END REPEAT .
+END OP := ;
+
+OP := (ROW 256 INT VAR int byte, ROW 256 BYTE CONST byte) :
+ INT VAR i ;
+ FOR i FROM 1 UPTO 256 REPEAT
+ int byte (i) := byte (i)
+ END REPEAT .
+END OP := ;
+
+BYTE OP + (BYTE VAR byte , INT CONST int byte) :
+ byte.lower byte := byte.lower byte + lower byte (int byte) ;
+ byte.higher byte := byte.higher byte + higher byte (int byte) ;
+ byte .
+END OP + ;
+
+BYTE OP - (BYTE VAR byte, INT CONST int byte) :
+ byte.lower byte := byte.lower byte - lower byte (int byte) ;
+ byte.higher byte := byte.higher byte - higher byte (int byte) ;
+ byte .
+END OP - ;
+
+OP := (INT VAR int byte, BYTE CONST byte) :
+ IF byte.higher byte > 127
+ THEN int byte := minus * 255 + minus + byte.lower byte
+ ELSE int byte := byte.higher byte * 256 + byte.lower byte
+ END IF
+
+.minus : byte.higher byte - 256 .
+END OP := ;
+
+OP INCRL (BYTE VAR byte, INT CONST lower) :
+ byte.lower byte INCR lower
+END OP INCRL ;
+
+OP INCRH (BYTE VAR byte, INT CONST high) :
+ byte.higher byte INCR high
+END OP INCRH ;
+
+OP DECRL (BYTE VAR byte, INT CONST lower) :
+ byte.higher byte DECR lower
+END OP DECRL ;
+
+OP DECRH (BYTE VAR byte, INT CONST high) :
+ byte.higher byte DECR high
+END OP DECRH ;
+
+INT PROC lower byte (BYTE CONST byte) :
+ byte.lower byte .
+END PROC lower byte ;
+
+INT PROC higher byte (BYTE CONST byte) :
+ byte.higher byte .
+END PROC higher byte ;
+
+INT PROC lower byte (INT CONST int byte) :
+ int byte MOD 256 .
+END PROC lower byte ;
+
+INT PROC higher byte (INT CONST int byte) :
+ (int byte AND -256) DIV 256 AND 255 .
+END PROC higher byte ;
+
+PROC set lower byte (BYTE VAR byte, INT CONST lower byte) :
+ byte.lower byte := lower byte
+END PROC set lower byte ;
+
+PROC set higher byte (BYTE VAR byte, INT CONST higher byte) :
+ byte.higher byte := higher byte
+END PROC set higher byte ;
+
+OP HEX (TEXT VAR insert line , BYTE CONST byte) :
+ insert line CAT (hex chars SUB (byte.lower byte DIV 16 + 1)) ;
+ insert line CAT (hex chars SUB (byte.lower byte MOD 16 + 1)) ;
+ insert line CAT " " ;
+ insert line CAT (hex chars SUB (byte.higher byte DIV 16 + 1)) ;
+ insert line CAT (hex chars SUB (byte.higher byte MOD 16 + 1)) ;
+ insert line CAT " " .
+END OP HEX ;
+
+OP ASCII (TEXT VAR insert line , BYTE CONST byte) :
+ insert line CAT ascii (byte.lower byte ) ;
+ insert line CAT ascii (byte.higher byte) .
+END OP ASCII ;
+
+TEXT PROC ascii (INT CONST half byte) :
+ IF half byte > 31 AND half byte < 127 COR
+ half byte > 213 AND half byte < 219 COR
+ half byte = 251
+ THEN code (half byte)
+ ELSE "."
+ END IF .
+END PROC ascii ;
+
+PROC block in (ROW 256 BYTE VAR block bytes, INT CONST type , block nr) :
+ ROW 256 INT VAR block ;
+ reset block io ;
+ block in (block, type, block nr, error answer) ;
+ block bytes := block ;
+ check archive error (error answer, true) .
+END PROC block in ;
+
+PROC block out (ROW 256 BYTE CONST bytes , INT CONST disk type, block nr) :
+ ROW 256 INT VAR int bytes := bytes ;
+ reset block io ;
+ block out (int bytes, disk type, block nr, error answer) ;
+ check archive error (error answer, true) .
+END PROC block out ;
+
+PROC put (BYTE CONST byte) :
+ put ("LOW : " + text (byte.lower byte) + " HIGH : " + text (byte.higher byte)) .
+END PROC put ;
+
+PROC get (BYTE VAR byte) :
+ get (integer) ;
+ byte := integer .
+END PROC get ;
+
+PROC zu byte (ROW 256 BYTE VAR bytes, TEXT CONST byte kette, INT CONST stelle) :
+ INT VAR lower, higher ;
+ lower := pos (hex chars, (byte kette SUB 1)) * 16 +
+ pos (hex chars, (byte kette SUB 2)) - 17 ;
+ higher:= pos (hex chars, (byte kette SUB 4)) * 16 +
+ pos (hex chars, (byte kette SUB 5)) - 17 ;
+ IF higher > 127
+ THEN bytes (stelle) := minus * 255 + minus + lower
+ ELSE bytes (stelle) := higher * 256 + lower
+ END IF .
+
+minus : higher - 256 .
+END PROC zu byte ;
+
+BYTE OPERATOR $ (TEXT CONST hex) :
+ TEXT VAR byte kette :: "";
+ FOR i FROM 1 UPTO 4 REPEAT
+ IF (hex SUB i) = ""
+ THEN byte kette CAT "0"
+ ELIF (hex SUB i) = " "
+ THEN (* Nix *)
+ ELSE byte kette CAT (hex SUB i)
+ END IF ;
+ END REPEAT ;
+ BYTE VAR byte ;
+ INT VAR lower, higher, i;
+ lower := pos (hex chars, (byte kette SUB 1)) * 16 +
+ pos (hex chars, (byte kette SUB 2)) - 17 ;
+ higher:= pos (hex chars, (byte kette SUB 3)) * 16 +
+ pos (hex chars, (byte kette SUB 4)) - 17 ;
+ IF higher > 127
+ THEN byte := minus * 255 + minus + lower
+ ELSE byte := higher * 256 + lower
+ END IF ;
+ byte .
+
+minus : higher - 256 .
+END OPERATOR $ ;
+
+INT PROCEDURE hint (TEXT CONST he) :
+ INT VAR laenge :: length (he) ,
+ stelle ,
+ ziffer ,
+ ergebnis :: 0 ;
+
+ TEXT VAR h :: he ;
+
+ FOR stelle FROM 65 UPTO 70 REPEAT
+ change all (h, code (stelle + 32), code (stelle))
+ END REPEAT ;
+
+ FOR stelle FROM laenge DOWNTO 1 REP
+ ziffer := pos ("0123456789ABCDEF", h SUB stelle) - 1 ;
+ IF ziffer < 0
+ THEN errorstop ("Unerlaubtes Zeichen in Hexadezimalzahl")
+ END IF ;
+ ergebnis := ergebnis + ziffer * 16 ** (laenge - stelle)
+ END REP ;
+ ergebnis
+END PROCEDURE hint ;
+
+
+(********************** PACKET header operations ***************************)
+
+
+OPERATOR := (HEADER VAR dest, HEADER CONST source) :
+ CONCR (dest) := CONCR (source) .
+END OPERATOR := ;
+
+HEADER PROCEDURE header (TEXT CONST name, date, INT CONST type,
+ TEXT CONST pass) :
+ HEADER : (name, date, type, pass) .
+END PROCEDURE header ;
+
+BOOL PROCEDURE is start header (HEADER CONST header) :
+ CONCR (header).type = start of volume .
+END PROCEDURE is start header ;
+
+BOOL PROCEDURE is end header (HEADER CONST header) :
+ CONCR (header).type = end of volume .
+END PROCEDURE is end header ;
+
+BOOL PROCEDURE is file header (HEADER CONST header) :
+ CONCR (header).type = file header .
+END PROCEDURE is file header ;
+
+PROCEDURE name (HEADER VAR header, TEXT CONST new name) :
+ CONCR (header).name := new name .
+END PROCEDURE name ;
+
+TEXT PROCEDURE name (HEADER CONST header) :
+ CONCR (header).name .
+END PROCEDURE name ;
+
+PROCEDURE date (HEADER VAR header, TEXT CONST new date) :
+ CONCR (header).date := new date .
+END PROCEDURE date ;
+
+TEXT PROCEDURE date (HEADER CONST header) :
+ CONCR (header).date .
+END PROCEDURE date ;
+
+PROCEDURE type (HEADER VAR header, INT CONST new type) :
+ CONCR (header).type := new type .
+END PROCEDURE type ;
+
+INT PROCEDURE type (HEADER CONST header) :
+ CONCR (header).type .
+END PROCEDURE type ;
+
+PROCEDURE pass (HEADER VAR header, TEXT CONST new pass) :
+ CONCR (header).pass := new pass .
+END PROCEDURE pass ;
+
+TEXT PROCEDURE pass (HEADER CONST header) :
+ CONCR (header).pass .
+END PROCEDURE pass ;
+
+
+(********************** Header-Editor V1.4 ****************************)
+
+
+PROCEDURE header edit (HEADER VAR header, TEXT CONST msg) :
+ TEXT VAR head :: ""15"HEADER - EDITOR V1.4" + (25 - LENGTH msg) * "." + msg +
+ 5 * "." + " "14"" ;
+ disable stop ;
+ REPEAT
+ out (home) ;
+ out (16 * (cl eol + down)) ;
+ cursor (6, 6) ;
+ putline (head) ;
+ cursor (6, 7) ;
+ put (""15"TEXT name : "14"") ;
+ edit get (CONCR (header).name, max text length, 38) ;
+ IF is error
+ THEN clear error ;
+ CONCR (header).name := "" ;
+ cursor (6, 7) ;
+ put (""15"TEXT name : "14"") ;
+ edit get (CONCR (header).name, max text length, 38)
+ END IF ;
+ cursor (6, 8) ;
+ put (""15"TEXT date : "14"") ;
+ edit get (CONCR (header).date, max text length, 38) ;
+ IF is error
+ THEN clear error ;
+ CONCR (header).date := "" ;
+ cursor (6, 8) ;
+ put (""15"TEXT date : "14"") ;
+ edit get (CONCR (header).date, max text length, 38)
+ END IF ;
+ cursor (6, 9) ;
+ put (""15"INT type : "14"") ;
+ TEXT VAR d :: text (CONCR (header).type) ;
+ edit get (d, max text length, 38) ;
+ CONCR (header).type := int (d) ;
+ cursor (6, 10) ;
+ put (""15"TEXT pass : "14"") ;
+ edit get (CONCR (header).pass, max text length, 38) ;
+ IF is error
+ THEN clear error ;
+ CONCR (header).pass := "" ;
+ cursor (6, 10) ;
+ put (""15"TEXT pass : "14"") ;
+ edit get (CONCR (header).pass, max text length, 38)
+ END IF ;
+ cursor (6, 13) ;
+ UNTIL NOT no (""15"header ok. "14"") END REPEAT
+END PROCEDURE header edit ;
+
+
+(********************** PACKET block editor ****************************)
+
+
+PROCEDURE show first (ROW 256 BYTE CONST block) :
+ out (home) ;
+ po := 1.0 ;
+ first := true ;
+ FOR i FROM 1 UPTO 16 REPEAT
+ text block (i) := text ((i - 1) * 16, 4) ;
+ text block (i) CAT " : " ;
+ get cursor (x, y) ;
+ FOR i1 FROM 1 UPTO 8 REPEAT
+ text block (i) HEX block ((i-1) * 8 + i1)
+ END REPEAT ;
+ text block (i) CAT " *" ;
+ FOR i1 FROM 1 UPTO 8 REPEAT
+ text block (i) ASCII block ((i - 1) * 8 + i1)
+ END REPEAT ;
+ text block (i) CAT "*" ;
+ cursor (x, y) ;
+ putline (text block (i))
+ END REPEAT .
+END PROCEDURE show first ;
+
+PROCEDURE show second (ROW 256 BYTE CONST block) :
+ out (home) ;
+ po := 129.0 ;
+ first := false ;
+ FOR i FROM 17 UPTO 32 REPEAT
+ text block (i) := text ((i - 1) * 16, 4) ;
+ text block (i) CAT " : " ;
+ get cursor (x,y) ;
+ FOR i1 FROM 1 UPTO 8 REPEAT
+ text block (i) HEX block ((i - 1) * 8 + i1)
+ END REPEAT ;
+ text block (i) CAT " *" ;
+ FOR i1 FROM 1 UPTO 8 REPEAT
+ text block (i) ASCII block ((i - 1) * 8 + i1)
+ END REPEAT ;
+ text block (i) CAT "*" ;
+ cursor (x, y);
+ putline (text block (i))
+ END REPEAT .
+END PROCEDURE show second ;
+
+PROCEDURE block edit (ROW 256 BYTE VAR block, INT CONST st) :
+ IF st > 0
+ THEN IF st > 255
+ THEN push (255 * right)
+ ELSE push (st * right)
+ END IF
+ END IF ;
+ BOOL VAR low :: TRUE ;
+ edit info ;
+ cursor (8, 1) ;
+ get cursor (x, y) ;
+ po := 1.0 ;
+ REPEAT
+ get cursor (x, y) ;
+ cursor (x, y) ;
+ (* inchar (t) ; *)
+ get char (t) ;
+ IF (t = right OR t = " ") AND x < 53
+ THEN cursor (x + 3, y) ; po INCR 0.5
+ ELIF (t = right OR t = " ") AND x > 52 AND y < 16
+ THEN cursor (8, y + 1) ; po INCR 0.5
+ ELIF t = up AND y > 1
+ THEN cursor (x, y - 1) ; po DECR 8.0
+ ELIF t = left AND x > 8
+ THEN cursor (x - 3, y) ; po DECR 0.5
+ ELIF t = left AND x = 8 AND y <> 1
+ THEN cursor (53, y - 1) ; po DECR 0.5
+ ELIF t = down AND y < 16
+ THEN cursor (x, y + 1) ; po INCR 8.0
+ ELIF t = tab
+ THEN IF first
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ ascii edit (block, first) ;
+ IF first
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ IF t <> return
+ THEN edit info ;
+ cursor (8, 1) ;
+ END IF
+ ELIF t = ""7""
+ THEN set ctrl g
+ END IF ;
+ get cursor (x, y) ;
+ cursor (x, y);
+ IF code (t) > 47 AND code (t) < 58 OR
+ code (t) > 96 AND code (t) < 103
+ THEN IF code (t) > 96 CAND code (t) < 103
+ THEN t := code (code (t) - 32)
+ END IF ;
+ out (left + "-" + 2 * right + "-" + 3 * left + t) ;
+ REPEAT
+ (* inchar (tc) ; *)
+ get char (tc) ;
+ UNTIL code (tc) > 47 AND code (tc) < 58 OR
+ code (tc) > 96 AND code (tc) < 103 END REPEAT ;
+ IF code (tc) > 96 CAND code (tc) < 103
+ THEN tc := code (code (tc) - 32)
+ END IF ;
+ out (tc + " " + 4 * left + " ") ;
+ cursor (x, y) ;
+ t CAT tc ;
+ INT VAR bp :: int (po) ;
+ IF po MOD real (bp) = 0.0
+ THEN low := TRUE
+ ELSE low := FALSE
+ END IF ;
+ IF NOT first (* ONE : 17.06.85 *)
+ THEN bp INCR 128
+ END IF ;
+ IF low
+ THEN set lower byte (block (bp), hint (t))
+ ELSE set higher byte (block (bp), hint (t))
+ END IF ;
+ END IF ;
+ info ;
+ UNTIL t = return COR ctrl g END REPEAT ;
+ IF first
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ cursor (1, 17) .
+
+info :
+ get cursor (x, y) ;
+ cursor (xx, yy) ;
+ IF po MOD real (int(po)) = 0.0
+ THEN put ("LOW")
+ ELSE put ("HIGH")
+ END IF ;
+ cursor (x,y) .
+
+edit info :
+ cursor (1, 23) ;
+ put (cl eol + "Block-Editor : Hexmodus,") ;
+ IF first
+ THEN put ("First Block")
+ ELSE put ("Second Block")
+ END IF ;
+ put (",") ;
+ get cursor (xx, yy) .
+END PROCEDURE block edit ;
+
+PROCEDURE block edit (ROW 256 BYTE VAR block, BOOL CONST first,
+ INT CONST st) :
+
+ IF st > 0
+ THEN IF st > 255
+ THEN push (255 * right)
+ ELSE push (st * right)
+ END IF
+ END IF ;
+ BOOL VAR low :: TRUE ;
+ edit info ;
+ cursor (8, 1) ;
+ get cursor (x, y) ;
+ po := 1.0 ;
+ REPEAT
+ get cursor (x, y) ;
+ cursor (x, y) ;
+ (* inchar (t) ; *)
+ get char (t) ;
+ IF (t = right OR t = " ") AND x < 53
+ THEN cursor (x + 3, y) ; po INCR 0.5
+ ELIF (t = right OR t = " ") AND x > 52 AND y < 16
+ THEN cursor (8, y + 1) ; po INCR 0.5
+ ELIF t = up AND y > 1
+ THEN cursor (x, y - 1) ; po DECR 8.0
+ ELIF t = left AND x > 8
+ THEN cursor (x - 3, y) ; po DECR 0.5
+ ELIF t = left AND x = 8 AND y <> 1
+ THEN cursor (53, y - 1) ; po DECR 0.5
+ ELIF t = down AND y < 16
+ THEN cursor (x, y + 1) ; po INCR 8.0
+ ELIF t = tab
+ THEN IF first
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ ascii edit (block, first) ;
+ IF first
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ IF t <> return
+ THEN edit info ;
+ cursor (8, 1) ;
+ END IF
+ ELIF t = ""7""
+ THEN set ctrl g
+ END IF ;
+ get cursor (x, y) ;
+ cursor (x, y);
+ IF code (t) > 47 AND code (t) < 58 OR
+ code (t) > 96 AND code (t) < 103
+ THEN IF code (t) > 96 CAND code (t) < 103
+ THEN t := code (code (t) - 32)
+ END IF ;
+ out (left + "-" + 2 * right + "-" + 3 * left + t) ;
+ REPEAT
+ (* inchar (tc) ; *)
+ get char (tc) ;
+ UNTIL code (tc) > 47 AND code (tc) < 58 OR
+ code (tc) > 96 AND code (tc) < 103 END REPEAT ;
+ IF code (tc) > 96 CAND code (tc) < 103
+ THEN tc := code (code (tc) - 32)
+ END IF ;
+ out (tc + " " + 4 * left + " ") ;
+ cursor (x, y) ;
+ t CAT tc ;
+ INT VAR bp :: int (po) ;
+ IF po MOD real (bp) = 0.0
+ THEN low := TRUE
+ ELSE low := FALSE
+ END IF ;
+ IF NOT first (* ONE : 17.06.85 *)
+ THEN bp INCR 128
+ END IF ;
+ IF low
+ THEN set lower byte (block (bp), hint (t))
+ ELSE set higher byte (block (bp), hint (t))
+ END IF ;
+ END IF ;
+ info ;
+ UNTIL t = return COR ctrl g END REPEAT ;
+ IF first
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ cursor (1, 17) .
+
+info :
+ get cursor (x, y) ;
+ cursor (xx, yy) ;
+ IF po MOD real (int(po)) = 0.0
+ THEN put ("LOW")
+ ELSE put ("HIGH")
+ END IF ;
+ cursor (x,y) .
+
+edit info :
+ cursor (1, 23) ;
+ put (cl eol + "Block-Editor : Hexmodus,") ;
+ IF first
+ THEN put ("First Block")
+ ELSE put ("Second Block")
+ END IF ;
+ put (",") ;
+ get cursor (xx, yy) .
+END PROCEDURE block edit ;
+
+PROCEDURE ascii edit (ROW 256 BYTE VAR block, BOOL CONST first) :
+ BOOL VAR low ;
+ edit info ;
+ cursor (59, 1) ;
+ x := 1 ;
+ y := 1 ;
+ po := 1.0 ;
+ REPEAT
+ get char (t) ;
+ IF po < 1.0 AND first
+ THEN po := 1.0
+ END IF ;
+ IF po < 129.0 AND NOT first
+ THEN po := 129.0
+ END IF ;
+ IF po > 128.5 AND first
+ THEN po := 128.5
+ END IF ;
+ IF po > 256.5 AND NOT first
+ THEN po := 256.5
+ END IF ;
+ SELECT pos (""9""8""2""3""10""13""7"", t) OF
+ CASE 1, 6 : quit ascii edit
+ CASE 2 : IF x > 1 COR (x = 1 AND y > 1)
+ THEN x DECR 1; po DECR 0.5
+ END IF
+ CASE 3 : IF x < 16 COR (x = 16 AND y <> 16)
+ THEN x INCR 1; po INCR 0.5
+ END IF
+ CASE 4 : IF y > 1
+ THEN y DECR 1 ;
+ po DECR 8.0
+ END IF
+ CASE 5 : IF y < 16
+ THEN y INCR 1 ;
+ po INCR 8.0
+ END IF
+ CASE 7 : set ctrl g
+ OTHERWISE IF code (t) >= 32 AND code (t) <= 126
+ THEN set char ; push (""2"")
+ END IF
+ END SELECT ;
+ IF x < 1 AND y = 1
+ THEN x := 1
+ ELIF x < 1 AND y > 1
+ THEN x := 16 ;
+ y DECR 1
+ ELIF x > 16 AND y = 16
+ THEN x := 16 ;
+ ELIF x > 16 AND y < 16
+ THEN x := 1 ;
+ y INCR 1
+ ELIF y < 1
+ THEN y := 1
+ ELIF y > 16
+ THEN y := 16
+ END IF ;
+ info ;
+ UNTIL ctrl g END REPEAT .
+
+quit ascii edit :
+ x := 8 ;
+ y := 1 ;
+ cursor (x, y) ;
+ po := 1.0 ;
+ LEAVE ascii edit .
+
+set char :
+ out (t) ;
+ INT VAR bp :: int (po) ;
+ IF x MOD 2 = 0
+ THEN set higher byte (block (bp), code (t))
+ ELSE set lower byte (block (bp), code (t))
+ END IF.
+
+info :
+ cursor (xx, yy) ;
+ IF po MOD real (int (po)) = 0.0
+ THEN put ("LOW")
+ ELSE put ("HIGH")
+ END IF ;
+ cursor (58 + x, y) .
+
+edit info :
+ cursor (1, 23) ;
+ put (""5"Block-Editor : Asciimodus,") ;
+ IF first
+ THEN put ("First Block")
+ ELSE put ("Second Block")
+ END IF ;
+ put (",") ;
+ get cursor (xx, yy) .
+END PROCEDURE ascii edit ;
+
+
+(********************** PACKET block i/o : ****************************)
+
+
+PROCEDURE set channel (INT CONST channel) :
+ archive channel := channel .
+END PROCEDURE set channel ;
+
+PROCEDURE read block (ROW 256 BYTE VAR block byte, INT CONST block nummer) :
+ user channel := channel ;
+ enable stop ;
+ continue (archive channel) ;
+ disable stop ;
+ block in (block int, disk type, block nummer, error answer) ;
+ IF is error
+ THEN clear error
+ END IF ;
+ break (quiet) ;
+ continue (user channel) ;
+ enable stop ;
+ check archive error (error answer, true) ;
+ block byte := block int .
+END PROCEDURE read block ;
+
+PROCEDURE write block (ROW 256 BYTE VAR block byte, INT CONST block nummer) :
+ user channel := channel ;
+ enable stop ;
+ block int := block byte ;
+ continue (archive channel) ;
+ disable stop ;
+ block out (block int, disk type, block nummer, error answer) ;
+ IF is error
+ THEN clear error
+ END IF ;
+ break (quiet) ;
+ continue (user channel) ;
+ enable stop ;
+ check archive error (error answer, false) .
+END PROCEDURE write block;
+
+PROCEDURE read block (ROW 256 INT VAR block int, INT CONST block nummer) :
+ user channel := channel ;
+ enable stop ;
+ continue (archive channel) ;
+ disable stop ;
+ block in (block int, disk type, block nummer, error answer) ;
+ IF is error
+ THEN clear error
+ END IF ;
+ break (quiet) ;
+ continue (user channel) ;
+ enable stop ;
+ check archive error (error answer, true) .
+END PROCEDURE read block ;
+
+PROC write block (ROW 256 INT VAR block int, INT CONST block nummer) :
+ user channel := channel ;
+ enable stop ;
+ continue (archive channel) ;
+ disable stop ;
+ block out (block int, disk type, block nummer, error answer) ;
+ IF is error
+ THEN clear error
+ END IF ;
+ break (quiet) ;
+ continue (user channel) ;
+ enable stop ;
+ check archive error (error answer, false) .
+END PROCEDURE write block ;
+
+
+(********************** PACKET space i/o : ****************************)
+
+
+PROCEDURE seek space (INT CONST space) :
+ user channel := channel ;
+ enable stop ;
+ rewind ;
+ INT VAR i ;
+ continue (archive channel) ;
+ disable stop ;
+ FOR i FROM 1 UPTO space REPEAT
+ skip dataspace
+ UNTIL is error END REPEAT ;
+ break (quiet) ;
+ continue (user channel) .
+END PROCEDURE seek space ;
+
+PROCEDURE seek block (INT CONST block nr) :
+ seek (block nr) .
+END PROCEDURE seek block ;
+
+PROCEDURE read space (DATASPACE VAR ds) :
+ user channel := channel ;
+ enable stop ;
+ continue (archive channel) ;
+ disable stop ;
+ read (ds) ;
+ break (quiet) ;
+ continue (user channel) .
+END PROCEDURE read space ;
+
+PROCEDURE read space (DATASPACE VAR ds, INT VAR max pages,
+ BOOL CONST errors) :
+ user channel := channel ;
+ enable stop ;
+ continue (archive channel) ;
+ disable stop ;
+ read (ds, max pages, errors) ;
+ break (quiet) ;
+ continue (user channel) .
+END PROCEDURE read space ;
+
+PROCEDURE write space (DATASPACE CONST ds) :
+ user channel := channel ;
+ enable stop ;
+ continue (archive channel) ;
+ disable stop ;
+ write (ds) ;
+ break (quiet) ;
+ continue (user channel) .
+END PROCEDURE write space ;
+
+PROCEDURE check archive error (INT CONST code, BOOL CONST read) :
+ enable stop ;
+ IF read
+ THEN SELECT code OF
+ CASE 0 :
+ CASE 1 : error stop (read write impossible error,
+ "Lesen unmoeglich (1)")
+ CASE 2 : error stop (read error,
+ "Lesefehler (2)")
+ CASE 3 : error stop (block number error,
+ "Blocknummer zu hoch (3)")
+ OTHERWISE error stop (undef archive error,
+ "Archivfehler unbekannt ("+ text (code) +")")
+ END SELECT
+ ELSE SELECT code OF
+ CASE 0 :
+ CASE 1 : error stop (read write impossible error,
+ "Schreiben unmoeglich (1)")
+ CASE 2 : error stop (write error,
+ "Schreibfehler (2)")
+ CASE 3 : error stop (block number error,
+ "Blocknummer zu hoch (3)")
+ OTHERWISE error stop (undef archive error,
+ "Archivfehler unbekannt ("+ text (code) +")")
+ END SELECT
+ END IF .
+END PROCEDURE check archive error ;
+
+
+(********************** PACKET menue monitor : ****************************)
+
+
+PROCEDURE fehler behandeln :
+ IF is error CAND error message <> ""
+ THEN IF is halt from terminal
+ THEN set ctrl g
+ ELSE cursor (error line x pos, error line y pos) ;
+ clear error ;
+ put (cl eol +"Fehler : "+ error message)
+ END IF
+ END IF .
+END PROCEDURE fehler behandeln ;
+
+PROCEDURE set ctrl g :
+ ctrl g := true .
+END PROCEDURE set ctrl g ;
+
+PROCEDURE reset ctrl g :
+ ctrl g := false .
+END PROCEDURE reset ctrl g ;
+
+PROCEDURE fehler loeschen :
+ INT VAR x, y ;
+ get cursor (x, y) ;
+ cursor (1, 22) ;
+ out (cl eol) ;
+ cursor (1, 18) ;
+ out (cl eol) ;
+ cursor (1, 23) ;
+ out (cl eol) ;
+ cursor (x, y) .
+END PROCEDURE fehler loeschen ;
+
+
+(********************** Global-Menue ****************************)
+
+
+PROCEDURE global menue :
+ ende := false ;
+ user channel := channel ;
+ disable stop ;
+ REPEAT
+ menue monitor (global info line, global chars, command index) ;
+ fehler loeschen ;
+ SELECT command index OF
+ CASE 1 : block menue
+ CASE 2 : space menue
+ CASE 3 : archive menue
+ CASE 4 : configurator menue
+ CASE 5 : urflop menue
+ CASE 6 : out ("uit");ende := true ;
+ CASE 7 : get and do one command ; block shown := false
+ CASE 8 : global menue help ; block shown := false
+ CASE 9 : set ctrl g
+ END SELECT ;
+ fehler behandeln ;
+ UNTIL ende COR ctrl g END REPEAT ;
+ reset ctrl g ;
+ ende := false .
+END PROCEDURE global menue ;
+
+
+(********************** Block-Menue ****************************)
+
+
+PROCEDURE block menue :
+ disable stop ;
+ REPEAT
+ menue monitor (block info line, block chars, command index) ;
+ fehler loeschen ;
+ SELECT command index OF
+ CASE 1 : read one block
+ CASE 2 : write one block
+ CASE 3 : edit block menue
+ CASE 4 : LEAVE block menue
+ CASE 5 : get and do one command
+ CASE 6 : search menue
+ CASE 7 : push ("r"+ text (block nummer + 1) +" ")
+ CASE 8 : block menue help ; block shown := false
+ CASE 9 : set ctrl g
+ END SELECT ;
+ show first three ints ;
+ display info line ;
+ fehler behandeln
+ UNTIL ctrl g END REPEAT .
+
+read one block :
+ out ("ead Block : ") ;
+ x get (block nummer) ;
+ IF NOT is error
+ THEN reset block io ;
+ read block (block, block nummer)
+ END IF ;
+ IF NOT is error
+ THEN show first (block) ; block shown := true
+ END IF .
+
+write one block :
+ out ("rite") ;
+ IF yes ("write auf Block "+ text (block nummer))
+ THEN reset block io ;
+ write block (block, block nummer)
+ ELIF yes ("write auf einen anderen Block")
+ THEN out (" auf Block : ") ;
+ x get (block nummer) ;
+ IF NOT is error
+ THEN reset block io ;
+ write block (block, block nummer)
+ END IF
+ END IF .
+
+show first three ints :
+ cursor (1, 18) ;
+ put (""5"1.INT : ") ;
+ TEXT VAR h :: "" ; h HEX block (1) ;
+ INT VAR ih := block (1) ;
+ h CAT ("/ " + text (ih)) ;
+ put (h) ;
+ put (", 2.INT : ") ;
+ h := "" ; h HEX block (2) ;
+ ih := block (2) ;
+ h CAT ("/ " + text (ih)) ;
+ put (h) ;
+ put (", 3.INT : ") ;
+ h := "" ; h HEX block (3) ;
+ ih := block (3) ;
+ h CAT ("/ " + text (ih)) ;
+ put (h) .
+END PROCEDURE block menue ;
+
+
+(********************** Search-Menue ****************************)
+
+
+PROCEDURE search menue :
+ disable stop ;
+ menue monitor (search info line, search chars, command index) ;
+ fehler loeschen ;
+ SELECT command index OF
+ CASE 1 : ascii search
+ CASE 2 : hex search
+ CASE 3 : dez search
+ CASE 4 : LEAVE search menue
+ CASE 5 : set ctrl g
+ END SELECT ;
+ display info line ;
+ fehler behandeln .
+
+ascii search :
+ cursor (command line x pos + 1, command line y pos) ;
+ put ("Suchtext :") ; getline (t) ;
+ cursor (command line x pos + 1, command line y pos) ;
+ put ("suchen nach """+ t +""" von Block :") ;
+ x get (s) ;
+ cursor (command line x pos + 1, command line y pos) ;
+ put ("suchen nach """+ t +""" von Block") ;
+ put (s) ; put ("bis Block :") ; x get (e) ;
+ search (t, s, e, fb, fp) ;
+ out (""13"") ;
+ IF fp > 0
+ THEN put (cl eol +"Gefunden auf Block") ; put (fb) ;
+ put (", Position") ; put (fp) ;
+ read block (block, fb) ;
+ IF fp < 256
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ block shown := true ;
+ st pos := (fp MOD 256) - 1 ;
+ block nummer := fb ;
+ ELSE put ("Nicht gefunden !!");
+ FI .
+
+hex search :
+ cursor (command line x pos + 1, command line y pos) ;
+ put ("Suchhex :") ; getline (t) ;
+ cursor (command line x pos + 1, command line y pos) ;
+ put ("suchen nach """+ t +""" von Block :") ;
+ x get (s) ;
+ cursor (command line x pos + 1, command line y pos) ;
+ put ("suchen nach """+ t +""" von Block") ;
+ put (s) ; put ("bis Block :") ; x get (e) ;
+ change all (t, " ", "") ;
+ TEXT VAR such hex := "" ;
+ i := 1 ;
+ REPEAT
+ such hex CAT code (hint (subtext (t, i, i + 1))) ;
+ i INCR 2
+ UNTIL i >= length (t) END REPEAT ;
+ search (such hex, s, e, fb, fp) ;
+ out (""13"") ;
+ IF fp > 0
+ THEN put (cl eol +"Gefunden auf Block") ; put (fb) ;
+ put (", Position") ; put (fp) ;
+ read block (block, fb) ;
+ IF fp < 256
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ block shown := true ;
+ st pos := (fp MOD 256) - 1 ;
+ block nummer := fb ;
+ ELSE put ("Nicht gefunden !!");
+ FI .
+
+dez search :
+ error stop ("gibt es noch nicht !") .
+END PROCEDURE search menue ;
+
+
+(********************** Block-Editor-Menue ****************************)
+
+
+PROCEDURE edit block menue :
+ INT VAR command index ;
+ disable stop ;
+ REPEAT
+ fehler loeschen ;
+ show first three ints ;
+ menue monitor (editor info line, editor chars, command index) ;
+ SELECT command index OF
+ CASE 1 : out ("irst") ;
+ show first (block) ;
+ block shown := true
+ CASE 2 : out ("econd") ;
+ show second (block) ;
+ block shown := true
+ CASE 3 : out ("ump") ;
+ show first (block) ; block edit (block, stpos) ;
+ show second (block) ; block edit (block, stpos) ;
+ block shown := true ;
+ CASE 4 : IF NOT block shown
+ THEN IF first
+ THEN show first (block)
+ ELSE show second (block)
+ END IF ;
+ block shown := true
+ END IF ;
+ (* IF first AND stpos >= 256
+ THEN show second (block) ;
+ block shown := true
+ ELIF NOT first AND stpos <= 256
+ THEN show first (block) ;
+ block shown := true
+ END IF ; *) (* ??? *)
+ block edit (block, stpos)
+ CASE 5 : LEAVE edit block menue
+ CASE 6 : get and do one command ; block shown := false
+ CASE 7 : block editor menue help ; block shown := false
+ CASE 8 : set ctrl g
+ CASE 9 : INT VAR old st pos := st pos ;
+ out ("os auf Byte : ") ;
+ x get (st pos) ;
+ IF st pos < 0 OR st pos > 513
+ THEN st pos := old st pos ;
+ error stop ("Zahl nicht ok")
+ END IF
+ END SELECT ;
+ fehler behandeln
+ UNTIL ctrl g END REPEAT .
+
+show first three ints :
+ cursor (1, 18) ;
+ put (""5"1.INT : ") ;
+ TEXT VAR h :: "" ; h HEX block (1) ;
+ INT VAR ih := block (1) ;
+ h CAT ("/ " + text (ih)) ;
+ put (h) ;
+ put (", 2.INT : ") ;
+ h := "" ; h HEX block (2) ;
+ ih := block (2) ;
+ h CAT ("/ " + text (ih)) ;
+ put (h) ;
+ put (", 3.INT : ") ;
+ h := "" ; h HEX block (3) ;
+ ih := block (3) ;
+ h CAT ("/ " + text (ih)) ;
+ put (h) .
+END PROCEDURE edit block menue ;
+
+
+(********************** Space-Menue ****************************)
+
+
+PROCEDURE space menue :
+ disable stop ;
+ REPEAT
+ menue monitor (space info line, space chars, command index) ;
+ fehler loeschen ;
+ rewind ;
+ SELECT command index OF
+ CASE 1 : read one space
+ CASE 2 : bit map read
+ CASE 3 : write one space
+ CASE 4 : bit map write
+ CASE 5 : edit one space
+ CASE 6 : copy one space
+ CASE 7 : LEAVE space menue
+ CASE 8 : new edit
+ CASE 9 : get and do one command
+ CASE 10 : load one space
+ CASE 11 : space menue help
+ CASE 12 : set ctrl g
+ END SELECT ;
+ fehler behandeln ;
+ display info line ;
+ UNTIL ctrl g END REPEAT .
+
+load one space :
+ out ("aden aus Datei : ") ;
+ getline (dummy) ;
+ forget (ds) ;
+ ds := nilspace ;
+ ds := old (dummy) .
+
+read one space :
+ cursor (info line x pos, info line y pos) ;
+ out (space header info) ;
+ cursor (command line x pos + 2, command line y pos) ;
+ out ("ead ") ;
+ REPEAT
+ get char (dummy)
+ UNTIL pos ("shq"7"", dummy) > 0 END REPEAT ;
+ IF dummy = "s"
+ THEN out ("Space : ") ; read one s
+ ELIF dummy = "h"
+ THEN out ("Header : ") ; read one h
+ ELIF dummy = ""7""
+ THEN set ctrl g
+ END IF .
+
+read one s :
+ x get (space nummer) ;
+ IF NOT is error
+ THEN seek space (space nummer) ;
+ first sp block := block number + 1 ;
+ forget (ds) ;
+ ds := nilspace ;
+ read space (ds)
+ END IF .
+
+read one h :
+ x get (header nummer) ;
+ space nummer := space nr (header nummer) ;
+ IF NOT is error
+ THEN seek space (space nummer) ;
+ first sp block := block number + 1 ;
+ forget (ds) ;
+ ds := nilspace ;
+ read space (ds)
+ END IF .
+
+bit map read :
+ out ("ead Space ab Block : ") ;
+ x get (s) ;
+ cursor (command line x pos + 1, command line y pos) ;
+ out ("Read Space ab Block "+ text (s) +" Max. Bloecke : ") ;
+ x get (e) ;
+ seek block (s) ;
+ IF e = 0
+ THEN e := 32000
+ END IF ;
+ forget (ds) ;
+ ds := nilspace ;
+ IF yes ("bei Lesefehlern abbrechen")
+ THEN read space (ds, e, true)
+ ELSE read space (ds, e, false)
+ END IF .
+
+write one space :
+ out ("rite") ;
+ IF yes ("write auf Space "+ text (space nummer))
+ THEN seek space (space nummer) ;
+ write space (ds)
+ ELIF yes ("write auf einen anderen Space")
+ THEN out (" auf Space : ") ;
+ x get (space nummer) ;
+ IF NOT is error
+ THEN seek space (space nummer) ;
+ write space (ds)
+ END IF
+ END IF .
+
+bit map write :
+ out ("rite Space ab Block : ") ;
+ x get (s) ;
+ seek block (s) ;
+ write space (ds) .
+
+edit one space :
+ IF type (ds) = file type 16
+ THEN change to 17 ;
+ f := sequential file (modify, ds) ;
+ edit (f, 1, 1, x size - 2, 16) ;
+ block shown := false
+ ELIF type (ds) = file type
+ THEN f := sequential file (modify, ds) ;
+ edit (f, 1, 1, x size - 2, 16) ;
+ block shown := false
+ ELIF ds pages (ds) = 1 CAND type (ds) = 0
+ THEN edit header ;
+ block shown := false
+ END IF .
+
+change to 17 :
+ TEXT VAR t := "" ;
+ REPEAT
+ t CAT "­"
+ UNTIL NOT exists (t) END REPEAT ;
+ copy (ds, t) ;
+ reorganize (t) ;
+ forget (ds) ;
+ ds := nilspace ;
+ ds := old (t) ;
+ forget (t, quiet) .
+
+copy one space :
+ put ("ave in Datei : ") ;
+ getline (t) ;
+ copy (ds, t) .
+
+edit header :
+ bound header := ds ;
+ cursor (1, 23) ;
+ out (cl eol +"Header-Editor : ") ;
+ IF is start header (bound header)
+ THEN out ("Header ist ein Archiv-Startheader.")
+ ELIF is file header (bound header)
+ THEN out ("Header ist ein File-Header.")
+ ELIF is end header (bound header)
+ THEN out ("Header ist ein Archiv-Endheader.")
+ ELSE out ("Header ist unbekannt (Headertype = "+ text (type (bound header)) +").")
+ END IF ;
+ header edit (bound header, "Headernummer : "+ text (header nr) + " ") .
+
+new edit :
+ out (left +"new edit ") ;
+ block shown := false ;
+ IF yes ("Neuen Headerspace erstellen")
+ THEN create new header
+ ELSE create new file
+ END IF .
+
+create new header :
+ forget (ds) ;
+ ds := nilspace ;
+ bound header := ds ;
+ bound header := nil header ;
+ cursor (1, 23) ;
+ out (cl eol +"Header-Editor : ") ;
+ put ("Neuen Header erstellen") ;
+ header edit (bound header, "Neuen Header erstellen") .
+
+create new file :
+ forget (ds) ;
+ ds := nilspace ;
+ f := sequential file (modify, ds) ;
+ edit (f, 1, 1, x size - 2, 16) .
+END PROCEDURE space menue ;
+
+
+(********************** Configurator-Menu ****************************)
+
+
+PROCEDURE configurator menue :
+ disable stop ;
+ REPEAT
+ display conf info ;
+ menue monitor (conf info line, conf chars, command index) ;
+ fehler loeschen ;
+ SELECT command index OF
+ CASE 1 : put ("hannel :") ; x get (archive channel) ;
+ CASE 2 : put (left +"disktype :") ; x get (disk type) ;
+ CASE 3 : disk info
+ CASE 4 : get and do one command
+ CASE 5 : LEAVE configurator menue
+ CASE 6 : conf menue help
+ CASE 7 : set ctrl g
+ END SELECT ;
+ fehler behandeln ;
+ display info line ;
+ UNTIL ctrl g END REPEAT .
+
+display conf info :
+ cursor (1, 19) ;
+ put (cl eol +"I/O Channel :") ; put (archive channel) ; put (",") ;
+ put ("Disktype :") ; put (disk type) ; put (",") ;
+ put ("Operatorchannel :") ; put (channel) ;
+ cursor (1, 18) ;
+ put ("Zeit :") ; put (time of day) ; put (", Datum :") ; put (date) ;
+ INT VAR x size, x used ;
+ storage (x size, x used) ;
+ put (",") ; put (x used) ; put ("K von") ;
+ put (int (real (x size + 24) * 64.0 / 63.0)) ;
+ put ("K sind belegt !") .
+
+disk info :
+ INT VAR size, io, error ;
+ io control (archive channel, io, size, error) ;
+ out (home + 16 * (cl eol + down)) ;
+ out (home + down) ;
+ putline ("Diskinfo :") ;
+ putline (first mon line) ;
+ put ("Disksize :") ; put (size) ; put ("Blocks,") ;
+ put (size DIV 2) ; put ("kB.") ;
+ line ;
+ put ("Disktype :") ;
+ IF size = ibm 720 format 5
+ THEN putline ("5 1/4 Zoll, IBM-720 kB Format, 80 Tracks,") ;
+ putline (" double sided/double density, softsectored")
+ ELIF size = ibm 360 format 5
+ THEN putline ("5 1/4 Zoll, IBM-360 kB Format, 40 Tracks,") ;
+ putline (" single sided/double density, softsectored")
+ ELIF size = pic 400 format 5
+ THEN putline ("5 1/4 Zoll, PIC400 Format, 80 Tracks,") ;
+ putline (" double sided/double density, softsectored")
+ ELIF size = soft sd 8
+ THEN putline ("8 Zoll, EUMEL-Format, 77 Tracks,") ;
+ putline (" single sided/double density, softsectored")
+ ELIF size = soft dd 8
+ THEN putline ("8 Zoll, EUMEL-Format, 77 Tracks,") ;
+ putline (" double sided/double density, softsectored")
+ ELIF size = hard ss sd
+ THEN putline ("8 Zoll, EUMEL-Format, 32 Tracks,") ;
+ putline (" single sided/single density, hardsectored")
+ ELIF size = hard ds sd
+ THEN putline ("8 Zoll, EUMEL-Format, 32 Tracks,") ;
+ putline (" double sided/single density, hardsectored")
+ ELSE putline ("Unbekannter Disktype") ; line
+ END IF ;
+ putline (first mon line) .
+END PROCEDURE configurator menue ;
+
+
+
+(********************** Header/Space Ops. ****************************)
+
+
+INT PROCEDURE header nr :
+ IF space nummer = 0
+ THEN 0
+ ELSE (space nummer + 1) DIV 2
+ END IF .
+END PROCEDURE header nr ;
+
+INT PROCEDURE space nr (INT CONST header nummer) :
+ IF header nummer = 0 COR header nummer = 1
+ THEN header nummer
+ ELSE header nummer * 2 - 1
+ END IF
+END PROCEDURE space nr ;
+
+
+(********************** Archiv-Menue ****************************)
+
+
+PROCEDURE archive menue :
+ archive (archive name) ;
+ disable stop ;
+ REPEAT
+ menue monitor (archiv info line, archiv chars, command index) ;
+ fehler loeschen ;
+ SELECT command index OF
+ CASE 1 : archive anmelden
+ CASE 2 : out ("elease (archive)") ;
+ release (archive) ; archivename := ""
+ CASE 3 : out ("ist (archive)") ;
+ list archive ;
+ block shown := false
+ CASE 4 : out ("etch (SOME archive, archive)") ;
+ fetch (SOME archive, archive) ;
+ block shown := false
+ CASE 5 : out ("ave (SOME all, archive)") ;
+ save (SOME all, archive) ;
+ block shown := false
+ CASE 6 : release (archive) ;
+ LEAVE archive menue
+ CASE 7 : get and do one command ;
+ block shown := false
+ CASE 8 : archiv menue help ;
+ block shown := false
+ CASE 9 : set ctrl g
+ END SELECT ;
+ fehler behandeln
+ UNTIL ctrl g END REPEAT .
+
+archive anmelden :
+ put ("rchivename : ") ;
+ getline (archivename) ;
+ archive (archivename) .
+
+list archive :
+ IF NOT (list file ok) COR no (""13"Alte Archiveliste zeigen")
+ THEN forget (af ds) ;
+ af ds := nilspace ;
+ af := sequential file (output, af ds) ;
+ list (af, archive) ;
+ list file ok := true
+ END IF ;
+ edit (af, 1, 1, xsize - 2, 16) .
+END PROCEDURE archive menue ;
+
+
+(********************** Urflop-Menue ****************************)
+
+
+PROCEDURE urflop menue :
+ INT VAR s, e ;
+ disable stop ;
+ REPEAT
+ menue monitor (urflop info line, urflop chars, command index) ;
+ fehler loeschen ;
+ SELECT command index OF
+ CASE 1 : read
+ CASE 2 : x read
+ CASE 3 : write
+ CASE 4 : x write
+ CASE 5 : list task ;
+ block shown := false
+ CASE 6 : LEAVE urflop menue
+ CASE 7 : get and do one command ;
+ block shown := false
+ CASE 8 : urflop menue help ;
+ block shown := false
+ CASE 9 : set ctrl g
+ END SELECT ;
+ fehler behandeln
+ UNTIL ctrl g END REPEAT .
+
+list task :
+ forget (l ds) ;
+ l ds := nilspace ;
+ lf := sequential file (output, l ds) ;
+ list (lf) ;
+ edit (lf, 1, 1, xsize - 2, 16) .
+
+write :
+ out ("rite Datenraumname : ") ;
+ getline (t) ;
+ IF yes ("Urlader schreiben wie gelesen")
+ THEN urlader schreiben (t, eumel 0 start block,
+ -1)
+ ELIF yes ("Urlader für PIC 400 (Shard 6.xx) schreiben")
+ THEN urlader schreiben (t, eumel 0 start block,
+ eumel 0 end block pic)
+ ELIF yes ("Urlader für PIC 400 (Shard 7.xx, u. Bicos Masch.) schreiben")
+ THEN urlader schreiben (t, eumel 0 start block,
+ eumel 0 end block)
+ ELIF yes ("Urlader für PIC 400 (ab Shard 7.13 für EUMEL Ver. 1758) schreiben")
+ THEN urlader schreiben (t, eumel 0 start block,
+ eumel 0 end block 1758)
+ END IF .
+
+x write :
+ out ("rite Datenraumname : ") ;
+ getline (t) ;
+ cursor (command line x pos, command line y pos) ;
+ out (">Write Datenraum """+ t +""" von Block : ") ;
+ x get (s) ;
+ cursor (command line x pos, command line y pos) ;
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis : ") ;
+ x get (e) ;
+ cursor (command line x pos, command line y pos) ;
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e)) ;
+ IF yes ("mit Versatz")
+ THEN cursor (command line x pos, command line y pos) ;
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Versatz : ") ;
+ x get (ver) ;
+ cursor (command line x pos, command line y pos) ;
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Ver. "+ text (ver) + " --> ") ;
+ urlader schreiben (t, s, e, ver)
+ ELSE cursor (command line x pos, command line y pos) ;
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" --> ") ;
+ urlader schreiben (t, s, e)
+ END IF .
+
+read :
+ out ("ead Datenraumname : ") ;
+ getline (t) ;
+ IF yes ("Urlader für PIC 400 (Shard 6.xx) lesen")
+ THEN urlader lesen (t, eumel 0 start block,
+ eumel 0 end block pic)
+ ELIF yes ("Urlader für PIC 400 (Shard 7.xx, u. Bicos Masch.) lesen")
+ THEN urlader lesen (t, eumel 0 start block,
+ eumel 0 end block)
+ ELIF yes ("Urlader für PIC 400 (Shard 7.xx für EUMEL Ver. 1758) lesen")
+ THEN urlader lesen (t, eumel 0 start block,
+ eumel 0 end block 1758)
+ END IF .
+
+x read :
+ out ("ead Datenraumname : ") ;
+ getline (t) ;
+ cursor (command line x pos, command line y pos) ;
+ out (">Read Datenraum """+ t +""" von Block : ") ;
+ x get (s) ;
+ cursor (command line x pos, command line y pos) ;
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis : ") ;
+ x get (e) ;
+ IF yes ("mit Versatz")
+ THEN cursor (command line x pos, command line y pos) ;
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Versatz : ") ;
+ x get (ver) ;
+ cursor (command line x pos, command line y pos) ;
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Ver. "+ text (ver) + " --> ") ;
+ urlader lesen (t, s, e, ver)
+ ELSE cursor (command line x pos, command line y pos) ;
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" --> ") ;
+ urlader lesen (t, s, e)
+ END IF .
+END PROCEDURE urflop menue ;
+
+
+(********************** Disk - Monitor Call ****************************)
+
+
+PROCEDURE central disk monitor process :
+ archive ("disk") ;
+ release (archive) ;
+ space nummer := -1 ;
+ block nummer := -1 ;
+ header nummer := -1 ;
+ first sp block := -1 ;
+ st pos := 0 ;
+ archive name := "" ;
+ list file ok := false ;
+ block shown := false ;
+ reset ctrl g ;
+ page ;
+ line (3) ;
+ putline ("D I S K - M O N I T O R") ;
+ putline ("=========================") ;
+ line ;
+ putline ("Autor : Ingo Siekmann") ;
+ putline ("Stand : "+ software stand) ;
+ putline (software version) ;
+ putline ("Bem. : "+ software bemerkung) ;
+ putline (" "+ software bemerkung1) ;
+ line ;
+ putline ("(c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert") ;
+ line ;
+ initialize if necessary ;
+ global menue ;
+ line ;
+ unblock (archive) ;
+ IF archive name <> "" CAND NOT ctrl g
+ THEN archive (archive name)
+ END IF .
+END PROCEDURE central disk monitor process ;
+
+
+(********************** Unterprogramme ****************************)
+
+
+THESAURUS OPERATOR SOME (THESAURUS CONST thesaurus) :
+ DATASPACE VAR edit space :: nilspace ;
+ THESAURUS VAR result := empty thesaurus ;
+ FILE VAR file := sequential file (output, edit space) ;
+ file FILLBY thesaurus ;
+ modify (file) ;
+ edit (file, 1, 1, xsize - 2, 16) ;
+ input (file) ;
+ result FILLBY file ;
+ forget (edit space) ;
+ result .
+END OPERATOR SOME ;
+
+THESAURUS OPERATOR SOME (TASK CONST dest task) :
+ SOME ALL dest task .
+END OPERATOR SOME ;
+
+PROCEDURE display info line :
+ INT VAR x, y ;
+ get cursor (x, y) ;
+ cursor (1, 24) ;
+ put (cl eol +"Block : ") ; put (block nummer) ;
+ put (", Space : ") ; put (space nummer) ;
+ put (", First Sp Block : ") ; put (first sp block) ;
+ put (", Header : ") ; put (header nummer) ;
+ cursor (x, y) .
+END PROCEDURE display info line ;
+
+PROCEDURE x get (INT VAR i) :
+ enable stop ;
+ get (dummy) ;
+ IF (dummy SUB length (dummy)) = hex marker
+ THEN i := hint (text (dummy, length (dummy) - 1))
+ ELSE i := int (dummy)
+ END IF ;
+ IF NOT last conversion ok
+ THEN error stop ("Zahl ist nicht korrekt")
+ END IF .
+END PROCEDURE x get ;
+
+
+(********************** Urflop - Ops. ****************************)
+
+
+PROCEDURE urlader lesen (TEXT CONST urname, INT CONST start, end) :
+ urlader lesen (urname, start, end, 0) .
+END PROCEDURE urlader lesen ;
+
+PROCEDURE urlader schreiben (TEXT CONST urname, INT CONST start, end) :
+ urlader schreiben (urname, start, end, 0) .
+END PROCEDURE urlader schreiben ;
+
+PROCEDURE urlader lesen auf seite (TEXT CONST urname, INT CONST start, end,
+ auf) :
+ urlader lesen (urname, start, end, auf - start) .
+END PROCEDURE urlader lesen auf seite ;
+
+PROCEDURE urlader schreiben von seite (TEXT CONST urname, INT CONST start,
+ end, von) :
+ urlader schreiben (urname, start, end, von - start) .
+END PROCEDURE urlader schreiben von seite ;
+
+PROCEDURE urlader lesen (TEXT CONST urname, INT CONST start, end, ver) :
+ IF exists (urname)
+ THEN error stop (""""+ urname +""" gibt es schon")
+ END IF ;
+ forget (uds) ;
+ uds := nilspace ;
+ reset block io ;
+ reset ctrl g ;
+ FOR block nr FROM start UPTO end REPEAT
+ continue (archive channel) ;
+ disable stop ;
+ block in (uds, block nr + ver, disk type, block nr, error) ;
+ continue (user channel) ;
+ enable stop ;
+ check archive error (error, true) ;
+ cout (block nr) ;
+ dummy := incharety ;
+ IF dummy = ""7""
+ THEN set ctrl g
+ END IF
+ UNTIL dummy = esc COR ctrl g END REPEAT ;
+ IF NOT ctrl g
+ THEN copy (uds, urname) ;
+ END IF ;
+ forget (uds) .
+END PROCEDURE urlader lesen ;
+
+PROCEDURE urlader schreiben (TEXT CONST urname, INT CONST start, end, ver) :
+ forget (uds) ;
+ uds := old (urname) ;
+ reset ctrl g ;
+ reset block io ;
+ block nr := start;
+ IF block nr = -1
+ THEN block nr := next ds page (uds, block nr)
+ END IF ;
+ WHILE block nr <> -1 REPEAT
+ continue (archive channel) ;
+ disable stop ;
+ block out (uds, block nr + ver, disk type, block nr, error) ;
+ break (quiet);
+ continue (user channel) ;
+ enable stop ;
+ check archive error (error, false) ;
+ cout (block nr) ;
+ dummy := incharety ;
+ IF dummy = ""7""
+ THEN set ctrl g
+ END IF ;
+ IF end = -1 COR start = -1
+ THEN block nr := next ds page (uds, block nr)
+ ELIF block nr = end
+ THEN block nr := -1
+ ELSE block nr INCR 1
+ END IF
+ UNTIL dummy = esc COR ctrl g END REPEAT ;
+ forget (uds) .
+END PROCEDURE urlader schreiben ;
+
+
+(********************** Unterprogramme ****************************)
+
+
+PROCEDURE reset block io :
+ user channel := channel ;
+ INT VAR i, s, e ;
+ io control (archive channel, i, s, e) ;
+ check archive error (e, true) .
+END PROCEDURE reset block io ;
+
+PROCEDURE get and do one command :
+ initialize if necessary ;
+ cursor (1, 21) ;
+ out (cl eop) ;
+ get command ("gib ein EUMEL-Kommando : ", own command line) ;
+ do (own command line) .
+END PROCEDURE get and do one command ;
+
+PROCEDURE io control (INT VAR io, size, error) :
+ ROW 256 INT VAR block ;
+ control (type mode, 0, 0, io) ;
+ control (size mode, 0, 0, size) ;
+ block in (block, std disk type, block 0, error) .
+END PROCEDURE io control ;
+
+PROCEDURE io control (INT CONST io channel, INT VAR io, size, error) :
+ INT VAR op channel :: channel ;
+ continue (io channel) ;
+ io control (io, size, error) ;
+ break (quiet) ;
+ continue (op channel) .
+END PROCEDURE io control ;
+
+
+(********************** Menue - Help Ops ****************************)
+
+
+PROCEDURE global menue help :
+ out (home + cl eop) ;
+ line ;
+ putline ("Help für das Global-Menue : ") ;
+ line ;
+ putline ("b --> Aufruf des Block-Menüs (direkter Block i/o)") ;
+ putline ("s --> Aufruf des Space-Menüs (direkter Space- und Header i/o)") ;
+ putline ("a --> Aufruf des Archiv-Menüs (normale Archivoperationen)") ;
+ putline ("u --> Aufruf des Urflop-Menüs (Urlader/Datenraum <-> Floppy)") ;
+ putline ("c --> Aufruf des Konfigurator-Menüs") ;
+ line ;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
+ line ;
+ putline ("q --> Verlassen des Diskettenmonitors (quit wie im Editor)") ;
+END PROCEDURE global menue help ;
+
+PROCEDURE block menue help :
+ out (home + cl eop) ;
+ line ;
+ putline ("Help für das Block-Menü : ") ;
+ line ;
+ putline ("r --> Lesen eines Blockes (block in)") ;
+ putline ("n --> Lesen des nächsten Blockes") ;
+ putline ("w --> Schreiben eines Blockes (block out)") ;
+ line ;
+ putline ("s --> Suchen nach einem Text") ;
+ line ;
+ putline ("e --> Aufruf des Blockeditor-Menüs") ;
+ line ;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
+ line ;
+ putline ("q --> Verlassen des Block-Menüs (Rückkehr ins Global-Menü)") ;
+END PROCEDURE block menue help ;
+
+PROCEDURE block editor menue help :
+ out (home + cl eop) ;
+ line ;
+ putline ("Help für das Blockeditor-Menü : ") ;
+ line ;
+ putline ("f --> Zeigen der ersten 256 Bytes des aktuellen Blockes") ;
+ putline ("s --> Zeigen der zweiten 256 Bytes des aktuellen Blockes") ;
+ line ;
+ putline ("e --> Editieren des aktullen Teilblockes") ;
+ putline ("d --> Editieren des ersten und zweiten Teilblockes") ;
+ line ;
+ putline ("p --> Position setzen, auf der der Editor beginnen soll.") ;
+ line ;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
+ line ;
+ putline ("q --> Verlassen des Blockeditor-Menüs (Rückkehr ins Block-Menü)") ;
+END PROCEDURE block editor menue help ;
+
+PROCEDURE space menue help :
+ out (home + cl eop) ;
+ line ;
+ putline ("Help für das Space-Menü : ") ;
+ line ;
+ putline ("r --> Lesen eines Datenraums bzw. eines Headers") ;
+ putline ("R --> Lesen eines Datenraums ab Block x") ;
+ putline ("w --> Schreiben eines Datenraums bzw. eines Headers") ;
+ putline ("W --> Schreiben eines Datenraums ab Block x") ;
+ line ;
+ putline ("e --> Editieren des aktullen Datenraums (Datei o. Header)") ;
+ putline ("E --> Editieren einer neuen Datei oder eines Header") ;
+ line ;
+ putline ("s --> Kopieren des aktuellen Datenraums in eine benannten Datenraum") ;
+ putline ("l --> Kopieren eines benannten Datenraums in den aktuellen Datenraum") ;
+ line ;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
+ putline ("q --> Verlassen des Space-Menüs (Rückkehr ins Global-Menü)") ;
+END PROCEDURE space menue help ;
+
+PROCEDURE archiv menue help :
+ out (home + cl eop) ;
+ line ;
+ putline ("Help für das Archiv-Menü : ") ;
+ line ;
+ putline ("a --> Archiv anmelden") ;
+ putline ("r --> Archiv abmelden") ;
+ line ;
+ putline ("f --> Einige Dateien vom Archiv in die Task laden") ;
+ putline ("s --> Einige Dateien der Task auf das Archiv schreiben") ;
+ putline ("l --> Dateiliste des Archives zeigen") ;
+ line ;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
+ line ;
+ putline ("q --> Verlassen des Archiv-Menüs (Rückkehr ins Global-Menü)") ;
+END PROCEDURE archiv menue help ;
+
+PROCEDURE urflop menue help :
+ out (home + cl eop) ;
+ line ;
+ putline ("Help für das Urflop-Menü : ") ;
+ line ;
+ putline ("r --> Lesen der Blöcke 10 bis 62 in einen benannten Datenraum") ;
+ putline ("R --> Lesen der Blöcke x bis y in einen benannten Datenraum") ;
+ line ;
+ putline ("w --> Schreiben der Blöcke 10 bis 62 aus einem benannten Datenraum") ;
+ putline ("W --> Schreiben der Blöcke x bis y aus einem benannten Datenraum") ;
+ line ;
+ putline ("l --> Dateiliste der Task zeigen (list)") ;
+ line ;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
+ line ;
+ putline ("q --> Verlassen des Urflop-Menüs (Rückkehr ins Global-Menü)") ;
+END PROCEDURE urflop menue help ;
+
+PROCEDURE conf menue help :
+ out (home + cl eop) ;
+ line ;
+ putline ("Help für das Configurator-Menü :") ;
+ line ;
+ putline ("c --> Einstellen des Kanals, auf dem der Block i/o abläuft") ;
+ putline ("t --> Einstellen des Diskettentypes (EUMEL, CPM etc)") ;
+ line ;
+ putline ("i --> Disketteninfo") ;
+ line ;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)") ;
+ line ;
+ putline ("q --> Verlassen des Archiv-Menüs (Rückkehr ins Global-Menü)") ;
+END PROCEDURE conf menue help ;
+
+BOOL PROCEDURE is halt from terminal :
+ is error CAND error code = 1
+END PROCEDURE is halt from terminal ;
+
+PROCEDURE block in (TEXT VAR block, INT CONST block nr, disk type,
+ INT VAR error) :
+ initialize if necessary ;
+ block in (blkinds, heap page nr, disk type, block nr, error) ;
+ block := subtext (bound text, start pos, LENGTH bound text) ;
+END PROCEDURE block in ;
+
+PROCEDURE initialize if necessary :
+ IF NOT initialized (this packet)
+ THEN forget (blkinds) ;
+ blkinds := nilspace ;
+ bound text := blkinds ;
+ bound text := (start pos + 511) * " " ;
+ own command line := "" ;
+ archive channel := std archive channel ;
+ disk type := std disk type
+ END IF .
+END PROCEDURE initialize if necessary ;
+
+BOOL PROCEDURE yes (TEXT CONST msg) :
+ get cursor (cx, cy) ;
+ cursor (command line x pos + 1, command line y pos + 1) ;
+ result := NOT no (msg) ;
+ cursor (cx, cy) ;
+ result .
+END PROCEDURE yes ;
+(*
+INT OPERATOR $ (TEXT CONST hex) :
+ INT VAR laenge := length (hex), stelle, ziffer, ergebnis := 0 ;
+ FOR stelle FROM laenge DOWNTO 1 REPEAT
+ ziffer := pos ("0123456789ABCDEF", hex SUB stelle) - 1 ;
+ IF ziffer < 0
+ THEN error stop ("Ist keine Hexzahl")
+ END IF ;
+ ergebnis INCR ziffer * 16 ** (laenge - stelle)
+ END REPEAT ;
+ ergebnis .
+END OPERATOR $ ;
+*)
+PROCEDURE search (TEXT CONST st, INT CONST start block, end block,
+ INT VAR fbnr, fpos) :
+ enable stop ;
+ INT CONST l := LENGTH st - 1 ;
+ reset ctrl g ;
+ reset block io ;
+ FOR fbnr FROM start block UPTO end block REPEAT
+ cout (fbnr) ;
+ continue (archive channel) ;
+ block in (stb1, fbnr, disk type, error) ;
+ IF error = 0
+ THEN block in (stb2, fbnr + 1, disk type, error)
+ END IF ;
+ break (quiet) ;
+ continue (user channel) ;
+ check archive error (error, true) ;
+ stb1 CAT text (stb2, l) ;
+ UNTIL pos (stb1, st) > 0 COR incharety = ""27"" END REPEAT ;
+ fpos := pos (stb1, st)
+END PROCEDURE search ;
+
+END PACKET byte operations and disk monitor version 35 multi ;
+
diff --git a/app/diskettenmonitor/3.5/src/disk cmd 3.5.quelle b/app/diskettenmonitor/3.5/src/disk cmd 3.5.quelle
new file mode 100644
index 0000000..68de7f5
--- /dev/null
+++ b/app/diskettenmonitor/3.5/src/disk cmd 3.5.quelle
@@ -0,0 +1,36 @@
+
+PACKET disk cmd
+
+(************************************************************************)
+(* *)
+(* Disk - Menuecall Version 3.5 *)
+(* *)
+(* *)
+(* Autor : Ingo Siekmann *)
+(* Stand : Sonntag, den 16.11.1986 *)
+(* *)
+(* Lauffähig ab EUMEL Version 1.7.3 /M und insertiertem *)
+(* Diskmonitor ab Version 3.4 *)
+(* *)
+(* (c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert *)
+(* *)
+(************************************************************************)
+
+ DEFINES disk ,
+ disk monitor :
+
+
+
+lernsequenz auf taste legen ("d", "disk"13"") ;
+
+
+PROCEDURE disk :
+ central disk monitor process .
+END PROCEDURE disk ;
+
+PROCEDURE disk monitor :
+ central disk monitor process .
+END PROCEDURE disk monitor ;
+
+END PACKET disk cmd ;
+
diff --git a/app/diskettenmonitor/3.5/src/m.rename archive^2.c b/app/diskettenmonitor/3.5/src/m.rename archive^2.c
new file mode 100644
index 0000000..445fba5
--- /dev/null
+++ b/app/diskettenmonitor/3.5/src/m.rename archive^2.c
@@ -0,0 +1,3 @@
+PACKETrenamearchivecmdDEFINESrenamearchive:DATASPACE VARds:=nilspace;forget(ds);LET HEADER = STRUCT(TEXTname,date,INTtype,TEXTpass);BOUND HEADER VARheader;INT VARopc;PROCrenamearchive(TEXT CONSTnewname):archive(newname);release(archive);opc:=channel;forget(ds);ds:=nilspace;continue(31);disablestop;rewind;read(ds);break(quiet);enablestop;continue(opc);header:=ds;IFyes("archiv """+header.name+""" in """+newname+""" umbenennen")THENheader.name:=newname;continue(31);disablestop;rewind;write(ds);brea
+k(quiet);enablestop;continue(opc);archive(newname)FI;forget(ds).ENDPROCrenamearchive;ENDPACKETrenamearchivecmd;
+
diff --git a/app/diskettenmonitor/3.5/src/read heap b/app/diskettenmonitor/3.5/src/read heap
new file mode 100644
index 0000000..533e78c
--- /dev/null
+++ b/app/diskettenmonitor/3.5/src/read heap
@@ -0,0 +1,107 @@
+DATASPACE VARd:=nilspace; forget(d);
+BOUND TEXT VAR t;
+INT CONST c := channel;
+LET a = 31;
+INT VAR block, anfang, ende, weiter;
+disablestop;
+exec;
+forget(d);
+break (quiet);
+continue (c);
+
+PROC blockin :
+ block INCR 1;
+ INT VAR error;
+ replace (t, anfang, subtext (t, weiter));
+ blockin (d, 3, 0, block, error);
+ IF error <> 0 THEN
+ errorstop ("Fehlercode "+text (error)+" auf Block "+text(block))
+ FI;
+END PROC blockin;
+
+PROC exec :
+enable stop;
+TEXT VAR zeile := "datei";
+editget (zeile);
+IF exists (zeile) THEN forget (zeile) FI;
+FILE VAR f := sequential file (output, new (zeile));
+forget (d); d := nilspace;
+t := d;
+t := "";
+REP
+ t CAT ""255"";
+ anfang := LENGTH t;
+UNTIL dspages (d) = 2 PER;
+REP
+ ende := LENGTH t;
+ t CAT ""255"";
+UNTIL dspages (d) > 2 PER;
+weiter := LENGTH t;
+t := subtext (t, 1, ende);
+t CAT subtext (t, anfang);
+put (anfang); put (ende); put (weiter); put (LENGTH t);
+put (weiter - anfang); put (LENGTH t - ende); line;
+continue (a);
+control (5, 0, 0, block);
+block := -1;
+blockin;
+block := 406;
+blockin; (* 407 lesen (ans ende) *)
+replace (t, LENGTH t DIV 2, 12352);
+INT VAR p := LENGTH t - 1, o;
+(*
+INT VAR p := pos (t, ""255"", weiter), o;
+IF p <> 0 THEN p := pos (t, ""0"", ""254"", p);
+FI;
+*)
+zeile := "";
+REP
+ naechsten block verarbeiten;
+ blockin;
+ p DECR weiter;
+ p INCR anfang;
+UNTIL block > 1170 PER;
+errorstop ("kein ende gefunden") .
+
+naechsten block verarbeiten :
+ REP
+ IF p < anfang COR p MOD 2 = 0 THEN
+ errorstop ("Fehler bei "+text(block)+", "+text (p - anfang));
+ FI;
+ IF p > ende THEN LEAVE naechsten block verarbeiten FI;
+ continue (c);
+ put (block - 1);
+ put (p -anfang);
+ INT VAR l := t ISUB p DIV 2 + 1;
+ put (l);
+ IF l <= 0 THEN (* continue (c);
+ put (block); put (p - anfang); put (l); *) LEAVE exec
+ FI;
+ put ("");
+ continue (a);
+ p INCR 2;
+ IF p + l - 1 > LENGTH t THEN
+ l INCR LENGTH zeile;
+ zeile CAT subtext (t, p);
+ l DECR LENGTH zeile;
+ replace (t, LENGTH t DIV 2, l);
+ p := LENGTH t - 1;
+ ELSE
+ o := LENGTH zeile;
+ zeile CAT subtext (t, p, p + l - 1);
+ p INCR l;
+ l INCR o;
+ IF LENGTH zeile <> l THEN
+ errorstop ("Laengenfehler bei "+text(block)+", "+text (p - anfang)
+ +", "+text(LENGTH zeile));
+ FI;
+ WHILE (zeile SUB l) = ""255"" REP l DECR 1 PER;
+ zeile := subtext (zeile, 1, l);
+ putline (f, zeile);
+ zeile := "";
+ FI;
+ PER .
+
+END PROC exec;
+
+
diff --git a/app/diskettenmonitor/3.7/source-disk b/app/diskettenmonitor/3.7/source-disk
new file mode 100644
index 0000000..d79c6a7
--- /dev/null
+++ b/app/diskettenmonitor/3.7/source-disk
@@ -0,0 +1 @@
+debug/diskettenmonitor-3.7_1990-04-28.img
diff --git a/app/diskettenmonitor/3.7/src/PAC digit conversion b/app/diskettenmonitor/3.7/src/PAC digit conversion
new file mode 100644
index 0000000..034eccf
--- /dev/null
+++ b/app/diskettenmonitor/3.7/src/PAC digit conversion
@@ -0,0 +1,93 @@
+PACKET digit conversion DEFINES bin,
+ dec,
+ hex :
+
+{ Rechnet Dezimalzahlen in Hexadezimalzahlen um und umgekehrt,
+ sowie Dezimalzahlen in Binärzahlen.
+
+ Autor Version Datum
+ Christian Lehmann 2 07.09.90 }
+
+LET hex letters = "123456789abcdef";
+
+TEXT CONST empty binary digit := 16 * "0",
+ empty hex digit := "0000";
+
+ROW 4 INT CONST sedecimal powers := ROW 4 INT : (1, 16, 256, 4096);
+ROW 16 INT CONST binary powers := ROW 16 INT :
+ ( 1, 2, 4, 8, 16, 32, 64, 128,
+ 256, 512, 1024, 2048, 4096, 8192, 16384, -32767-1);
+
+INT PROC dec (TEXT CONST hex text):
+ INT VAR stellen := LENGTH hex text;
+ IF stellen > 4 COR hex text > "7fff"
+ THEN errorstop ("Zahl zu groß")
+ FI;
+ INT VAR dec result := 0, stelle, hex digit;
+ TEXT VAR hex letter;
+ FOR stelle FROM 1 UPTO stellen REP
+ hex letter := hex text SUB (stellen - stelle + 1);
+ hex digit := pos (hex letters, hex letter);
+ IF hex digit <> 0
+ THEN dec result INCR hex digit * sedecimal powers [stelle]
+ ELIF hex letter <> "0"
+ THEN errorstop ("Hexadezimalzahl fehlerhaft")
+ FI
+ PER;
+ dec result
+END PROC dec;
+{ kann nicht durch `replace' zu Beginn verkleinert werden }
+
+TEXT PROC hex (INT CONST decimal int) :
+ INT VAR nibble no, nibble bit no, bit no := 16, hex digit;
+ TEXT VAR hex result := empty hex digit;
+ FOR nibble no FROM 4 DOWNTO 1 REP
+ hex digit := 0;
+ FOR nibble bit no FROM 4 DOWNTO 1 REP
+ IF (decimal int AND binary powers [bit no]) = binary powers [bit no]
+ THEN hex digit INCR binary powers [nibble bit no]
+ FI;
+ bit no DECR 1
+ PER;
+ IF hex digit <> 0
+ THEN replace (hex result, 5 - nibble no, (hex letters SUB hex digit))
+ FI
+ PER;
+ hex result
+END PROC hex;
+
+TEXT PROC bin (INT CONST dez) :
+ TEXT VAR bin result := empty binary digit;
+ INT VAR bit no;
+ FOR bit no FROM 16 DOWNTO 1 REP
+ IF (dez AND binary powers [bit no]) = binary powers [bit no]
+ THEN replace (bin result, 17 - bit no, "1")
+ FI
+ PER;
+ bin result
+END PROC bin;
+
+END PACKET digit conversion;
+
+(* Test *)
+(*
+
+INT VAR x, y;
+TEXT VAR z;
+page;
+putline ("Dezimalzahl oder Hexadezimalzahl (mit Kleinbuchstaben und `h' am Schluß)");
+putline ("Abbruch durch `0'");
+REP
+ line;
+ get cursor (x, y);
+ put ("Zahl:");
+ get (z);
+ cursor (x + 14, y);
+ put (":");
+ IF (z SUB LENGTH z) = "h"
+ THEN put (dec (subtext (z, 1, LENGTH z - 1)))
+ ELSE put (hex (z))
+ FI
+UNTIL z = "0" PER
+*)
+
diff --git a/app/diskettenmonitor/3.7/src/basic menu handling 3.6.quelle b/app/diskettenmonitor/3.7/src/basic menu handling 3.6.quelle
new file mode 100644
index 0000000..6a02811
--- /dev/null
+++ b/app/diskettenmonitor/3.7/src/basic menu handling 3.6.quelle
@@ -0,0 +1,53 @@
+
+PACKET basic menu handling
+
+(************************************************************************)
+(* *)
+(* Basic Menu Handling Version 1.0 *)
+(* *)
+(* *)
+(* Autor : Ingo Siekmann *)
+(* Stand : Donnerstag, den 12. Juni 1986 *)
+(* *)
+(* Lauffähig ab EUMEL Version 1.7.3 *)
+(* *)
+(* (c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert *)
+(* *)
+(************************************************************************)
+
+ DEFINES menue monitor :
+
+
+
+LET info line x pos = 1 ,
+ info line y pos = 20 ,
+ command line x pos = 1 ,
+ command line y pos = 21 ;
+
+LET first mon line = "----------------------------------------------------------------------------" ,
+ command line = ">__________________________________________________________________________<" ;
+
+
+TEXT VAR char ;
+
+PROCEDURE menue monitor (TEXT CONST info line, chars, (* I. Siekmann *)
+ INT VAR command index) : (* 12.06.1986 *)
+ enable stop ;
+ cursor (1, 17) ;
+ command index := 0 ;
+ out (first mon line) ;
+ cursor (info line x pos, info line y pos) ;
+ out (info line) ;
+ cursor (command line x pos, command line y pos) ;
+ out (command line) ;
+ cursor (command line x pos + 1, command line y pos) ;
+ REPEAT
+ (* inchar (char) ; *)
+ get char (char) ;
+ command index := pos (chars, char)
+ UNTIL command index > 0 COR is error END REPEAT ;
+ out (char) .
+END PROCEDURE menue monitor ;
+
+ENDPACKET basic menu handling ;
+
diff --git a/app/diskettenmonitor/3.7/src/disk 3.7-m.quelle b/app/diskettenmonitor/3.7/src/disk 3.7-m.quelle
new file mode 100644
index 0000000..b4471a6
--- /dev/null
+++ b/app/diskettenmonitor/3.7/src/disk 3.7-m.quelle
@@ -0,0 +1,2218 @@
+(************************************************************************)
+(* *)
+(* DDDD IIIII SSSS K K 3333 666 / M M *)
+(* D D I S K K 3 6 / MM MM *)
+(* D D I SSS KK 333 6666 / M M M M *)
+(* D D I S K K 3 6 6 / M M M *)
+(* DDDD IIIII SSSS K K 3333 O 666 / M M *)
+(* *)
+(************************************************************************)
+(* *)
+(* Diskettenmonitor Version 3.6 Multi *)
+(* *)
+(* Autor : Ingo Siekmann unter freundlicher Mithilfe von Stefan Haase, *)
+(* Nils Ehnert, APu und Frank Lenniger *)
+(* *)
+(* Stand : Montag, den 09. Februar 1987 *)
+(* *)
+(* Lauffähig ab EUMEL Version 1.8.1 /M in Systemtasks *)
+(* *)
+(* *)
+(* (c) 1987 by ULES c/o Ingo Siekmann & Nils Ehnert *)
+(* *)
+(************************************************************************)
+(* *)
+(* Softwareaenderungen und Softwareneuerungen : *)
+(* *)
+(* 03.01.1986 3.3.2.8 : Block- Asciieditor ueberarbeitet, neuer Header- *)
+(* editor (V1.3), Helpfunktion, gib kommando, *)
+(* Fileaccess auch fuer 16-Files *)
+(* 15.01.1986 3.3.2.9 : Vorbereitung fuer den Suchmodus in 3.3.3.0, *)
+(* Notbremse ins globalmenue mit ctrl g, byte ops *)
+(* ueberarbeitet, pic dienste in vorbereitung *)
+(* Headereditor (V1.4) *)
+(* 16.01.1986 : halt from terminal --> ctrl g := true *)
+(* 16.01.1886 3.3.3.0 : Suchmodus ins Blockmenue (TEST), Blockeditor *)
+(* Byteposops fuer Suchmodus einbauen *)
+(* 21.01.1986 : inchar in get char umgewandelt *)
+(* 28.01.1986 : lernmodus eingebaut (???) *)
+(* 31.01.1986 3.3.3.1 : Suchmodus und Lernmodus wieder ausgebaut *)
+(* beim Datenraumschreiben nur belegte Bloecke raus*)
+(* 14.02.1986 3.3.3.2 : Fehler Überarbeitet *)
+(* 20.02.1986 : Suchmodus vorbereitet (2. Versuch ?) *)
+(* 06.03.1986 3.3.3.3 : Suchmodus eingebaut (Test) *)
+(* 10.03.1986 : Softwaretrennung zwischen Single und Multi *)
+(* 12.03.1986 : read next block cmd ins blockmenu eingebaut *)
+(* Fehler überarbeitet, Vorbereitung für besseren *)
+(* Suchmodus *)
+(* 17.03.1986 3.3.3.4 : configurator menü -> einstellen von disk type, *)
+(* i/o channel, disk info. TEXT/HEX search. *)
+(* 02.04.1986 : urflop ops mit versatzops *)
+(* 08.04.1986 : urflop menue mit versatz *)
+(* 30.04.1986 3.3.3.5 : Fehler ueberarbeitet *)
+(* 30.04.1986 3.3.3.6 : lab read/write ins space menue *)
+(* 05.05.1986 3.3.3.7 : hex / dez - get für alles, block editor über- *)
+(* arbeitet, fehler überarbeitet. auslieferung für *)
+(* HRZ ! *)
+(* 06.06.1986 3.4 : Fehler im search und menue monitor behoben *)
+(* 12.06.1986 : Fehler im Space/Header-Menue behoben *)
+(* 16.11.1986 3.5 : Fehler im Urflopmenue behoben *)
+(* 09.02.1987 3.6 : Doktormenu eingebaut *)
+(* 28.04.90 3.7 : Optimierungen CL *)
+(* *)
+(* A C H T U N G : Keine weitere Entwicklung von Version 3 !! *)
+(* *)
+(* Bielefeld, den 08.02.1987 ULES *)
+(* *)
+(* Ingo Siekmann *)
+(* *)
+(* Version disk 3.6/s teilt nur mit, daß es sie nicht gibt ! *)
+(************************************************************************)
+
+PACKET byte operations and disk monitor version 36 multi
+
+ DEFINES WORD, { BYTE in WORD umbenannt cl 8.2.89 }
+ CATHEX, { HEX in CATHEX }
+ CATASCII, { ASCII in CATASCII umbenannt cl 28.04.90 }
+ DECRL,
+ DECRH,
+ INCRL,
+ INCRH,
+ :=,
+ -,
+ +,
+ $,
+ hint,
+ zu byte,
+ lower byte,
+ higher byte,
+ set lower byte,
+ set higher byte,
+ nil byte,
+ put,
+ get,
+
+ block in,
+ block out,
+
+ HEADER,
+ header,
+ nil header,
+ is start header,
+ is end header,
+ is file header,
+ name,
+ date,
+ type,
+ pass,
+ header edit,
+
+ show first,
+ show second,
+ block edit,
+ ascii edit,
+
+ set ctrl g,
+ reset ctrl g,
+
+ set channel,
+ read block,
+ write block,
+ seek space,
+ seek block,
+ read space,
+ write space,
+ check archive error,
+
+ space nr,
+ header nr,
+
+ urlader lesen,
+ urlader schreiben,
+ urlader lesen auf seite,
+ urlader schreiben von seite,
+
+ heap lesen,
+ search,
+ io control,
+
+ central disk monitor process :
+
+
+LET start of volume = 1000,
+ end of volume = 1,
+ file header = 3;
+
+LET global info line = "** GLOBAL : b / s / a / c / u / d / q # stop --> ctrl g, help --> ""?"" **",
+ block info line = "** BLOCK : r / w / e / k / s / n / q # stop --> ctrl g, help --> ""?"" **",
+ search info line = "** SEARCH : a -> ascii / h -> hex / q -> quit / ctrl g -> stop **",
+ editor info line = "** EDITOR : f / s / d / e / k / p / q # stop --> ctrl g, help --> ""?"" **",
+ space info line = "** SPACE : r, R, w, W, e, E, s, l, k, q # stop --> ctrl g, help --> ""?"" **",
+ space header info = "** SPACE / HEADER : s -> read space / h -> read header / q -> quit **",
+ archiv info line = "** ARCHIV : a / r / l / f / s / k / q # stop --> ctrl g, help --> ""?"" **",
+ urflop info line = "** URFLOP : r / R / w / W / l / k / q # stop --> ctrl g, help --> ""?"" **",
+ conf info line = "** CONFIGURATOR : c / t / i / k / q # stop --> ctrl g, help --> ""?"" **",
+ doctor info line = "** DOCTOR : a / e / r / h / k / q # stop --> ctrl g, help --> ""?"" **",
+ first mon line = "̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊̊";
+
+LET global chars = "bsacuqk?d"7"",
+ block chars = "rweqksn?"7"",
+ search chars = "ahdq"7"",
+ editor chars = "fsdeqk?"7"p",
+ space chars = "rRwWesqEkl?"7"",
+ archiv chars = "arlfsqk?"7"",
+ urflop chars = "rRwWlqk?"7"",
+ conf chars = "ctikq?"7"",
+ doctor chars = "aerhkq?"7"";
+
+LET info line x pos = 1,
+ info line y pos = 20,
+ command line x pos = 1,
+ command line y pos = 21,
+ error line x pos = 1,
+ error line y pos = 22,
+
+ file type = 1003,
+ file type 16 = 1002,
+
+ block 0 = 0,
+
+ std archive channel = 31,
+
+ type mode = 1,
+ size mode = 5,
+ std disk type = 0;
+
+LET software stand = "Montag, den 09.02.1987",
+ software version = "Version 3.6 /Multi",
+ software bemerkung = "Doktormenue eingebaut,",
+ software bemerkung1 = "*** Ende der Entwicklung der Version 3 ! ***";
+
+LET eumel 0 start block = 10,
+ eumel 0 end block = 65,
+ eumel 0 end block pic = 62,
+ eumel 0 end block 1758 = 67,
+
+(* pic char table start block = 63,
+ pic char table end block = 65,
+ pic shard start block = 0,
+ pic shard end block = 79, *)
+
+ read write impossible error = 101,
+ read error = 102,
+ write error = 103,
+ block number error = 104,
+ undef archive error = 105;
+
+LET ibm 720 format 5 = 1440,
+ ibm 360 format 5 = 720,
+ pic 400 format 5 = 1600,
+ soft sd 8 = 1232,
+ soft dd 8 = 2464,
+ hard ss sd = 616,
+ hard ds sd = 1232;
+
+LET home = ""1"",
+ left = ""8"",
+ right = ""2"",
+ up = ""3"",
+ down = ""10"",
+ return = ""13"",
+ tab = ""9"",
+ esc = ""27"",
+ cl eol = ""5"",
+ cl eop = ""4"";
+
+LET hex chars = "0123456789ABCDEF",
+ hex marker = "h";
+
+LET start pos = 479,
+ heap page nr = 2;
+
+TYPE HEADER = STRUCT (TEXT name, date, INT type, TEXT pass);
+TYPE WORD = STRUCT (INT lower byte, higher byte);
+
+HEADER CONST nil header := HEADER : ("", "", 0, "");
+BOUND HEADER VAR bound header;
+BOUND TEXT VAR bound text;
+
+INITFLAG VAR this packet := false;
+
+ROW 256 WORD VAR block;
+ROW 32 TEXT VAR text block;
+ROW 256 INT VAR block int;
+
+DATASPACE VAR ds :: nilspace; forget (ds);
+DATASPACE VAR afds :: nilspace; forget (afds);
+DATASPACE VAR lds :: nilspace; forget (lds);
+DATASPACE VAR uds :: nilspace; forget (uds);
+DATASPACE VAR blkinds :: nilspace; forget (blkinds);
+
+FILE VAR af, f, lf;
+
+INT VAR command index, block nummer, space nummer, x, y, i, i1, xx, yy,
+ archive channel := std archive channel, user channel, error answer,
+ header nummer, first sp block, integer, error, block nr,
+ stpos, s, e, fb, fp, cx, cy, disk type := std disk type, ver, last file;
+
+TEXT VAR tc, t, archive name, dummy,
+ stb1, stb2, own command line;
+
+REAL VAR po;
+
+BOOL VAR first := true, ende, list file ok, block shown, ctrl g, result;
+
+
+(********************** PACKET bytes ok : ****************************)
+
+WORD PROC nil byte :
+ WORD : (0,0)
+END PROC nil byte;
+
+OP := (WORD VAR byte, WORD CONST old byte) :
+ byte.lower byte := old byte.lower byte;
+ byte.higher byte := old byte.higher byte.
+END OP :=;
+
+OP := (WORD VAR byte, INT CONST int byte) :
+ byte.lower byte := int byte MOD 256;
+ byte.higher byte := (int byte AND -256) DIV 256 AND 255.
+END OP :=;
+
+OP := (ROW 256 WORD VAR byte, ROW 256 INT CONST int byte) :
+ INT VAR i;
+ FOR i FROM 1 UPTO 256 REP
+ byte [i] := int byte [i]
+ PER.
+END OP :=;
+
+OP := (ROW 256 INT VAR int byte, ROW 256 WORD CONST byte) :
+ INT VAR i;
+ FOR i FROM 1 UPTO 256 REP
+ int byte [i] := byte [i]
+ PER.
+END OP :=;
+
+WORD OP + (WORD VAR byte, INT CONST int byte) :
+ byte.lower byte := byte.lower byte + lower byte (int byte);
+ byte.higher byte := byte.higher byte + higher byte (int byte);
+ byte.
+END OP +;
+
+WORD OP - (WORD VAR byte, INT CONST int byte) :
+ byte.lower byte := byte.lower byte - lower byte (int byte);
+ byte.higher byte := byte.higher byte - higher byte (int byte);
+ byte.
+END OP -;
+
+OP := (INT VAR int byte, WORD CONST byte) :
+ IF byte.higher byte > 127
+ THEN int byte := minus * 255 + minus + byte.lower byte
+ ELSE int byte := byte.higher byte * 256 + byte.lower byte
+ FI
+
+.minus : byte.higher byte - 256.
+END OP :=;
+
+OP INCRL (WORD VAR byte, INT CONST lower) :
+ byte.lower byte INCR lower
+END OP INCRL;
+
+OP INCRH (WORD VAR byte, INT CONST high) :
+ byte.higher byte INCR high
+END OP INCRH;
+
+OP DECRL (WORD VAR byte, INT CONST lower) :
+ byte.higher byte DECR lower
+END OP DECRL;
+
+OP DECRH (WORD VAR byte, INT CONST high) :
+ byte.higher byte DECR high
+END OP DECRH;
+
+INT PROC lower byte (WORD CONST byte) :
+ byte.lower byte.
+END PROC lower byte;
+
+INT PROC higher byte (WORD CONST byte) :
+ byte.higher byte.
+END PROC higher byte;
+
+INT PROC lower byte (INT CONST int byte) :
+ int byte MOD 256.
+END PROC lower byte;
+
+INT PROC higher byte (INT CONST int byte) :
+ (int byte AND -256) DIV 256 AND 255.
+END PROC higher byte;
+
+PROC set lower byte (WORD VAR byte, INT CONST lower byte) :
+ byte.lower byte := lower byte
+END PROC set lower byte;
+
+PROC set higher byte (WORD VAR byte, INT CONST higher byte) :
+ byte.higher byte := higher byte
+END PROC set higher byte;
+
+OP CATHEX (TEXT VAR insert line, WORD CONST byte) :
+ insert line CAT (hex chars SUB (byte.lower byte DIV 16 + 1));
+ insert line CAT (hex chars SUB (byte.lower byte MOD 16 + 1));
+ insert line CAT " ";
+ insert line CAT (hex chars SUB (byte.higher byte DIV 16 + 1));
+ insert line CAT (hex chars SUB (byte.higher byte MOD 16 + 1));
+ insert line CAT " ".
+END OP CATHEX;
+
+OP CATASCII (TEXT VAR insert line, WORD CONST byte) :
+ insert line CAT ascii (byte.lower byte );
+ insert line CAT ascii (byte.higher byte).
+END OP CATASCII;
+
+TEXT PROC ascii (INT CONST half byte) :
+(*IF half byte > 31 AND half byte < 127 COR
+ half byte > 213 AND half byte < 219 COR
+ half byte = 251 8.2.89 cl *)
+ IF half byte > 18 CAND half byte < 255
+ THEN code (half byte)
+ ELSE "."
+ FI.
+END PROC ascii;
+
+PROC block in (ROW 256 WORD VAR block bytes, INT CONST type, block nr) :
+ ROW 256 INT VAR block;
+ reset block io;
+ block in (block, type, block nr, error answer);
+ block bytes := block;
+ check archive error (error answer, true).
+END PROC block in;
+
+PROC block out (ROW 256 WORD CONST bytes, INT CONST disk type, block nr) :
+ ROW 256 INT VAR int bytes := bytes;
+ reset block io;
+ block out (int bytes, disk type, block nr, error answer);
+ check archive error (error answer, true).
+END PROC block out;
+
+PROC put (WORD CONST byte) :
+ put ("LOW :");
+ put (text (byte.lower byte));
+ put ("HIGH :");
+ put (text (byte.higher byte))
+END PROC put;
+
+PROC get (WORD VAR byte) :
+ get (integer);
+ byte := integer.
+END PROC get;
+
+PROC zu byte (ROW 256 WORD VAR bytes, TEXT CONST byte kette, INT CONST stelle) :
+ INT VAR lower, higher;
+ lower := pos (hex chars, (byte kette SUB 1)) * 16 +
+ pos (hex chars, (byte kette SUB 2)) - 17;
+ higher:= pos (hex chars, (byte kette SUB 4)) * 16 +
+ pos (hex chars, (byte kette SUB 5)) - 17;
+ IF higher > 127
+ THEN bytes [stelle] := minus * 255 + minus + lower
+ ELSE bytes [stelle] := higher * 256 + lower
+ FI.
+
+minus : higher - 256.
+END PROC zu byte;
+
+WORD OP $ (TEXT CONST hex) :
+ TEXT VAR byte kette :: "";
+ FOR i FROM 1 UPTO 4 REP
+ IF (hex SUB i) = ""
+ THEN byte kette CAT "0"
+ ELIF (hex SUB i) <> " "
+ THEN byte kette CAT (hex SUB i)
+ FI;
+ PER;
+ WORD VAR byte;
+ INT VAR lower, higher, i;
+ lower := pos (hex chars, (byte kette SUB 1)) * 16 +
+ pos (hex chars, (byte kette SUB 2)) - 17;
+ higher:= pos (hex chars, (byte kette SUB 3)) * 16 +
+ pos (hex chars, (byte kette SUB 4)) - 17;
+ IF higher > 127
+ THEN byte := minus * 255 + minus + lower
+ ELSE byte := higher * 256 + lower
+ FI;
+ byte.
+
+minus : higher - 256.
+END OP $;
+
+INT PROC hint (TEXT CONST he) :
+ INT VAR laenge :: length (he),
+ stelle,
+ ziffer,
+ ergebnis :: 0;
+
+ TEXT VAR h :: he;
+
+ FOR stelle FROM 65 UPTO 70 REP
+ change all (h, code (stelle + 32), code (stelle))
+ PER;
+
+ FOR stelle FROM laenge DOWNTO 1 REP
+ ziffer := pos ("0123456789ABCDEF", h SUB stelle) - 1;
+ IF ziffer < 0
+ THEN errorstop ("Unerlaubtes Zeichen in Hexadezimalzahl")
+ FI;
+ ergebnis INCR ziffer * 16 ** (laenge - stelle)
+ PER;
+ ergebnis
+END PROC hint;
+
+
+(********************** PACKET header operations ***************************)
+
+OP := (HEADER VAR dest, HEADER CONST source) :
+ CONCR (dest) := CONCR (source).
+END OP :=;
+
+HEADER PROC header (TEXT CONST name, date, INT CONST type, TEXT CONST pass) :
+ HEADER : (name, date, type, pass).
+END PROC header;
+
+BOOL PROC is start header (HEADER CONST header) :
+ CONCR (header).type = start of volume.
+END PROC is start header;
+
+BOOL PROC is end header (HEADER CONST header) :
+ CONCR (header).type = end of volume.
+END PROC is end header;
+
+BOOL PROC is file header (HEADER CONST header) :
+ CONCR (header).type = file header.
+END PROC is file header;
+
+PROC name (HEADER VAR header, TEXT CONST new name) :
+ CONCR (header).name := new name.
+END PROC name;
+
+TEXT PROC name (HEADER CONST header) :
+ CONCR (header).name.
+END PROC name;
+
+PROC date (HEADER VAR header, TEXT CONST new date) :
+ CONCR (header).date := new date.
+END PROC date;
+
+TEXT PROC date (HEADER CONST header) :
+ CONCR (header).date.
+END PROC date;
+
+PROC type (HEADER VAR header, INT CONST new type) :
+ CONCR (header).type := new type.
+END PROC type;
+
+INT PROC type (HEADER CONST header) :
+ CONCR (header).type.
+END PROC type;
+
+PROC pass (HEADER VAR header, TEXT CONST new pass) :
+ CONCR (header).pass := new pass.
+END PROC pass;
+
+TEXT PROC pass (HEADER CONST header) :
+ CONCR (header).pass.
+END PROC pass;
+
+
+(********************** Header-Editor V1.4 ****************************)
+
+PROC header edit (HEADER VAR header, TEXT CONST msg) :
+ TEXT VAR head :: ""15"HEADER - EDITOR V1.4" + (25 - LENGTH msg) * "." + msg +
+ 5 * "." + " "14"";
+ disable stop;
+ REP
+ out (home);
+ out (16 * (cl eol + down));
+ cursor (6, 6);
+ putline (head);
+ cursor (6, 7);
+ put (""15"TEXT name : "14"");
+ edit get (CONCR (header).name, max text length, 38);
+ IF is error
+ THEN clear error;
+ CONCR (header).name := "";
+ cursor (6, 7);
+ put (""15"TEXT name : "14"");
+ edit get (CONCR (header).name, max text length, 38)
+ FI;
+ cursor (6, 8);
+ put (""15"TEXT date : "14"");
+ edit get (CONCR (header).date, max text length, 38);
+ IF is error
+ THEN clear error;
+ CONCR (header).date := "";
+ cursor (6, 8);
+ put (""15"TEXT date : "14"");
+ edit get (CONCR (header).date, max text length, 38)
+ FI;
+ cursor (6, 9);
+ put (""15"INT type : "14"");
+ TEXT VAR d :: text (CONCR (header).type);
+ edit get (d, max text length, 38);
+ CONCR (header).type := int (d);
+ cursor (6, 10);
+ put (""15"TEXT pass : "14"");
+ edit get (CONCR (header).pass, max text length, 38);
+ IF is error
+ THEN clear error;
+ CONCR (header).pass := "";
+ cursor (6, 10);
+ put (""15"TEXT pass : "14"");
+ edit get (CONCR (header).pass, max text length, 38)
+ FI;
+ cursor (6, 13);
+ UNTIL NOT no (""15"header ok. "14"") PER
+END PROC header edit;
+
+
+(********************** PACKET block editor ****************************)
+
+PROC show first (ROW 256 WORD CONST block) :
+ out (home);
+ po := 1.0;
+ first := true;
+ FOR i FROM 1 UPTO 16 REP
+ text block [i] := text ((i - 1) * 16, 4);
+ text block [i] CAT " � ";
+(* get cursor (x, y); *)
+ FOR i1 FROM 1 UPTO 8 REP
+ text block [i] CATHEX block [(i-1) * 8 + i1]
+ PER;
+ text block [i] CAT " �";
+ FOR i1 FROM 1 UPTO 8 REP
+ text block [i] CATASCII block [(i - 1) * 8 + i1]
+ PER;
+ text block [i] CAT "�";
+(* cursor (x, y); *)
+ putline (text block [i])
+ PER.
+END PROC show first;
+
+PROC show second (ROW 256 WORD CONST block) :
+ out (home);
+ po := 129.0;
+ first := false;
+ FOR i FROM 17 UPTO 32 REP
+ text block [i] := text ((i - 1) * 16, 4);
+ text block [i] CAT " � ";
+(* get cursor (x,y); *)
+ FOR i1 FROM 1 UPTO 8 REP
+ text block [i] CATHEX block [(i - 1) * 8 + i1]
+ PER;
+ text block [i] CAT " �";
+ FOR i1 FROM 1 UPTO 8 REP
+ text block [i] CATASCII block [(i - 1) * 8 + i1]
+ PER;
+ text block [i] CAT "�";
+(* cursor (x, y); *)
+ putline (text block [i])
+ PER.
+END PROC show second;
+
+PROC block edit (ROW 256 WORD VAR block, INT CONST st) :
+ IF st > 0
+ THEN IF st > 255
+ THEN push (255 * right)
+ ELSE push (st * right)
+ FI
+ FI;
+ BOOL VAR low :: TRUE;
+ edit info;
+ cursor (8, 1);
+(* get cursor (x, y); *)
+ po := 1.0;
+ REP
+ get cursor (x, y);
+ cursor (x, y);
+ (* inchar (t); *)
+ get char (t);
+ IF (t = right OR t = " ") AND x < 53
+ THEN cursor (x + 3, y); po INCR 0.5
+ ELIF (t = right OR t = " ") AND x > 52 AND y < 16
+ THEN cursor (8, y + 1); po INCR 0.5
+ ELIF t = up AND y > 1
+ THEN cursor (x, y - 1); po DECR 8.0
+ ELIF t = left AND x > 8
+ THEN cursor (x - 3, y); po DECR 0.5
+ ELIF t = left AND x = 8 AND y <> 1
+ THEN cursor (53, y - 1); po DECR 0.5
+ ELIF t = down AND y < 16
+ THEN cursor (x, y + 1); po INCR 8.0
+ ELIF t = tab
+ THEN IF first
+ THEN show first (block)
+ ELSE show second (block)
+ FI;
+ ascii edit (block, first);
+ IF first
+ THEN show first (block)
+ ELSE show second (block)
+ FI;
+ IF t <> return
+ THEN edit info;
+ cursor (8, 1);
+ FI
+ ELIF t = ""7""
+ THEN set ctrl g
+ FI;
+ get cursor (x, y);
+ cursor (x, y);
+ IF code (t) > 47 AND code (t) < 58 OR
+ code (t) > 96 AND code (t) < 103
+ THEN IF code (t) > 96 CAND code (t) < 103
+ THEN t := code (code (t) - 32)
+ FI;
+ out (left + "-" + 2 * right + "-" + 3 * left + t);
+ REP
+ (* inchar (tc); *)
+ get char (tc);
+ UNTIL code (tc) > 47 AND code (tc) < 58 OR
+ code (tc) > 96 AND code (tc) < 103 PER;
+ IF code (tc) > 96 CAND code (tc) < 103
+ THEN tc := code (code (tc) - 32)
+ FI;
+ out (tc + " " + 4 * left + " ");
+ cursor (x, y);
+ t CAT tc;
+ INT VAR bp :: int (po);
+ IF po MOD real (bp) = 0.0
+ THEN low := TRUE
+ ELSE low := FALSE
+ FI;
+ IF NOT first (* ONE : 17.06.85 *)
+ THEN bp INCR 128
+ FI;
+ IF low
+ THEN set lower byte (block [bp], hint (t))
+ ELSE set higher byte (block [bp], hint (t))
+ FI;
+ FI;
+ info;
+ UNTIL t = return COR ctrl g PER;
+ IF first
+ THEN show first (block)
+ ELSE show second (block)
+ FI;
+ cursor (1, 17).
+
+info :
+ get cursor (x, y);
+ cursor (xx, yy);
+ IF po MOD real (int(po)) = 0.0
+ THEN put ("LOW")
+ ELSE put ("HIGH")
+ FI;
+ cursor (x,y).
+
+edit info :
+ cursor (1, 23);
+ put (cl eol + "Block-Editor : Hexmodus,");
+ IF first
+ THEN put ("First Block")
+ ELSE put ("Second Block")
+ FI;
+ put (",");
+ get cursor (xx, yy).
+END PROC block edit;
+
+PROC ascii edit (ROW 256 WORD VAR block, BOOL CONST first) :
+ edit info;
+ cursor (59, 1);
+ x := 1;
+ y := 1;
+ po := 1.0;
+ REP
+ get char (t);
+ IF po < 1.0 AND first
+ THEN po := 1.0
+ FI;
+ IF po < 129.0 AND NOT first
+ THEN po := 129.0
+ FI;
+ IF po > 128.5 AND first
+ THEN po := 128.5
+ FI;
+ IF po > 256.5 AND NOT first
+ THEN po := 256.5
+ FI;
+ SELECT pos (""9""8""2""3""10""13""7"", t) OF
+ CASE 1, 6 : quit ascii edit
+ CASE 2 : IF x > 1 COR (x = 1 AND y > 1)
+ THEN x DECR 1; po DECR 0.5
+ FI
+ CASE 3 : IF x < 16 COR (x = 16 AND y <> 16)
+ THEN x INCR 1; po INCR 0.5
+ FI
+ CASE 4 : IF y > 1
+ THEN y DECR 1;
+ po DECR 8.0
+ FI
+ CASE 5 : IF y < 16
+ THEN y INCR 1;
+ po INCR 8.0
+ FI
+ CASE 7 : set ctrl g
+ OTHERWISE IF code (t) >= 32 AND code (t) <= 126
+ THEN set char; push (""2"")
+ FI
+ END SELECT;
+ IF x < 1 AND y = 1
+ THEN x := 1
+ ELIF x < 1 AND y > 1
+ THEN x := 16;
+ y DECR 1
+ ELIF x > 16 AND y = 16
+ THEN x := 16;
+ ELIF x > 16 AND y < 16
+ THEN x := 1;
+ y INCR 1
+ ELIF y < 1
+ THEN y := 1
+ ELIF y > 16
+ THEN y := 16
+ FI;
+ info;
+ UNTIL ctrl g PER.
+
+quit ascii edit :
+ x := 8;
+ y := 1;
+ cursor (x, y);
+ po := 1.0;
+ LEAVE ascii edit.
+
+set char :
+ out (t);
+ INT VAR bp :: int (po);
+ IF x MOD 2 = 0
+ THEN set higher byte (block [bp], code (t))
+ ELSE set lower byte (block [bp], code (t))
+ FI.
+
+info :
+ cursor (xx, yy);
+ IF po MOD real (int (po)) = 0.0
+ THEN put ("LOW")
+ ELSE put ("HIGH")
+ FI;
+ cursor (58 + x, y).
+
+edit info :
+ cursor (1, 23);
+ put (""5"Block-Editor : Asciimodus,");
+ IF first
+ THEN put ("First Block")
+ ELSE put ("Second Block")
+ FI;
+ put (",");
+ get cursor (xx, yy).
+END PROC ascii edit;
+
+
+(********************** PACKET block i/o : ****************************)
+
+PROC set channel (INT CONST channel) :
+ archive channel := channel.
+END PROC set channel;
+
+PROC read block (ROW 256 WORD VAR block byte, INT CONST block nummer) :
+ user channel := channel;
+ enable stop;
+ continue (archive channel);
+ disable stop;
+ block in (block int, disk type, block nummer, error answer);
+ IF is error
+ THEN clear error
+ FI;
+ break (quiet);
+ continue (user channel);
+ enable stop;
+ check archive error (error answer, true);
+ block byte := block int.
+END PROC read block;
+
+PROC write block (ROW 256 WORD VAR block byte, INT CONST block nummer) :
+ user channel := channel;
+ enable stop;
+ block int := block byte;
+ continue (archive channel);
+ disable stop;
+ block out (block int, disk type, block nummer, error answer);
+ IF is error
+ THEN clear error
+ FI;
+ break (quiet);
+ continue (user channel);
+ enable stop;
+ check archive error (error answer, false).
+END PROC write block;
+
+PROC read block (ROW 256 INT VAR block int, INT CONST block nummer) :
+ user channel := channel;
+ enable stop;
+ continue (archive channel);
+ disable stop;
+ block in (block int, disk type, block nummer, error answer);
+ IF is error
+ THEN clear error
+ FI;
+ break (quiet);
+ continue (user channel);
+ enable stop;
+ check archive error (error answer, true).
+END PROC read block;
+
+PROC write block (ROW 256 INT VAR block int, INT CONST block nummer) :
+ user channel := channel;
+ enable stop;
+ continue (archive channel);
+ disable stop;
+ block out (block int, disk type, block nummer, error answer);
+ IF is error
+ THEN clear error
+ FI;
+ break (quiet);
+ continue (user channel);
+ enable stop;
+ check archive error (error answer, false).
+END PROC write block;
+
+
+(********************** PACKET space i/o : ****************************)
+
+PROC seek space (INT CONST space) :
+ user channel := channel;
+ enable stop;
+ rewind;
+ INT VAR i;
+ continue (archive channel);
+ disable stop;
+ FOR i FROM 1 UPTO space REP
+ skip dataspace
+ UNTIL is error PER;
+ break (quiet);
+ continue (user channel).
+END PROC seek space;
+
+PROC seek block (INT CONST block nr) :
+ seek (block nr).
+END PROC seek block;
+
+PROC read space (DATASPACE VAR ds) :
+ user channel := channel;
+ enable stop;
+ continue (archive channel);
+ disable stop;
+ read (ds);
+ break (quiet);
+ continue (user channel).
+END PROC read space;
+
+PROC read space (DATASPACE VAR ds, INT VAR max pages,
+ BOOL CONST errors) :
+ user channel := channel;
+ enable stop;
+ continue (archive channel);
+ disable stop;
+ read (ds, max pages, errors);
+ break (quiet);
+ continue (user channel).
+END PROC read space;
+
+PROC write space (DATASPACE CONST ds) :
+ user channel := channel;
+ enable stop;
+ continue (archive channel);
+ disable stop;
+ write (ds);
+ break (quiet);
+ continue (user channel).
+END PROC write space;
+
+PROC check archive error (INT CONST code, BOOL CONST read) :
+ enable stop;
+ IF read
+ THEN SELECT code OF
+ CASE 0 :
+ CASE 1 : error stop (read write impossible error,
+ "Lesen unmoeglich (1)")
+ CASE 2 : error stop (read error,
+ "Lesefehler (2)")
+ CASE 3 : error stop (block number error,
+ "Blocknummer zu hoch (3)")
+ OTHERWISE error stop (undef archive error,
+ "Archivfehler unbekannt ("+ text (code) +")")
+ END SELECT
+ ELSE SELECT code OF
+ CASE 0 :
+ CASE 1 : error stop (read write impossible error,
+ "Schreiben unmoeglich (1)")
+ CASE 2 : error stop (write error,
+ "Schreibfehler (2)")
+ CASE 3 : error stop (block number error,
+ "Blocknummer zu hoch (3)")
+ OTHERWISE error stop (undef archive error,
+ "Archivfehler unbekannt ("+ text (code) +")")
+ END SELECT
+ FI.
+END PROC check archive error;
+
+
+(********************** PACKET menue monitor : ****************************)
+
+PROC fehler behandeln :
+ IF is error CAND error message <> ""
+ THEN IF is halt from terminal
+ THEN set ctrl g
+ ELSE cursor (error line x pos, error line y pos);
+ clear error;
+ put (cl eol +"Fehler : "+ error message)
+ FI
+ FI.
+END PROC fehler behandeln;
+
+PROC set ctrl g :
+ ctrl g := true.
+END PROC set ctrl g;
+
+PROC reset ctrl g :
+ ctrl g := false.
+END PROC reset ctrl g;
+
+PROC fehler loeschen :
+ INT VAR x, y;
+ get cursor (x, y);
+ cursor (1, 22);
+ out (cl eol);
+ cursor (1, 18);
+ out (cl eol);
+ cursor (1, 23);
+ out (cl eol);
+ cursor (x, y).
+END PROC fehler loeschen;
+
+
+(********************** Global-Menue ****************************)
+
+PROC global menue :
+ ende := false;
+ user channel := channel;
+ disable stop;
+ REP
+ menue monitor (global info line, global chars, command index);
+ fehler loeschen;
+ SELECT command index OF
+ CASE 1 : block menue
+ CASE 2 : space menue
+ CASE 3 : archive menue
+ CASE 4 : configurator menue
+ CASE 5 : urflop menue
+ CASE 6 : out ("uit");ende := true;
+ CASE 7 : get and do one command; block shown := false
+ CASE 8 : global menue help; block shown := false
+ CASE 9 : doctor menue
+ CASE 10 : set ctrl g
+ END SELECT;
+ fehler behandeln;
+ UNTIL ende COR ctrl g PER;
+ reset ctrl g;
+ ende := false.
+END PROC global menue;
+
+PROC doctor menue :
+ DATASPACE VAR head ds := nilspace; forget (head ds);
+ BOUND HEADER VAR head;
+ TEXT VAR new archive name;
+ disable stop;
+ REP
+ menue monitor (doctor info line, doctor chars, command index);
+ fehler loeschen;
+ SELECT command index OF
+ CASE 1 : neuer archiv start header
+ CASE 2 : neuer archiv end header
+ CASE 3 : rette eine datei
+ CASE 4 : heap auslutschen
+ CASE 5 : get and do one command; block shown := false
+ CASE 6 : LEAVE doctor menue
+ CASE 7 : doctor menue help; block shown := false
+ CASE 8 : set ctrl g
+ END SELECT;
+ fehler behandeln;
+ UNTIL ende COR ctrl g PER.
+
+neuer archiv start header :
+ cursor (2, 21);
+ forget (head ds);
+ head ds := nilspace;
+ head := head ds;
+ out ("gib neuen Archivnamen : ");
+ getline (new archive name);
+ head := nil header;
+ name (head, new archive name);
+ type (head, 1000);
+ date (head, "0.0");
+ seek space (0);
+ write space (head ds).
+
+neuer archiv end header :
+ cursor (2, 21);
+ forget (head ds);
+ head ds := nilspace;
+ head := head ds;
+ out ("Nach der wievielten Datei soll das Ende geschrieben werden : ");
+ get (last file);
+ name (head, "");
+ date (head, "");
+ type (head, 1);
+ pass (head, "");
+ cursor (1, 22); out (""5"");
+ IF yes ("Neues Archivende nach der "+ text (last file) +
+ " Datei schreiben")
+ THEN seek space ((last file * 2) + 1);
+ write space (head ds)
+ FI.
+
+rette eine datei :
+ cursor (2, 21);
+ out ("Die wievielte Datei soll gerettet werden : ");
+ get (filenr);
+ seek space (file nr * 2);
+ forget (head ds);
+ head ds := nilspace;
+ read space (head ds);
+ rename file.
+
+rename file :
+ TEXT VAR new name := "";
+ IF type (head ds) = 1003
+ THEN f := sequential file (input, head ds);
+ new name := head line (f);
+ close (f);
+ IF no ("soll die gerettete Datei """+ new name +""" heissen")
+ THEN get command ("gib Dateinamen :", new name)
+ FI;
+ ELSE IF yes ("soll die Datei einen bestimmten Namen bekommen")
+ THEN get command ("gib Dateinamen :", new name)
+ FI
+ FI;
+ copy (head ds, new name).
+
+heap auslutschen :
+ INT VAR h start, h end, file nr;
+ TEXT VAR h dat;
+ cursor (2, 21);
+ out ("Heap lesen ab Block : ");
+ get (h start);
+ cursor (2, 21);
+ out ("Heap lesen ab Block "); put (h start); put ("bis Block :");
+ get (h end);
+ cursor (1, 22);
+ out ("in Datei : ");
+ getline (h dat);
+ cursor (60, 22);
+ out ("Block : ");
+ heap lesen (h start, h end, archive channel, h dat).
+
+END PROC doctor menue;
+
+
+(********************** Block-Menue ****************************)
+
+PROC block menue :
+ disable stop;
+ REP
+ menue monitor (block info line, block chars, command index);
+ fehler loeschen;
+ SELECT command index OF
+ CASE 1 : read one block
+ CASE 2 : write one block
+ CASE 3 : edit block menue
+ CASE 4 : LEAVE block menue
+ CASE 5 : get and do one command
+ CASE 6 : search menue
+ CASE 7 : read next block
+ CASE 8 : block menue help; block shown := false
+ CASE 9 : set ctrl g
+ END SELECT;
+ show first three ints;
+ display info line;
+ fehler behandeln
+ UNTIL ctrl g PER.
+
+read one block :
+ out ("ead Block : ");
+ x get (block nummer);
+ IF NOT is error
+ THEN reset block io;
+ read block (block, block nummer)
+ FI;
+ IF NOT is error
+ THEN show first (block); block shown := true
+ FI.
+
+write one block :
+ out ("rite");
+ IF yes ("write auf Block "+ text (block nummer))
+ THEN reset block io;
+ write block (block, block nummer)
+ ELIF yes ("write auf einen anderen Block")
+ THEN out (" auf Block : ");
+ x get (block nummer);
+ IF NOT is error
+ THEN reset block io;
+ write block (block, block nummer)
+ FI
+ FI.
+
+read next block :
+ put (""8"read Block :");
+ block nummer INCR 1;
+ out (text (block nummer));
+ reset block io;
+ read block (block, block nummer);
+ IF NOT is error
+ THEN show first (block); block shown := true
+ FI.
+
+END PROC block menue;
+
+
+(********************** Search-Menue ****************************)
+
+PROC search menue :
+ disable stop;
+ menue monitor (search info line, search chars, command index);
+ fehler loeschen;
+ SELECT command index OF
+ CASE 1 : ascii search
+ CASE 2 : hex search
+ CASE 3 : dez search
+ CASE 4 : LEAVE search menue
+ CASE 5 : set ctrl g
+ END SELECT;
+ display info line;
+ fehler behandeln.
+
+ascii search :
+ cursor (command line x pos + 1, command line y pos);
+ put ("Suchtext :"); getline (t);
+ cursor (command line x pos + 1, command line y pos);
+ put ("suchen nach """+ t +""" von Block :");
+ x get (s);
+ cursor (command line x pos + 1, command line y pos);
+ put ("suchen nach """+ t +""" von Block");
+ put (s); put ("bis Block :"); x get (e);
+ search (t, s, e, fb, fp);
+ out (""13"");
+ IF fp > 0
+ THEN put (cl eol +"Gefunden auf Block"); put (fb);
+ put (", Position"); put (fp);
+ read block (block, fb);
+ IF fp < 256
+ THEN show first (block)
+ ELSE show second (block)
+ FI;
+ block shown := true;
+ st pos := (fp MOD 256) - 1;
+ block nummer := fb;
+ ELSE put ("Nicht gefunden !!");
+ FI.
+
+hex search :
+ cursor (command line x pos + 1, command line y pos);
+ put ("Suchhex :"); getline (t);
+ cursor (command line x pos + 1, command line y pos);
+ put ("suchen nach """+ t +""" von Block :");
+ x get (s);
+ cursor (command line x pos + 1, command line y pos);
+ put ("suchen nach """+ t +""" von Block");
+ put (s); put ("bis Block :"); x get (e);
+ change all (t, " ", "");
+ TEXT VAR such hex := "";
+ i := 1;
+ REP
+ such hex CAT code (hint (subtext (t, i, i + 1)));
+ i INCR 2
+ UNTIL i >= length (t) PER;
+ search (such hex, s, e, fb, fp);
+ out (""13"");
+ IF fp > 0
+ THEN put (cl eol +"Gefunden auf Block"); put (fb);
+ put (", Position"); put (fp);
+ read block (block, fb);
+ IF fp < 256
+ THEN show first (block)
+ ELSE show second (block)
+ FI;
+ block shown := true;
+ st pos := (fp MOD 256) - 1;
+ block nummer := fb;
+ ELSE put ("Nicht gefunden !!");
+ FI.
+
+dez search :
+ error stop ("gibt es noch nicht !").
+END PROC search menue;
+
+
+(********************** Block-Editor-Menue ****************************)
+
+PROC edit block menue :
+ INT VAR command index;
+ disable stop;
+ REP
+ fehler loeschen;
+ show first three ints;
+ menue monitor (editor info line, editor chars, command index);
+ SELECT command index OF
+ CASE 1 : out ("irst");
+ show first (block);
+ block shown := true
+ CASE 2 : out ("econd");
+ show second (block);
+ block shown := true
+ CASE 3 : out ("ump");
+ show first (block); block edit (block, stpos);
+ show second (block); block edit (block, stpos);
+ block shown := true;
+ CASE 4 : IF NOT block shown
+ THEN IF first
+ THEN show first (block)
+ ELSE show second (block)
+ FI;
+ block shown := true
+ FI;
+ (* IF first AND stpos >= 256
+ THEN show second (block);
+ block shown := true
+ ELIF NOT first AND stpos <= 256
+ THEN show first (block);
+ block shown := true
+ FI; *) (* ??? *)
+ block edit (block, stpos)
+ CASE 5 : LEAVE edit block menue
+ CASE 6 : get and do one command; block shown := false
+ CASE 7 : block editor menue help; block shown := false
+ CASE 8 : set ctrl g
+ CASE 9 : INT VAR old st pos := st pos;
+ out ("os auf Byte : ");
+ x get (st pos);
+ IF st pos < 0 OR st pos > 513
+ THEN st pos := old st pos;
+ error stop ("Zahl nicht ok")
+ FI
+ END SELECT;
+ fehler behandeln
+ UNTIL ctrl g PER.
+
+END PROC edit block menue;
+
+
+(********************** Space-Menue ****************************)
+
+PROC space menue :
+ disable stop;
+ REP
+ menue monitor (space info line, space chars, command index);
+ fehler loeschen;
+ rewind;
+ SELECT command index OF
+ CASE 1 : read one space
+ CASE 2 : bit map read
+ CASE 3 : write one space
+ CASE 4 : bit map write
+ CASE 5 : edit one space
+ CASE 6 : copy one space
+ CASE 7 : LEAVE space menue
+ CASE 8 : new edit
+ CASE 9 : get and do one command
+ CASE 10 : load one space
+ CASE 11 : space menue help
+ CASE 12 : set ctrl g
+ END SELECT;
+ fehler behandeln;
+ display info line;
+ UNTIL ctrl g PER.
+
+load one space :
+ out ("aden aus Datei : ");
+ getline (dummy);
+ forget (ds);
+ ds := nilspace;
+ ds := old (dummy).
+
+read one space :
+ cursor (info line x pos, info line y pos);
+ out (space header info);
+ cursor (command line x pos + 2, command line y pos);
+ out ("ead ");
+ REP
+ get char (dummy)
+ UNTIL pos ("shq"7"", dummy) > 0 PER;
+ IF dummy = "s"
+ THEN out ("Space : "); read one s
+ ELIF dummy = "h"
+ THEN out ("Header : "); read one h
+ ELIF dummy = ""7""
+ THEN set ctrl g
+ FI.
+
+read one s :
+ x get (space nummer);
+ IF NOT is error
+ THEN seek space (space nummer);
+ first sp block := block number + 1;
+ forget (ds);
+ ds := nilspace;
+ read space (ds)
+ FI.
+
+read one h :
+ x get (header nummer);
+ space nummer := space nr (header nummer);
+ IF NOT is error
+ THEN seek space (space nummer);
+ first sp block := block number + 1;
+ forget (ds);
+ ds := nilspace;
+ read space (ds)
+ FI.
+
+bit map read :
+ out ("ead Space ab Block : ");
+ x get (s);
+ cursor (command line x pos + 1, command line y pos);
+ out ("Read Space ab Block "+ text (s) +" Max. Bloecke : ");
+ x get (e);
+ seek block (s);
+ IF e = 0
+ THEN e := 32000
+ FI;
+ forget (ds);
+ ds := nilspace;
+ IF yes ("bei Lesefehlern abbrechen")
+ THEN read space (ds, e, true)
+ ELSE read space (ds, e, false)
+ FI.
+
+write one space :
+ out ("rite");
+ IF yes ("write auf Space "+ text (space nummer))
+ THEN seek space (space nummer);
+ write space (ds)
+ ELIF yes ("write auf einen anderen Space")
+ THEN out (" auf Space : ");
+ x get (space nummer);
+ IF NOT is error
+ THEN seek space (space nummer);
+ write space (ds)
+ FI
+ FI.
+
+bit map write :
+ out ("rite Space ab Block : ");
+ x get (s);
+ seek block (s);
+ write space (ds).
+
+edit one space :
+ IF type (ds) = file type 16
+ THEN change to 17;
+ f := sequential file (modify, ds);
+ edit (f, 1, 1, x size - 2, 16);
+ block shown := false
+ ELIF type (ds) = file type
+ THEN f := sequential file (modify, ds);
+ edit (f, 1, 1, x size - 2, 16);
+ block shown := false
+ ELIF ds pages (ds) = 1 CAND type (ds) = 0
+ THEN edit header;
+ block shown := false
+ FI.
+
+change to 17 :
+ TEXT VAR t := "";
+ REP
+ t CAT "­"
+ UNTIL NOT exists (t) PER;
+ copy (ds, t);
+ reorganize (t);
+ forget (ds);
+ ds := nilspace;
+ ds := old (t);
+ forget (t, quiet).
+
+copy one space :
+ put ("ave in Datei : ");
+ getline (t);
+ copy (ds, t).
+
+edit header :
+ bound header := ds;
+ cursor (1, 23);
+ out (cl eol +"Header-Editor : ");
+ IF is start header (bound header)
+ THEN out ("Header ist ein Archiv-Startheader.")
+ ELIF is file header (bound header)
+ THEN out ("Header ist ein File-Header.")
+ ELIF is end header (bound header)
+ THEN out ("Header ist ein Archiv-Endheader.")
+ ELSE out ("Header ist unbekannt (Headertype = "+ text (type (bound header)) +").")
+ FI;
+ header edit (bound header, "Headernummer : "+ text (header nr) + " ").
+
+new edit :
+ out (left +"new edit ");
+ block shown := false;
+ IF yes ("Neuen Headerspace erstellen")
+ THEN create new header
+ ELSE create new file
+ FI.
+
+create new header :
+ forget (ds);
+ ds := nilspace;
+ bound header := ds;
+ bound header := nil header;
+ cursor (1, 23);
+ out (cl eol +"Header-Editor : ");
+ put ("Neuen Header erstellen");
+ header edit (bound header, "Neuen Header erstellen").
+
+create new file :
+ forget (ds);
+ ds := nilspace;
+ f := sequential file (modify, ds);
+ edit (f, 1, 1, x size - 2, 16).
+END PROC space menue;
+
+
+(********************** Configurator-Menu ****************************)
+
+PROC configurator menue :
+ disable stop;
+ REP
+ display conf info;
+ menue monitor (conf info line, conf chars, command index);
+ fehler loeschen;
+ SELECT command index OF
+ CASE 1 : put ("hannel :"); x get (archive channel);
+ CASE 2 : put (left +"disktype :"); x get (disk type);
+ CASE 3 : disk info
+ CASE 4 : get and do one command
+ CASE 5 : LEAVE configurator menue
+ CASE 6 : conf menue help
+ CASE 7 : set ctrl g
+ END SELECT;
+ fehler behandeln;
+ display info line;
+ UNTIL ctrl g PER.
+
+display conf info :
+ cursor (1, 19);
+ put (cl eol +"I/O Channel :"); put (archive channel); put (",");
+ put ("Disktype :"); put (disk type); put (",");
+ put ("Operatorchannel :"); put (channel);
+ cursor (1, 18);
+ put ("Zeit :"); put (time of day); put (", Datum :"); put (date);
+ INT VAR x size, x used;
+ storage (x size, x used);
+ put (","); put (x used); put ("K von");
+ put (int (real (x size + 24) * 64.0 / 63.0));
+ put ("K sind belegt !").
+
+disk info :
+ INT VAR size, io, error;
+ io control (archive channel, io, size, error);
+ out (home + 16 * (cl eol + down));
+ out (home + down);
+ putline ("Diskinfo :");
+ putline (first mon line);
+ put ("Disksize :"); put (size); put ("Blocks,");
+ put (size DIV 2); put ("kB.");
+ line;
+ put ("Disktype :");
+ IF size = ibm 720 format 5
+ THEN putline ("5 1/4 Zoll, IBM-720 kB Format, 80 Tracks,");
+ putline (" double sided/double density, softsectored")
+ ELIF size = ibm 360 format 5
+ THEN putline ("5 1/4 Zoll, IBM-360 kB Format, 40 Tracks,");
+ putline (" single sided/double density, softsectored")
+ ELIF size = pic 400 format 5
+ THEN putline ("5 1/4 Zoll, PIC400 Format, 80 Tracks,");
+ putline (" double sided/double density, softsectored")
+ ELIF size = soft sd 8
+ THEN putline ("8 Zoll, EUMEL-Format, 77 Tracks,");
+ putline (" single sided/double density, softsectored")
+ ELIF size = soft dd 8
+ THEN putline ("8 Zoll, EUMEL-Format, 77 Tracks,");
+ putline (" double sided/double density, softsectored")
+ ELIF size = hard ss sd
+ THEN putline ("8 Zoll, EUMEL-Format, 32 Tracks,");
+ putline (" single sided/single density, hardsectored")
+ ELIF size = hard ds sd
+ THEN putline ("8 Zoll, EUMEL-Format, 32 Tracks,");
+ putline (" double sided/single density, hardsectored")
+ ELSE putline ("Unbekannter Disktype"); line
+ FI;
+ putline (first mon line).
+END PROC configurator menue;
+
+
+(********************** Header/Space Ops. ****************************)
+
+INT PROC header nr :
+ IF space nummer = 0
+ THEN 0
+ ELSE (space nummer + 1) DIV 2
+ FI.
+END PROC header nr;
+
+INT PROC space nr (INT CONST header nummer) :
+ IF header nummer = 0 COR header nummer = 1
+ THEN header nummer
+ ELSE header nummer * 2 - 1
+ FI
+END PROC space nr;
+
+
+(********************** Archiv-Menue ****************************)
+
+PROC archive menue :
+ archive (archive name);
+ disable stop;
+ REP
+ menue monitor (archiv info line, archiv chars, command index);
+ fehler loeschen;
+ SELECT command index OF
+ CASE 1 : archive anmelden
+ CASE 2 : out ("elease (archive)");
+ release (archive); archivename := ""
+ CASE 3 : out ("ist (archive)");
+ list archive;
+ block shown := false
+ CASE 4 : out ("etch (SOME archive, archive)");
+ fetch (SOME archive, archive);
+ block shown := false
+ CASE 5 : out ("ave (SOME all, archive)");
+ save (SOME all, archive);
+ block shown := false
+ CASE 6 : release (archive);
+ LEAVE archive menue
+ CASE 7 : get and do one command;
+ block shown := false
+ CASE 8 : archiv menue help;
+ block shown := false
+ CASE 9 : set ctrl g
+ END SELECT;
+ fehler behandeln
+ UNTIL ctrl g PER.
+
+archive anmelden :
+ put ("rchivename : ");
+ getline (archivename);
+ archive (archivename).
+
+list archive :
+ IF NOT (list file ok) COR no (""13"Alte Archiveliste zeigen")
+ THEN forget (af ds);
+ af ds := nilspace;
+ af := sequential file (output, af ds);
+ list (af, archive);
+ list file ok := true
+ FI;
+ edit (af, 1, 1, xsize - 2, 16).
+END PROC archive menue;
+
+
+(********************** Urflop-Menue ****************************)
+
+PROC urflop menue :
+ INT VAR s, e;
+ disable stop;
+ REP
+ menue monitor (urflop info line, urflop chars, command index);
+ fehler loeschen;
+ SELECT command index OF
+ CASE 1 : read
+ CASE 2 : x read
+ CASE 3 : write
+ CASE 4 : x write
+ CASE 5 : list task;
+ block shown := false
+ CASE 6 : LEAVE urflop menue
+ CASE 7 : get and do one command;
+ block shown := false
+ CASE 8 : urflop menue help;
+ block shown := false
+ CASE 9 : set ctrl g
+ END SELECT;
+ fehler behandeln
+ UNTIL ctrl g PER.
+
+list task :
+ forget (l ds);
+ l ds := nilspace;
+ lf := sequential file (output, l ds);
+ list (lf);
+ edit (lf, 1, 1, xsize - 2, 16).
+
+write :
+ out ("rite Datenraumname : ");
+ getline (t);
+ IF yes ("Urlader schreiben wie gelesen")
+ THEN urlader schreiben (t, eumel 0 start block,
+ -1)
+ ELIF yes ("Urlader für PIC 400 (Shard 6.xx) schreiben")
+ THEN urlader schreiben (t, eumel 0 start block,
+ eumel 0 end block pic)
+ ELIF yes ("Urlader für PIC 400 (Shard 7.xx, u. Bicos Masch.) schreiben")
+ THEN urlader schreiben (t, eumel 0 start block,
+ eumel 0 end block)
+ ELIF yes ("Urlader für PIC 400 (ab Shard 7.13 für EUMEL Ver. 1758) schreiben")
+ THEN urlader schreiben (t, eumel 0 start block,
+ eumel 0 end block 1758)
+ FI.
+
+x write :
+ out ("rite Datenraumname : ");
+ getline (t);
+ cursor (command line x pos, command line y pos);
+ out (">Write Datenraum """+ t +""" von Block : ");
+ x get (s);
+ cursor (command line x pos, command line y pos);
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis : ");
+ x get (e);
+ cursor (command line x pos, command line y pos);
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e));
+ IF yes ("mit Versatz")
+ THEN cursor (command line x pos, command line y pos);
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Versatz : ");
+ x get (ver);
+ cursor (command line x pos, command line y pos);
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Ver. "+ text (ver) + " --> ");
+ urlader schreiben (t, s, e, ver)
+ ELSE cursor (command line x pos, command line y pos);
+ out (">Write Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" --> ");
+ urlader schreiben (t, s, e)
+ FI.
+
+read :
+ out ("ead Datenraumname : ");
+ getline (t);
+ IF yes ("Urlader für PIC 400 (Shard 6.xx) lesen")
+ THEN urlader lesen (t, eumel 0 start block,
+ eumel 0 end block pic)
+ ELIF yes ("Urlader für PIC 400 (Shard 7.xx, u. Bicos Masch.) lesen")
+ THEN urlader lesen (t, eumel 0 start block,
+ eumel 0 end block)
+ ELIF yes ("Urlader für PIC 400 (Shard 7.xx für EUMEL Ver. 1758) lesen")
+ THEN urlader lesen (t, eumel 0 start block,
+ eumel 0 end block 1758)
+ FI.
+
+x read :
+ out ("ead Datenraumname : ");
+ getline (t);
+ cursor (command line x pos, command line y pos);
+ out (">Read Datenraum """+ t +""" von Block : ");
+ x get (s);
+ cursor (command line x pos, command line y pos);
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis : ");
+ x get (e);
+ IF yes ("mit Versatz")
+ THEN cursor (command line x pos, command line y pos);
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Versatz : ");
+ x get (ver);
+ cursor (command line x pos, command line y pos);
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" Ver. "+ text (ver) + " --> ");
+ urlader lesen (t, s, e, ver)
+ ELSE cursor (command line x pos, command line y pos);
+ out (">Read Datenraum """+ t +""" von Block "+ text (s) + " bis"+
+ " Block "+ text (e) +" --> ");
+ urlader lesen (t, s, e)
+ FI.
+END PROC urflop menue;
+
+
+(********************** Disk - Monitor Call ****************************)
+
+PROC central disk monitor process :
+ archive ("disk");
+ release (archive);
+ space nummer := -1;
+ block nummer := -1;
+ header nummer := -1;
+ first sp block := -1;
+ st pos := 0;
+ archive name := "";
+ list file ok := false;
+ block shown := false;
+ reset ctrl g;
+ page;
+ line (3);
+ putline ("D I S K - M O N I T O R");
+ putline ("=========================");
+ line;
+ putline ("Autor : Ingo Siekmann");
+ putline ("Stand : "+ software stand);
+ putline (software version);
+ putline ("Bem. : "+ software bemerkung);
+ putline (" "+ software bemerkung1);
+ line;
+ putline ("(c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert");
+ line;
+ initialize if necessary;
+ global menue;
+ line;
+ unblock (archive);
+ IF archive name <> "" CAND NOT ctrl g
+ THEN archive (archive name)
+ FI.
+END PROC central disk monitor process;
+
+
+(********************** Unterprogramme ****************************)
+
+THESAURUS OP SOME (THESAURUS CONST thesaurus) :
+ DATASPACE VAR edit space :: nilspace;
+ THESAURUS VAR result := empty thesaurus;
+ FILE VAR file := sequential file (output, edit space);
+ file FILLBY thesaurus;
+ modify (file);
+ edit (file, 1, 1, xsize - 2, 16);
+ input (file);
+ result FILLBY file;
+ forget (edit space);
+ result.
+END OP SOME;
+
+THESAURUS OP SOME (TASK CONST dest task) :
+ SOME ALL dest task.
+END OP SOME;
+
+PROC display info line :
+ INT VAR x, y;
+ get cursor (x, y);
+ cursor (1, 24);
+ put (cl eol +"Block : "); put (block nummer);
+ put (", Space : "); put (space nummer);
+ put (", First Sp Block : "); put (first sp block);
+ put (", Header : "); put (header nummer);
+ cursor (x, y).
+END PROC display info line;
+
+PROC show first three ints :
+ INT VAR i, ih;
+ cursor (1, 18);
+ out (cleol);
+ FOR i FROM 1 UPTO 3 REP
+ out (text (i));
+ put (". INT:");
+ dummy := ""; dummy CATHEX block [i];
+ put (dummy);
+ put ("/");
+ ih := block [i];
+ out (text (ih));
+ out (", ")
+ PER
+END PROC show first three ints;
+
+PROC x get (INT VAR i) :
+ enable stop;
+ get (dummy);
+ IF (dummy SUB length (dummy)) = hex marker
+ THEN i := hint (text (dummy, length (dummy) - 1))
+ ELSE i := int (dummy)
+ FI;
+ IF NOT last conversion ok
+ THEN error stop ("Zahl ist nicht korrekt")
+ FI.
+END PROC x get;
+
+
+(********************** Urflop - Ops. ****************************)
+
+PROC urlader lesen (TEXT CONST urname, INT CONST start, end) :
+ urlader lesen (urname, start, end, 0).
+END PROC urlader lesen;
+
+PROC urlader schreiben (TEXT CONST urname, INT CONST start, end) :
+ urlader schreiben (urname, start, end, 0).
+END PROC urlader schreiben;
+
+PROC urlader lesen auf seite (TEXT CONST urname, INT CONST start, end,
+ auf) :
+ urlader lesen (urname, start, end, auf - start).
+END PROC urlader lesen auf seite;
+
+PROC urlader schreiben von seite (TEXT CONST urname, INT CONST start,
+ end, von) :
+ urlader schreiben (urname, start, end, von - start).
+END PROC urlader schreiben von seite;
+
+PROC urlader lesen (TEXT CONST urname, INT CONST start, end, ver) :
+ IF exists (urname)
+ THEN error stop (""""+ urname +""" gibt es schon")
+ FI;
+ forget (uds);
+ uds := nilspace;
+ reset block io;
+ reset ctrl g;
+ FOR block nr FROM start UPTO end REP
+ continue (archive channel);
+ disable stop;
+ block in (uds, block nr + ver, disk type, block nr, error);
+ continue (user channel);
+ enable stop;
+ check archive error (error, true);
+ cout (block nr);
+ dummy := incharety;
+ IF dummy = ""7""
+ THEN set ctrl g
+ FI
+ UNTIL dummy = esc COR ctrl g PER;
+ IF NOT ctrl g
+ THEN copy (uds, urname);
+ FI;
+ forget (uds).
+END PROC urlader lesen;
+
+PROC urlader schreiben (TEXT CONST urname, INT CONST start, end, ver) :
+ forget (uds);
+ uds := old (urname);
+ reset ctrl g;
+ reset block io;
+ block nr := start;
+ IF block nr = -1
+ THEN block nr := next ds page (uds, block nr)
+ FI;
+ WHILE block nr <> -1 REP
+ continue (archive channel);
+ disable stop;
+ block out (uds, block nr + ver, disk type, block nr, error);
+ break (quiet);
+ continue (user channel);
+ enable stop;
+ check archive error (error, false);
+ cout (block nr);
+ dummy := incharety;
+ IF dummy = ""7""
+ THEN set ctrl g
+ FI;
+ IF end = -1 COR start = -1
+ THEN block nr := next ds page (uds, block nr)
+ ELIF block nr = end
+ THEN block nr := -1
+ ELSE block nr INCR 1
+ FI
+ UNTIL dummy = esc COR ctrl g PER;
+ forget (uds).
+END PROC urlader schreiben;
+
+
+(********************** Unterprogramme ****************************)
+
+PROC reset block io :
+ user channel := channel;
+ INT VAR i, s, e;
+ io control (archive channel, i, s, e);
+ check archive error (e, true).
+END PROC reset block io;
+
+PROC get and do one command :
+ initialize if necessary;
+ cursor (1, 21);
+ out (cl eop);
+ get command ("gib ein EUMEL-Kommando : ", own command line);
+ do (own command line).
+END PROC get and do one command ;
+
+PROC io control (INT VAR io, size, error) :
+ ROW 256 INT VAR block;
+ control (type mode, 0, 0, io);
+ control (size mode, 0, 0, size);
+ block in (block, std disk type, block 0, error).
+END PROC io control;
+
+PROC io control (INT CONST io channel, INT VAR io, size, error) :
+ INT VAR op channel :: channel;
+ continue (io channel);
+ io control (io, size, error);
+ break (quiet);
+ continue (op channel).
+END PROC io control;
+
+
+(********************** Menue - Help Ops ****************************)
+
+PROC doctor menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Doktor-Menue : ");
+ line;
+ putline ("a --> Neuen Archivnamen (Archivanfang) schreiben");
+ putline ("e --> Neues Archivende schreiben");
+ line;
+ putline ("r --> Eine Datei von der Archiv-Diskette retten");
+ line;
+ putline ("h --> Heapteil einer Datei auf der Diskette lesen");
+ line;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ line;
+ putline ("q --> Verlassen des Diskettenmonitors (quit wie im Editor)");
+END PROC doctor menue help;
+
+PROC global menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Global-Menue : ");
+ line;
+ putline ("b --> Aufruf des Block-Menüs (direkter Block i/o)");
+ putline ("s --> Aufruf des Space-Menüs (direkter Space- und Header i/o)");
+ putline ("a --> Aufruf des Archiv-Menüs (normale Archivoperationen)");
+ putline ("u --> Aufruf des Urflop-Menüs (Urlader/Datenraum <-> Floppy)");
+ putline ("c --> Aufruf des Konfigurator-Menüs");
+ putline ("d --> Aufruf des Doktor-Menüs");
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ line;
+ putline ("q --> Verlassen des Diskettenmonitors (quit wie im Editor)");
+END PROC global menue help;
+
+PROC block menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Block-Menü : ");
+ line;
+ putline ("r --> Lesen eines Blockes (block in)");
+ putline ("n --> Lesen des nächsten Blockes");
+ putline ("w --> Schreiben eines Blockes (block out)");
+ line;
+ putline ("s --> Suchen nach einem Text");
+ line;
+ putline ("e --> Aufruf des Blockeditor-Menüs");
+ line;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ line;
+ putline ("q --> Verlassen des Block-Menüs (Rückkehr ins Global-Menü)");
+END PROC block menue help;
+
+PROC block editor menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Blockeditor-Menü : ");
+ line;
+ putline ("f --> Zeigen der ersten 256 Bytes des aktuellen Blockes");
+ putline ("s --> Zeigen der zweiten 256 Bytes des aktuellen Blockes");
+ line;
+ putline ("e --> Editieren des aktuellen Teilblockes");
+ putline ("d --> Editieren des ersten und zweiten Teilblockes");
+ line;
+ putline ("p --> Position setzen, auf der der Editor beginnen soll");
+ line;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ line;
+ putline ("q --> Verlassen des Blockeditor-Menüs (Rückkehr ins Block-Menü)");
+END PROC block editor menue help;
+
+PROC space menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Space-Menü : ");
+ line;
+ putline ("r --> Lesen eines Datenraums bzw. eines Headers");
+ putline ("R --> Lesen eines Datenraums ab Block x");
+ putline ("w --> Schreiben eines Datenraums bzw. eines Headers");
+ putline ("W --> Schreiben eines Datenraums ab Block x");
+ line;
+ putline ("e --> Editieren des aktuellen Datenraums (Datei o. Header)");
+ putline ("E --> Editieren einer neuen Datei oder eines Header");
+ line;
+ putline ("s --> Kopieren des aktuellen Datenraums in einen benannten Datenraum");
+ putline ("l --> Kopieren eines benannten Datenraums in den aktuellen Datenraum");
+ line;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ putline ("q --> Verlassen des Space-Menüs (Rückkehr ins Global-Menü)");
+END PROC space menue help;
+
+PROC archiv menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Archiv-Menü : ");
+ line;
+ putline ("a --> Archiv anmelden");
+ putline ("r --> Archiv abmelden");
+ line;
+ putline ("f --> Einige Dateien vom Archiv in die Task laden");
+ putline ("s --> Einige Dateien der Task auf das Archiv schreiben");
+ putline ("l --> Dateiliste des Archives zeigen");
+ line;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ line;
+ putline ("q --> Verlassen des Archiv-Menüs (Rückkehr ins Global-Menü)");
+END PROC archiv menue help;
+
+PROC urflop menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Urflop-Menü : ");
+ line;
+ putline ("r --> Lesen der Blöcke 10 bis 62 in einen benannten Datenraum");
+ putline ("R --> Lesen der Blöcke x bis y in einen benannten Datenraum");
+ line;
+ putline ("w --> Schreiben der Blöcke 10 bis 62 aus einem benannten Datenraum");
+ putline ("W --> Schreiben der Blöcke x bis y aus einem benannten Datenraum");
+ line;
+ putline ("l --> Dateiliste der Task zeigen (list)");
+ line;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ line;
+ putline ("q --> Verlassen des Urflop-Menüs (Rückkehr ins Global-Menü)");
+END PROC urflop menue help;
+
+PROC conf menue help :
+ out (home + cl eop);
+ line;
+ putline ("Help für das Configurator-Menü :");
+ line;
+ putline ("c --> Einstellen des Kanals, auf dem der Block i/o abläuft");
+ putline ("t --> Einstellen des Diskettentypes (EUMEL, CPM etc)");
+ line;
+ putline ("i --> Disketteninfo");
+ line;
+ putline ("k --> Möglichkeit, ein EUMEL/ELAN - Kommando zu geben (gib kommando :)");
+ line;
+ putline ("q --> Verlassen des Konfigurator-Menüs (Rückkehr ins Global-Menü)");
+END PROC conf menue help;
+
+BOOL PROC is halt from terminal :
+ is error CAND error code = 1
+END PROC is halt from terminal;
+
+PROC block in (TEXT VAR block, INT CONST block nr, disk type,
+ INT VAR error) :
+ initialize if necessary;
+ block in (blkinds, heap page nr, disk type, block nr, error);
+ block := subtext (bound text, start pos, LENGTH bound text);
+END PROC block in;
+
+PROC initialize if necessary :
+ IF NOT initialized (this packet)
+ THEN forget (blkinds);
+ blkinds := nilspace;
+ bound text := blkinds;
+ bound text := (start pos + 511) * " ";
+ own command line := "";
+ archive channel := std archive channel;
+ disk type := std disk type
+ FI.
+END PROC initialize if necessary;
+
+BOOL PROC yes (TEXT CONST msg) :
+ get cursor (cx, cy);
+ cursor (command line x pos + 1, command line y pos + 1);
+ result := NOT no (msg);
+ cursor (cx, cy);
+ result.
+END PROC yes;
+(*
+INT OP $ (TEXT CONST hex) :
+ INT VAR laenge := length (hex), stelle, ziffer, ergebnis := 0;
+ FOR stelle FROM laenge DOWNTO 1 REP
+ ziffer := pos ("0123456789ABCDEF", hex SUB stelle) - 1;
+ IF ziffer < 0
+ THEN error stop ("Ist keine Hexzahl")
+ FI;
+ ergebnis INCR ziffer * 16 ** (laenge - stelle)
+ PER;
+ ergebnis.
+END OP $;
+*)
+PROC search (TEXT CONST st, INT CONST start block, end block,
+ INT VAR fbnr, fpos) :
+ enable stop;
+ INT CONST l := LENGTH st - 1;
+ reset ctrl g;
+ reset block io;
+ FOR fbnr FROM start block UPTO end block REP
+ cout (fbnr);
+ continue (archive channel);
+ block in (stb1, fbnr, disk type, error);
+ IF error = 0
+ THEN block in (stb2, fbnr + 1, disk type, error)
+ FI;
+ break (quiet);
+ continue (user channel);
+ check archive error (error, true);
+ stb1 CAT text (stb2, l);
+ UNTIL pos (stb1, st) > 0 COR incharety = ""27"" PER;
+ fpos := pos (stb1, st)
+END PROC search;
+
+PROC heap lesen (INT CONST start block, end block, channel nr,
+ TEXT CONST output filename) :
+
+ FILE VAR f;
+ ROW 256 INT VAR block;
+ INT VAR i, j;
+ TEXT VAR t;
+ IF exists (output filename)
+ THEN error stop (""""+ output filename +""" gibt es schon")
+ FI;
+ f := sequential file (output, output filename);
+ max line length (f, 100);
+ t := "";
+ reset ctrl g;
+ set channel (channel nr);
+ FOR i FROM start block UPTO end block REP
+ c out (i);
+ read block (block, i);
+ j := 1;
+ REP
+ IF lower byte (block [j]) = 255 COR higher byte (block [j]) = 255
+ THEN putline (f, t);
+ t := ""; hihi;
+ j INCR 1
+ FI;
+ IF j < 257
+ THEN IF lower byte (block [j]) = 220 COR
+ lower byte (block [j]) = 221
+ THEN t CAT code (lower byte (block [j]))
+ ELSE t CAT ascii (lower byte (block [j]));
+ FI;
+ IF higher byte (block [j]) = 220 COR
+ higher byte (block [j]) = 221
+ THEN t CAT code (higher byte (block [j]))
+ ELSE t CAT ascii (higher byte (block [j]));
+ FI
+ FI;
+ j INCR 1;
+ UNTIL j >= 255 PER;
+ UNTIL incharety = ""27"" PER.
+
+hihi :
+ REP
+ j INCR 1;
+ IF j > 256
+ THEN LEAVE hihi
+ FI
+ UNTIL lower byte (block [j]) <> 255 CAND
+ higher byte (block [j]) <> 255 PER.
+
+END PROC heap lesen;
+
+END PACKET byte operations and disk monitor version 36 multi;
+
diff --git a/app/diskettenmonitor/3.7/src/disk cmd 3.6.quelle b/app/diskettenmonitor/3.7/src/disk cmd 3.6.quelle
new file mode 100644
index 0000000..8660a67
--- /dev/null
+++ b/app/diskettenmonitor/3.7/src/disk cmd 3.6.quelle
@@ -0,0 +1,48 @@
+
+PACKET disk cmd
+
+(************************************************************************)
+(* *)
+(* Disk - Menuecall Version 3.6 *)
+(* *)
+(* *)
+(* Autor : Ingo Siekmann *)
+(* Stand : Montag, den 09.02.1987 *)
+(* *)
+(* Lauffähig ab EUMEL Version 1.8.1 /M und insertiertem *)
+(* Diskmonitor ab Version 3.6 *)
+(* *)
+(* (c) 1986 by ULES c/o Ingo Siekmann & Nils Ehnert *)
+(* *)
+(************************************************************************)
+
+ DEFINES disk ,
+ disk monitor ,
+ disk doctor :
+
+
+lernsequenz auf taste legen ("d", "disk monitor"13"") ;
+lernsequenz auf taste legen ("D", "disk doctor"13"") ;
+
+
+PROCEDURE disk :
+
+ central disk monitor process .
+
+END PROCEDURE disk ;
+
+PROCEDURE disk monitor :
+
+ central disk monitor process .
+
+END PROCEDURE disk monitor ;
+
+PROCEDURE disk doctor :
+
+ push ("d") ;
+ disk monitor .
+
+END PROCEDURE disk doctor ;
+
+END PACKET disk cmd ;
+
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-29 22:48:24 +0000