diff options
Diffstat (limited to 'app/diskettenmonitor/3.5/src/disk 3.5-m.quelle')
| -rw-r--r-- | app/diskettenmonitor/3.5/src/disk 3.5-m.quelle | 2192 |
1 files changed, 2192 insertions, 0 deletions
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 ; + |