(************************************************************************)
(* *)
(* 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 ;