|
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: 20608 (0x5080)
Types: TextFile
Names: »VC-005.BAK«
└─⟦ec7c10e12⟧ Bits:30009789/_.ft.Ibm2.50007351.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »VC-005.BAK«
(******************************************************************************)
(* *)
(* MAIN PROCEDURES *)
(* *)
(******************************************************************************)
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, 'OPR 1 = = = ');
write_status(test_out, status);
write(test_out, ' IOS: ', 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, 'OPR 2 = = = ');
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 var_segment(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
;VAR c_file: c_file_type
;VAR fsd: fsd_type
;VAR lsn_current: psn_type
;VAR lrn_current: psn_type
;VAR lbn_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; (* 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;
BEGIN (* var_segment *)
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, ' REC: ', rec:6);
write(test_out, ' SGS: ', sgs:2);
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
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( (.t_8.) ) THEN
BEGIN
write(test_out, '= = = = =FRC');
write(test_out, ' ');
write(test_out, ' PTR: ', rec_ptr);
write(test_out, ' LENGTH: ', rec_length);
write(test_out, ' FRACTION: ', fraction);
write(test_out, ' RESIDUAL: ', residual);
writeln(test_out);
END
UNTIL (fraction = 0) or (status <> succes);
END;
END;
IF test( (.t_7.) ) THEN
BEGIN
write(test_out, '= = = = FSD2');
write_status(test_out, status);
write(test_out, ' LRN: '); write_psn(test_out, lrn_current);
write(test_out, ' LSN: '); write_psn(test_out, lsn_current);
write(test_out, ' LBN: '); write_psn(test_out, lbn_current);
writeln(test_out);
END;
END
END; (* var_segment *)
PROCEDURE isam_dup(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
;VAR c_file: c_file_type
; flk_psn: psn_type
; lrn_current: psn_type
; lsn_current: psn_type
; lbn_current: psn_type
);
VAR
fsd_number: byte; (* index of fsd in fab *)
fab: block_type; (* current fab *)
BEGIN (* isam_dup *)
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, ' 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 := 0;
WHILE (status = succes) and (use > 0) and (fsd_number < 30) DO
BEGIN
fsd_number := fsd_number + 1;
var_segment(status, error_out, v_file, c_file,
fsd(.fsd_number.),
lsn_current, lrn_current, lbn_current);
END;
END
END
ELSE
status := failure;
END; (* isam_dup *)
PROCEDURE primary_entry(VAR status: status_type
;VAR error_out: text
;VAR print_out: text
;VAR v_file: v_file_type
;VAR pde: pde_type
; first_file_no: integer
;VAR current_file_no: integer
; path_name: path_name_type
);
VAR
c_file_name: c_file_name_type; (* name of c_file *)
c_file: c_file_type; (* cp/m file to write *)
lsn_current: psn_type; (* current logical sector number *)
lrn_current: psn_type; (* current logical record number *)
lbn_current: psn_type; (* current logical byte number *)
BEGIN (* primary_entry *)
WITH pde DO
BEGIN
IF test( (.t_5.) ) THEN
BEGIN
write(test_out, '= = PDE = = ');
write(test_out, ' CURR. FILE NO: ', current_file_no:6);
write(test_out, ' ATT: ', hex_2(att) );
write(test_out, ' FS: '); write_psn(test_out, fs);
write(test_out, ' FE: '); write_psn(test_out, fe);
write(test_out, ' EOF: '); write_psn(test_out, pde.eof);
write(test_out, ' EOR: '); write_psn(test_out, eor);
write(test_out, ' FAB: ', fab);
write(test_out, ' DAT: ', dat);
writeln(test_out);
END;
IF ord( fil(.1.) ) <> 0 (* 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
lsn_current := null_psn;
lrn_current := null_psn;
lbn_current := null_psn;
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) and
(dat = 8) and (fab = 1) THEN
BEGIN
WHILE (status = succes) and
not equal_psn(fs, null_psn) DO
isam_dup(status, error_out,
v_file, c_file, fs,
lsn_current, lrn_current, lbn_current);
IF not ( equal_psn(lsn_current, pde.eof) and
equal_psn(lrn_current, pde.eor) ) THEN
BEGIN
END;
END
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
END; (* primary_entry *)
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
);
VAR
pdb: block_type; (* current pdb *)
pde_number: 0..20; (* index of pde in pdb *)
BEGIN (* primary *)
pdb.kind := pdb_tag;
get_block(status, error_out, v_file, pdp_psn, recs_per_pdb, pdb);
WITH pdb.pdb DO
BEGIN
IF test( (.t_4.) ) THEN
BEGIN
write(test_out, '= = PDB = = ');
write_status(test_out, status);
write(test_out, ' PDP: '); write_psn(test_out, fpt);
write(test_out, ' CURR. FILE NO: ', current_file_no:6);
writeln(test_out);
END;
IF status = succes THEN
BEGIN
path_name.pdb_clg := clg;
print_dir(status, print_out, path_name);
pdp_psn := fpt;
pde_number := 0;
WHILE (status = succes) and (pde_number < 20) DO
BEGIN
pde_number := pde_number + 1;
primary_entry(status, error_out, print_out, v_file,
pde(.pde_number.),
first_file_no, current_file_no, path_name)
END
END
END
END; (* primary *)
PROCEDURE secondary_entry(VAR status: status_type
;VAR error_out: text
;VAR print_out: text
;VAR v_file: v_file_type
;VAR sde: sde_type
; first_file_no: integer
;VAR current_file_no: integer
; path_name: path_name_type
);
BEGIN (* secondary_entry *)
WITH sde DO
BEGIN
IF test( (.t_3.) ) THEN
BEGIN
write(test_out, '= SDE = = = ');
write_status(test_out, status);
write(test_out, ' PDP: '); write_psn(test_out, pdp);
write(test_out, ' CURR. FILE NO: ', current_file_no:4);
write(test_out, ' CLG: ', clg:8);
writeln(test_out);
END;
path_name.sdb_clg := clg;
WHILE (status = succes) and not equal_psn(pdp, null_psn) DO
primary(status, error_out, print_out, v_file, pdp,
first_file_no, current_file_no, path_name);
END
END; (* secondary_entry *)
PROCEDURE secondary(VAR status: status_type
;VAR error_out: text
;VAR print_out: text
;VAR v_file: v_file_type
;VAR sds_psn: psn_type
; first_file_no: integer
;VAR current_file_no: integer
; path_name: path_name_type
);
VAR
sdb: block_type; (* current sdb *)
sde_number: 0..15; (* index of sde in sdb *)
BEGIN (* secondary *)
sdb.kind := sdb_tag;
get_block(status, error_out, v_file, sds_psn, recs_per_sdb, sdb);
WITH sdb.sdb DO
BEGIN
IF test( (.t_2.) ) THEN
BEGIN
write(test_out, '=SDB= = = = ');
write_status(test_out, status);
write(test_out, ' FPT: '); write_psn(test_out, fpt);
write(test_out, ' CURR. FILE NO: ', current_file_no);
writeln(test_out);
END;
IF status = succes THEN
BEGIN
sds_psn := fpt;
sde_number := 0;
WHILE (sde_number < 15) and (status = succes) DO
BEGIN
sde_number := sde_number + 1;
secondary_entry(status, error_out, print_out, v_file,
sde(.sde_number.),
first_file_no, current_file_no, path_name)
END
END
END
END; (* secondary *)
PROCEDURE volume(VAR status: status_type
;VAR error_out: text
;VAR print_out: text
;VAR oper_in: text
;VAR oper_out: text
);
VAR
vid: block_type; (* current and only vid *)
sds_psn: psn_type; (* psn of next 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);
WITH vid.vid DO
BEGIN
IF test( (.t_1.) ) THEN
BEGIN
write(test_out, 'VOL = = = = ');
write_status(test_out,status);
write(test_out, ' SDS: '); write_psn(test_out, sds);
write(test_out, ' VOL: ', vol:4);
writeln(test_out);
END;
IF status = succes THEN
IF vol = usr_vidvol THEN
BEGIN
print_header(status, print_out, v_file_name, first_file_no);
path_name.vol := vol;
path_name.usn := usn;
current_file_no := 0;
sds_psn := sds;
WHILE (status = succes) and not equal_psn(sds, null_psn) DO
secondary(status, error_out, print_out, v_file, sds_psn,
first_file_no, current_file_no, path_name);
writeln(oper_out, current_file_no - 1, ' files transferred.');
print_footer(status, print_out, current_file_no);
END
ELSE
writeln(error_out, 'conflicting volume identifier.')
END
END
END; (* volume *)
«eof»