|
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: 23040 (0x5a00)
Types: TextFile
Names: »OLDVC005.INC«
└─⟦ec7c10e12⟧ Bits:30009789/_.ft.Ibm2.50007351.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »OLDVC005.INC«
(******************************************************************************)
(* *)
(* MAIN PROCEDURES *)
(* *)
(******************************************************************************)
PROCEDURE volume(VAR status: status_type
;VAR error_out: text
;VAR print_out: text
;VAR oper_in: text
;VAR oper_out: text
);
PROCEDURE operator(VAR status: status_type
;VAR oper_in: text
;VAR oper_out: text
;VAR v_file: v_file_type
;VAR v_file_name: c_file_name_type
;VAR first_file_no: integer
;VAR usr_vidvol: string_4
);
VAR
ios_v_file: byte;
BEGIN (* operator *)
(* operator dialogue *)
writeln(oper_out, 'Program VERSACON version 1.0.');
writeln(oper_out);
writeln(oper_out, '(1) Indsæt kildedisketten i A-drevet.');
REPEAT
writeln(oper_out, '(2) Angiv navnet på kildediskettens CP/M-fil med ',
'VersaDos-filsystem-kopien:');
writeln(oper_out);
readln(oper_in, v_file_name);
writeln(oper_out);
IF length(v_file_name) > 0 THEN
BEGIN
assign(v_file, v_file_name);
(*$I-*)
reset(v_file);
(*$I+*)
ios_v_file := ioresult;
IF ios_v_file <> IO_succes THEN
BEGIN
writeln(oper_out, '*** Filåbningsfejl.');
writeln(oper_out);
status := fatal
END
ELSE
status := succes
END
ELSE
status := exit;
IF test( (.t_1.) ) THEN
BEGIN
write(test_out, '=== operator-1 ====');
write_status(test_out, status);
write(test_out, ' ios_v_file: ', ios_v_file);
END;
UNTIL status in (.succes, exit.);
IF status = succes THEN
BEGIN
writeln(oper_out, '(3) Angiv antal VersaDos-filer at overspringe:');
writeln(oper_out);
readln(oper_in, first_file_no);
writeln(oper_out);
writeln(oper_out, '(4) Angiv VersaDos-diskettens "volume-id":');
writeln(oper_out);
readln(oper_in, usr_vidvol);
writeln(oper_out);
END;
IF test( (.t_1.) ) THEN
BEGIN
write(test_out, '=== operator > ===');
write_status(test_out, status);
write(test_out, ' v_file_name: ',v_file_name:14);
write(test_out, ' first_file_no: ',first_file_no);
write(test_out, ' usr_vidvol: ',usr_vidvol);
writeln(test_out);
END;
END; (* operator *)
PROCEDURE secondary(VAR status: status_type
;VAR error_out: text
;VAR print_out: text
;VAR v_file: v_file_type
; sds_psn: psn_type
; first_file_no: integer
;VAR current_file_no: integer
; path_name: path_name_type
);
PROCEDURE primary(VAR status: status_type
;VAR error_out: text
;VAR print_out: text
;VAR v_file: v_file_type
; pdp_psn: psn_type
; first_file_no: integer
;VAR current_file_no: integer
; path_name: path_name_type
);
PROCEDURE isam_dup(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
;VAR c_file: c_file_type
; pde_fs: psn_type
; pde_fe: psn_type
; pde_eof: psn_type
; pde_eor: psn_type
; pde_fab: byte
; pde_dat: byte
);
PROCEDURE var_segment(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
;VAR c_file: c_file_type
; fsd: fsd_type
; lsn_current: psn_type
; lrn_current: psn_type
);
PROCEDURE expand(VAR status: status_type
;VAR error_out: text
;VAR c_file: c_file_type
; n: byte
);
BEGIN (* expand *)
IF n > 127 THEN
write(c_file, ' ':(n mod 128) )
ELSE
write(c_file, chr(n):1)
END; (* expand *)
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.) * 256 +
dab.db(.rec_ptr + 1.)
END; (* get_length *)
VAR
dab: block_type;
rec_ptr: byte_number;
rec_length: byte_number;
fraction: byte_number;
residual: byte_number;
i: byte_number;
BEGIN (* var_segment *)
dab.kind := dab_tag;
WITH fsd DO
BEGIN
IF test( (..) ) THEN
BEGIN
write(test_out, '=== > var_segment ==');
write(test_out, ' PSN: ');
write_psn(test_out, psn);
write(test_out, ' REC: ', rec:6);
write(test_out, ' SGS: ', sgs:2);
write(test_out, ' KEY: ', key:2);
writeln(test_out);
END;
position(status, error_out, v_file, psn);
IF status = succes THEN
BEGIN
rec_ptr := 255;
fraction := 0;
residual := 0;
rec_length := 0;
REPEAT
(* copy from dab.db(.rec_ptr + fraction.)*)
FOR i := 0 TO fraction - 1 DO
expand(status, error_out, c_file,
dab.db(.rec_ptr + i.) );
(* DAB exhausted *)
IF rec_ptr >= 255 THEN
IF sgs >= 0 THEN
BEGIN
get_current_block(status, error_out, v_file,
recs_per_dab, dab);
sgs := sgs - 1;
rec_ptr := -1;
END
ELSE
BEGIN
status := failure;
writeln(error_out, 'Data segment exceeded.');
END;
(* record exhausted *)
IF residual <= 0 THEN
BEGIN
rec := rec -1;
IF odd(rec_length) THEN
fraction := fraction + 1;
rec_ptr := rec_ptr + fraction + 2;
get_length(dab, rec_ptr, rec_length);
END;
IF rec_ptr + rec_length > 255 THEN (* spanning *)
BEGIN
fraction := 255 - rec_ptr;
residual := rec_length - fraction;
END
ELSE
BEGIN
fraction := rec_length;
residual := 0;
END;
IF test( (..) ) THEN
BEGIN
write(test_out, '=== var_segment-1 ==');
write(test_out, ' PTR: ', rec_ptr);
write(test_out, ' LENGTH: ', rec_length);
write(test_out, ' FRACTION: ', fraction);
write(test_out, ' RESIDUAL: ', residual);
write(test_out, ' REC: ', rec);
write(test_out, ' SGS: ', sgs);
writeln(test_out);
END
UNTIL (fraction = 0) or (status <> succes);
END;
END;
IF test( (..) ) THEN
BEGIN
write(test_out, '=== var_segment > ==');
write_status(test_out, status);
writeln(test_out);
END;
END; (* var_segment *)
VAR
flk: psn_type;
dab_number: byte;
fsd_number: byte;
fab: block_type;
dab: block_type;
lsn_current: psn_type;
lrn_current: psn_type;
BEGIN (* isam_dup *)
lsn_current := null_psn;
lrn_current := null_psn;
fab.kind := fab_tag;
flk := pde_fs;
REPEAT
IF test( (..) ) THEN
BEGIN
write(test_out, '=== > isam_dup ===');
write(test_out, ' FS: '); write_psn(test_out, pde_fs);
write(test_out, ' FE: '); write_psn(test_out, pde_fe);
write(test_out, ' EOF: '); write_psn(test_out, pde_eof);
write(test_out, ' EOR: '); write_psn(test_out, pde_eor);
write(test_out, ' FAB: ', pde_fab);
write(test_out, ' DAT: ', pde_dat);
writeln(test_out);
END;
get_block(status, error_out, v_file, flk, recs_per_fab, fab);
IF status = succes THEN
BEGIN
flk := fab.fab.flk;
IF test( (..) ) THEN
BEGIN
write(test_out, '=== isam_dup-1 ===');
write(test_out, ' FLK: ');
write_psn(test_out, fab.fab.flk);
write(test_out, ' BLK: ');
write_psn(test_out, fab.fab.blk);
write(test_out, ' USE: ', fab.fab.use:2);
writeln(test_out);
END;
IF (fab.fab.use > 0) and (pde_fab = 1)
and (pde_dat = 8) THEN
BEGIN
fsd_number := 0;
REPEAT
fsd_number := fsd_number + 1;
IF test( (..) ) THEN
BEGIN
write(test_out, '=== isam_dup-2 ===');
write(test_out, ' FSD NUMBER: ', fsd_number:2);
writeln(test_out);
END;
var_segment(status, error_out, v_file,
c_file,fab.fab.fsd(.fsd_number.),
lsn_current, lrn_current);
UNTIL (equal_psn(fab.fab.fsd(.fsd_number.).psn,
null_psn
)
) or (status <> succes) or (fsd_number > 30);
inc_psn(pde_eof);
inc_psn(pde_eor);
IF not ( equal_psn(lsn_current, pde_eof) and
equal_psn(lrn_current, pde_eor) ) THEN
BEGIN
END;
END
END
ELSE
status := failure;
UNTIL equal_psn(flk,null_psn) or (status <> succes);
END; (* isam_dup *)
VAR
fpt: psn_type; (* psn of next pdb (zero if none) *)
pdb: block_type; (* current pdb *)
pde_number: 0..20; (* index of pde in pdb *)
c_file_name: c_file_name_type; (* name of c_file *)
c_file: c_file_type; (* Cp/m file to write *)
BEGIN (* primary *)
pdb.kind := pdb_tag;
fpt := pdp_psn;
REPEAT
get_block(status, error_out, v_file, fpt, recs_per_pdb, pdb);
IF status = succes THEN
BEGIN
WITH path_name DO
pdb_clg := pdb.pdb.clg;
print_dir(status, print_out, path_name);
fpt := pdb.pdb.fpt;
pde_number := 0;
REPEAT
pde_number := pde_number + 1;
WITH pdb.pdb.pde(.pde_number.) DO
BEGIN
IF test( (.t_3.) ) THEN
BEGIN
write(test_out, '=== primary-1 ===');
write(test_out, ' PDE NUMBER: ', pde_number:2);
write(test_out, ' CURR. FILE NO: ', current_file_no:6);
write(test_out, ' ATT: ', hex_2(att) );
write(test_out, ' FPT: ');
write_psn(test_out, fpt);
writeln(test_out);
END;
IF true (* entry used *) THEN
BEGIN
current_file_no := current_file_no + 1;
IF current_file_no > first_file_no THEN
BEGIN
open_c_file(status, error_out, c_file, c_file_name,
fil, ext);
IF status = succes THEN
BEGIN
print_pre_file(status, print_out
, current_file_no
, fil, ext
, c_file_name
);
CASE (att mod 4) OF
0: (* contiguous *)
writeln(error_out, 'Contiguous files ',
'not implemented.');
1: (* sequential Variable + Fixed *)
writeln(error_out, 'Sequential files ',
'not implemented.');
2: (* Keyed ISAM No duplicate keys *)
writeln(error_out, 'Keyed ISAM files ',
'(no duplicate keys) ',
'not implemented.');
3: (* Keyed ISAM Duplicate + Null keys *)
IF (key = 0) and (lrl =0) THEN
isam_dup(status, error_out,
v_file, c_file,
fs, fe,
pdb.pdb.pde(.pde_number.).eof,
eor, fab, dat);
END; (* case *)
close_erase_c_file(status, error_out, c_file,
status <> succes);
(* print_post_file(status, print_out, recs, bytes);*)
END
END
END
END
UNTIL (pde_number >=20) or (status <> succes)
END
UNTIL equal_psn(fpt, null_psn) or (status <> succes);
IF test( (.t_2,t_3.) ) THEN
BEGIN
write(test_out, '=== primary > ===');
write_status(test_out, status);
write(test_out, ' CURR. FILE NO: ', current_file_no:6);
writeln(test_out);
END;
END; (* primary *)
VAR
sdb: block_type; (* current sdb *)
fpt: psn_type; (* psn of next sdb *)
sde_number: 0..15; (* index of sde in sdb *)
BEGIN (* secondary *)
sdb.kind := sdb_tag;
fpt := sds_psn;
REPEAT
get_block(status, error_out, v_file, fpt, recs_per_sdb, sdb);
IF status = succes THEN
BEGIN
fpt := sdb.sdb.fpt;
sde_number := 0;
REPEAT
sde_number := sde_number + 1;
WITH sdb.sdb.sde(.sde_number.) DO
BEGIN
IF test( (.t_2.) ) THEN
BEGIN
write(test_out, '=== secondary-1 ===');
write(test_out, ' SDE NUMBER: ', sde_number);
write(test_out, ' PDP: '); write_psn(test_out, pdp);
write(test_out, ' CLG: ', clg:8);
write(test_out, ' FPT: '); write_psn(test_out, fpt);
writeln(test_out);
END;
WITH path_name DO
sdb_clg := clg;
IF not( equal_psn(pdp, null_psn) ) THEN
primary(status, error_out, print_out, v_file, pdp,
first_file_no, current_file_no, path_name);
END
UNTIL (sde_number >= 15) or (status <> succes)
END;
UNTIL equal_psn(fpt, null_psn) or (status <> succes);
IF test( (.t_1,t_2.) ) THEN
BEGIN
write(test_out, '=== secondary > ===');
write_status(test_out, status);
write(test_out, ' CURR. FILE NO: ', current_file_no);
writeln(test_out);
END;
END; (* secondary *)
VAR
vid: block_type; (* current and only vid *)
sds: psn_type; (* psn of next (first) sdb *)
v_file: v_file_type; (* CP/M source file holding
Versados file system *)
v_file_name: c_file_name_type; (* name of v_file *)
first_file_no: integer; (* name of first file to convert.
Files numbered 0... *)
current_file_no: integer; (* number of current file *)
usr_vidvol: string_4; (* Volume label stated by operator
to be verified against volume *)
path_name: path_name_type; (* path name of current file *)
BEGIN (* volume *)
vid.kind := vid_tag;
operator(status, oper_in, oper_out, v_file, v_file_name,
first_file_no, usr_vidvol);
IF status = succes THEN
BEGIN
get_block(status, error_out, v_file, null_psn, recs_per_vid, vid);
IF test( (.t_1.) ) THEN
BEGIN
write(test_out, '=== volume-1 ===');
write_status(test_out,status);
write(test_out, ' vid.vol: ', vid.vid.vol:4);
writeln(test_out);
END;
IF status = succes THEN
IF vid.vid.vol = usr_vidvol THEN
BEGIN
print_header(status, print_out, v_file_name, first_file_no);
WITH path_name DO
BEGIN
vol := vid.vid.vol;
usn := vid.vid.usn;
END;
current_file_no := 0;
sds := vid.vid.sds;
IF not equal_psn(sds, null_psn) THEN
secondary(status, error_out, print_out, v_file, sds,
first_file_no, current_file_no, path_name);
writeln(oper_out, current_file_no - 1, ' files transferred.');
(* should probably be printed as well *)
END
ELSE
writeln(error_out, 'conflicting volume identifier.')
END
END; (* volume *)
(********************)
(*
BEGIN
IF test( (..) ) THEN
BEGIN
write(test_out,'=== ===');
write_status(test_out, status);
write(test_out,' ');
writeln(test_out);
END;
END;
*)
«eof»