|
DataMuseum.dkPresents historical artifacts from the history of: Bogika Butler |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Bogika Butler Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 12544 (0x3100)
Types: TextFile
Names: »VC-005-3.INC«
└─⟦398ae89d3⟧ Bits:30009789/_.ft.Ibm2.50007353.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »VC-005-3.INC«
(******************************************************************************)
(* *)
(* *)
(* This file contains parts of the *)
(* source text for program VERSACON *)
(* *)
(* Copyright (C) 1985 by Lars G. Jakobsen and Metanic Aps. *)
(* *)
(* *)
(******************************************************************************)
(* 1985.03.29 V 1.1: Repeat loop in fsd_3 expanding fraction of record
changed to while loop in order to avoid the first
cycle of the loop in case of a record starting in
byte 00 of the dab as this would otherwise cause
index range violation for rec_ptr = 255 and i = 1
in dab.db(. rec_ptr + i.)
*)
(******************************************************************************)
(* *)
(* PROCEDURES FOR KEYED ISAM FILES WITH DUPLICATE KEYS AND NULL KEYS *)
(* *)
(******************************************************************************)
PROCEDURE fsd_3(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
;VAR c_file: c_file_type
;VAR fsd: fsd_type
; fsd_number: byte
;VAR lsn_current: psn_type
;VAR lrn_current: psn_type
);
PROCEDURE expand(VAR status: status_type
;VAR error_out: text
;VAR c_file: c_file_type
; n: byte
);
BEGIN (* expand *)
(*$I-*)
IF n > 127 THEN
write(c_file, ' ':(n mod 128) )
ELSE
write(c_file, chr(n):1);
(*$I+*)
IF IOresult <> IO_succes THEN
status := fatal
END; (* expand *)
PROCEDURE terminate_c_record(VAR status: status_type
;VAR c_file: c_file_type
);
BEGIN (* terminate_c_record *)
(*$I-*)
writeln(c_file);
(*$I+*)
IF IOresult <> IO_succes THEN
status := fatal
END; (* terminate_c_record *)
PROCEDURE get_length(VAR dab: block_type
; rec_ptr: byte_number
;VAR rec_length: byte_number
);
BEGIN (* get_length *)
rec_length := dab.db(.rec_ptr - 1.) * 256 +
dab.db(.rec_ptr.)
END; (* get_length *)
VAR
dab: block_type; (* current data block *)
rec_ptr: byte_number; (* pointer to start of current fraction *)
rec_length: byte_number; (* length of current record (- zerofiller) *)
fraction: byte_number; (* length of current fraction *)
residual: byte_number; (* length of current residual *)
i: byte_number;
record_count: integer; (* count of records not yet delt with *)
sector_count: integer; (* count of sectors not yet delt with *)
(* Neither record_count nor sector_count can be overflown if
the file system is consistent *)
BEGIN (* fsd_3 *)
dab.kind := dab_tag;
WITH fsd DO
BEGIN
IF test( (.t_7.) ) THEN
BEGIN
write(test_out, '= = = = FSD1');
write(test_out, ' ');
write(test_out, ' PSN: ');
write_psn(test_out, psn);
write(test_out, ' SGS: ', sgs:2);
write(test_out, ' REC: '); write_i_16(test_out, rec);
write(test_out, ' KEY: ', key:2);
writeln(test_out);
END;
IF not equal_psn(psn, null_psn) THEN
BEGIN
position(status, error_out, v_file, psn);
IF status = succes THEN
BEGIN
record_count := s_i_16(rec);
sector_count := sgs;
rec_ptr := 255;
fraction := 0;
residual := -1;
rec_length := 0;
REPEAT
(* copy from dab.db(.rec_ptr + fraction.)*)
i := 1;
WHILE (i <= fraction) and (status = succes) DO (*850329 lgj*)
BEGIN (*850329 lgj*)
expand(status, error_out, c_file,
dab.db(.rec_ptr + i.) );
i := i + 1
END; (*850329 lgj*)
rec_ptr := rec_ptr + fraction;
IF residual = 0 THEN
BEGIN
IF odd(rec_length) THEN
rec_ptr := rec_ptr + 1;
IF status <> fatal THEN
terminate_c_record(status, c_file);
(* terminate old record *)
END;
(* DAB exhausted *)
IF rec_ptr >= 255 THEN
CASE sgn(sector_count) OF
negative:
status := failure;
zero:
IF record_count <> 0 THEN
status := failure;
positive:
BEGIN
sector_count := sector_count - 1;
rec_ptr := -1;
get_current_block(status, error_out, v_file,
recs_per_dab, dab);
END
END; (* CASE *)
(* record exhausted *)
IF residual <= 0 THEN
CASE sgn(record_count) OF
negative:
status := failure;
zero:
IF sector_count <> 0 THEN
status := failure
ELSE
rec_length := 0;
positive:
BEGIN
record_count := record_count -1;
rec_ptr := rec_ptr + 2;
get_length(dab, rec_ptr, rec_length);
residual := rec_length;
IF test( (.t_7, t_8.) ) and (
(rec_length > max_record_length) or
(rec_length < 0) ) THEN
status := failure;
END
END; (* CASE *)
(* fraction exhausted i.e. any case *)
IF rec_ptr + residual > 255 THEN (* spanning *)
BEGIN
fraction := 255 - rec_ptr;
residual := residual - fraction;
END
ELSE
BEGIN
fraction := residual;
residual := 0;
END;
IF test( (.t_8.) ) THEN
BEGIN
write(test_out, '= = = = =FRC');
write_status(test_out, status);
write(test_out, ' SEC: ', sector_count:3);
write(test_out, ' REC: ', record_count:5);
write(test_out, ' PTR: ', rec_ptr:3);
write(test_out, ' LENGTH: ', rec_length:5);
write(test_out, ' FRACTION: ', fraction:3);
write(test_out, ' RESIDUAL: ', residual);
writeln(test_out);
END
UNTIL (rec_length = 0) or (status <> succes);
record_count := s_i_16(rec) - record_count;
sector_count := sgs - sector_count;
sum_32_i(lrn_current, record_count);
sum_32_i(lsn_current, sector_count);
IF record_count <> s_i_16(rec) THEN
writeln(error_out, '*** Ukorrekt antal poster kopieret i ',
'datasegment # ', fsd_number:2);
IF sector_count <> sgs THEN
writeln(error_out, '*** Ukorrekt antal sektorer kopieret i ',
'datasegment # ', fsd_number:2);
IF test( (.t_7, t_8.) ) and (
(rec_length > max_record_length) or
(rec_length < 0) ) THEN
writeln(error_out, '*** Postlængde = ',
rec_length:5, ' > ', max_record_length,
' i datasegment # ', fsd_number:2);
IF status <> succes THEN
BEGIN
write(error_out, ' PSN: ');
write_psn(error_out, psn);
write(error_out, ' SEC: ', sector_count:3,
' REC: ', record_count:5,
' LSN: '); write_psn(error_out, lsn_current);
write(error_out, ' LRN: '); write_psn(error_out, lrn_current);
write(error_out, ' REC-PTR: ', rec_ptr:3);
writeln(error_out);
END
END;
END;
IF test( (.t_7.) ) THEN
BEGIN
write(test_out, '= = = = FSD2');
write_status(test_out, status);
write(test_out, ' SEC CNT: ', sector_count);
write(test_out, ' REC CNT: ', record_count);
write(test_out, ' LSN: '); write_psn(test_out, lsn_current);
write(test_out, ' LRN: '); write_psn(test_out, lrn_current);
(* write(test_out, ' LBN: '); write_psn(test_out, lbn_current); *)
writeln(test_out);
END;
END
END; (* fsd_3 *)
PROCEDURE fab_3(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
;VAR c_file: c_file_type
;VAR flk_psn: psn_type
;VAR lsn_current: psn_type
;VAR lrn_current: psn_type
);
VAR
fsd_number: byte; (* index of fsd in fab *)
fab: block_type; (* current fab *)
BEGIN (* fab_3 *)
fab.kind := fab_tag;
get_block(status, error_out, v_file, flk_psn, recs_per_fab, fab);
WITH fab.fab DO
BEGIN
IF test( (.t_6.) ) THEN
BEGIN
write(test_out, '= = = FAB = ');
write_status(test_out, status);
write(test_out, ' PSN: '); write_psn(test_out, flk_psn);
write(test_out, ' FLK: '); write_psn(test_out, flk);
write(test_out, ' BLK: '); write_psn(test_out, blk);
write(test_out, ' USE: ', use:2);
writeln(test_out);
END;
IF status = succes THEN
BEGIN
flk_psn := flk;
fsd_number := 1;
WHILE (status <> fatal) and
not equal_psn(fsd(.fsd_number.).psn, null_psn) and
(fsd_number <= 30) DO
BEGIN
fsd_3(status, error_out, v_file, c_file,
fsd(.fsd_number.), fsd_number,
lsn_current, lrn_current);
fsd_number := fsd_number + 1;
END;
END
ELSE
status := failure;
END
END; (* fab_3 *)
«eof»