(* ------------------- VERSION 11 06.03.86 ------------------- *)
PACKET basic archive DEFINES
archive blocks ,
block number ,
check read ,
format archive ,
read block ,
read ,
rewind ,
search dataspace ,
seek ,
size ,
skip dataspace ,
write block ,
write :
INT VAR blocknr := 0 ,
rerun := 0 ,
page := -1 ,
bit word := 1 ,
unreadable sequence length := 0 ;
INT CONST all ones :=-1 ;
DATASPACE VAR label ds ;
LET write normal = 0 ,
archive version = 1 ,
first page stored = 2 ,
dr size = 3 ,
first bit word = 4 ,
(* write deleted data mark = 64 , *)
inconsistent = 90 ,
read error = 92 ,
label size = 131 ;
BOUND STRUCT (ALIGN dummy for page1,
(* Page 2 begins: *)
ROW label size INT lab) VAR label;
INT PROC block number :
block nr
ENDPROC block number ;
PROC seek (INT CONST block) :
block nr := block
ENDPROC seek ;
PROC rewind :
forget (label ds);
label ds := nilspace;
label := label ds;
block nr := 0;
rerun := session
END PROC rewind;
PROC skip dataspace:
check rerun;
get label;
IF is error
THEN
ELIF olivetti
THEN block nr INCR label.lab (dr size+1)
ELSE block nr INCR label.lab (dr size)
FI
END PROC skip dataspace;
PROC read (DATASPACE VAR ds):
read (ds, 30000, FALSE)
ENDPROC read ;
PROC read (DATASPACE VAR ds, INT CONST max pages, BOOL CONST error accept) :
enable stop ;
check rerun;
get label;
init next page;
INT VAR i ;
FOR i FROM 1 UPTO max pages REP
next page;
IF no further page THEN LEAVE read FI;
check storage ;
check rerun ;
read block ;
block nr INCR 1;
PER .
read block :
disable stop ;
get external block (ds, page, block nr) ;
ignore read error if no errors accepted ;
enable stop .
ignore read error if no errors accepted :
IF is error CAND error code = read error CAND NOT error accept
THEN clear error
FI .
check storage :
INT VAR size, used ;
storage (size, used) ;
IF used > size
THEN forget (ds) ;
ds := nilspace ;
errorstop ("Speicherengpass") ;
LEAVE read
FI .
check rerun :
IF rerun <> session
THEN errorstop ("RERUN beim Archiv-Zugriff") ;
LEAVE read
FI .
END PROC read;
PROC check read :
enable stop ;
get label ;
INT VAR pages, i;
IF olivetti
THEN pages := label.lab (dr size+1)
ELSE pages := label.lab (dr size)
FI ;
FOR i FROM 1 UPTO pages REP
get external block (label ds, 2, block nr) ;
block nr INCR 1
PER .
ENDPROC check read ;
PROC write (DATASPACE CONST ds):
enable stop ;
check rerun;
INT VAR label block nr := block nr;
block nr INCR 1;init label;
INT VAR page := -1,i;
FOR i FROM 1 UPTO ds pages (ds) REP
check rerun ;
page := next ds page(ds,page);
put external block (ds, page, block nr) ;
reset archive bit;
label.lab(dr size) INCR 1;
block nr INCR 1
PER;
put label.
init label:
label.lab(archive version) := 0 ;
label.lab(first page stored) := 0 ;
label.lab(dr size) := 0;
INT VAR j;
FOR j FROM first bit word UPTO label size REP
label.lab (j) := all ones
PER.
put label:
put external block (label ds, 2, label block nr).
reset archive bit:
reset bit (label.lab (page DIV 16+first bit word), page MOD 16).
END PROC write;
PROC get label:
enable stop ;
get external block (label ds, 2, block nr) ;
block nr INCR 1;
check label.
check label:
IF may be z80 format label OR may be old olivetti format label
THEN
ELSE errorstop (inconsistent, "Archiv inkonsistent")
FI.
may be z80 format label :
z80 archive AND label.lab(dr size) > 0 .
may be old olivetti format label :
olivetti AND label.lab(first page stored)=0 AND label.lab(dr size+1) > 0 .
END PROC get label;
PROC next page:
IF z80 archive
THEN
WHILE labelbits = all ones REP
bitword INCR 1;
IF bitword >= label size THEN
no further page := true; LEAVE next page FI
PER;
INT VAR p := lowest reset (labelbits);
set bit (labelbits, p);
page := 16*(bitword-first bit word)+p
ELSE
WHILE oli bits = 0 REP
bitword INCR 1;
IF bitword >= labelsize-64 THEN
no further page := true; LEAVE next page FI
PER;
p := lowest set (oli bits);
reset bit (olibits, p);
page := 16*(bitword-firstbitword)+p;
FI.
label bits : label.lab (bitword).
oli bits : label.lab (bitword+1).
END PROC next page;
.
olivetti : label.lab (archive version) = -1.
z80 archive : label.lab (archive version) = 0.
init next page:
BOOL VAR no further page := false;
bitword := first bit word.
check rerun :
IF rerun <> session
THEN errorstop ("RERUN beim Archiv-Zugriff")
FI .
PROC get external block (DATASPACE VAR ds, INT CONST page,
INT CONST block nr):
INT VAR error ;
read block (ds, page, block nr, error) ;
SELECT error OF
CASE 0: read succeeded
CASE 1: error stop ("Lesen unmoeglich (Archiv)")
CASE 2: read failed
CASE 3: error stop ("Archiv-Ueberlauf")
OTHERWISE error stop ("??? (Archiv)")
END SELECT .
read succeeded :
unreadable sequence length := 0 .
read failed :
unreadable sequence length INCR 1 ;
IF unreadable sequence length >= 30
THEN errorstop ("30 unlesbare Bloecke hintereinander")
ELSE error stop (read error, "Lesefehler (Archiv)")
FI .
END PROC get external block;
PROC put external block (DATASPACE CONST ds, INT CONST page,
INT CONST block nr):
INT VAR error;
write block (ds, page, write normal, block nr, error) ;
SELECT error OF
CASE 0:
CASE 1: error stop ("Schreiben unmoeglich (Archiv)")
CASE 2: error stop ("Schreibfehler (Archiv)")
CASE 3: error stop ("Archiv-Ueberlauf")
OTHERWISE error stop ("??? (Archiv)")
END SELECT .
END PROC put external block;
PROC read block (DATASPACE VAR ds,
INT CONST ds page no,
INT CONST block no,
INT VAR return code) :
read block;
retry if read error.
read block:
block in (ds, ds page no, 0, block no, return code).
retry if read error:
INT VAR retry;
FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
reset to block 0 if fifth try;
read block
PER.
reset to block 0 if fifth try:
IF retry = 5
THEN block in (ds, ds page no, 0, 0, return code)
FI.
END PROC read block;
PROC write block (DATASPACE CONST ds,
INT CONST ds page no,
INT CONST mode,
INT CONST block no,
INT VAR return code):
write block;
retry if write error.
write block:
block out (ds, ds page no, mode * 256, block no, return code) .
retry if write error:
INT VAR retry;
FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
reset to block 0 if fifth try;
write block
PER.
reset to block 0 if fifth try:
IF retry = 5
THEN disable stop;
DATASPACE VAR dummy ds := nilspace;
block in (dummy ds, 2, 0, 0, return code);
forget (dummy ds);
enable stop
FI.
END PROC write block;
INT PROC size (INT CONST key) :
INT VAR return code ;
control (5, key, 0, return code) ;
return code .
ENDPROC size ;
INT PROC archive blocks :
size (0)
ENDPROC archive blocks ;
PROC search dataspace (INT VAR ds pages) :
disable stop ;
ds pages := -1 ;
INT CONST last block := archive blocks ;
WHILE block nr < last block REP
IF block is dataspace label
THEN ds pages := pages counted ;
LEAVE search dataspace
FI ;
block nr INCR 1
UNTIL is error PER .
block is dataspace label :
look at label block ;
IF is error
THEN IF error code = read error OR error code = inconsistent
THEN clear error
FI ;
FALSE
ELSE count pages ;
pages counted = number of pages as label says
FI .
look at label block :
INT CONST
old block nr := block nr ;
get label ;
block nr := old block nr.
count pages :
INT VAR
pages counted := 0 ;
init next page ;
next page ;
WHILE NOT no further page REP
pages counted INCR 1 ;
next page
PER .
number of pages as label says : label.lab (dr size) .
ENDPROC search dataspace ;
PROC format archive (INT CONST format code) :
IF format is possible
THEN format
ELSE errorstop ("'format' ist hier nicht implementiert")
FI .
format is possible :
INT VAR return code ;
control (1,0,0, return code) ;
bit (return code, 4) .
format :
control (7, format code, 0, return code) ;
IF return code = 1
THEN errorstop ("Formatieren unmoeglich")
ELIF return code > 1
THEN errorstop ("Schreibfehler (Archiv)")
FI .
ENDPROC format archive ;
END PACKET basic archive;