|
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: 8064 (0x1f80)
Types: TextFile
Names: »VC-002.INC«
└─⟦ec7c10e12⟧ Bits:30009789/_.ft.Ibm2.50007351.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »VC-002.INC«
(******************************************************************************)
(* *)
(* PROCEDURES FOR FILE I/O *)
(* *)
(******************************************************************************)
PROCEDURE position(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
; psn: psn_type
);
VAR
ios: byte;
record_number: integer;
BEGIN (* position *)
IF (psn(.rx3.) = 0) or (psn(.rx2.) = 0) or (psn(.rx1.) < 128) THEN
BEGIN
record_number := psn(.rx1.) * 256 + psn(.rx0.);
record_number := record_number + record_number;
(*$I-*)
seek(v_file, record_number);
(*$I+*)
ios := IOresult;
status := succes;
IF ios <> IO_succes THEN
BEGIN
status := failure;
writeln(error_out, 'File position beyond end of file.');
END;
END
ELSE
BEGIN
status := failure;
writeln(error_out, 'File position beyond implementation limit.');
END;
IF test( (.t_11.) ) THEN
BEGIN
write(test_out, 'POSITION= = ');
write_status(test_out, status);
write(test_out, ' PSN: '); write_psn(test_out, psn);
write(test_out, ' RECN: ', record_number:6);
write(test_out, ' IOS: ', hex_2(ios) );
writeln(test_out);
END;
END; (* position *)
PROCEDURE get_current_block(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
; recs_per_block: integer
; block: block_type
);
VAR
ios: byte;
BEGIN (* get_current_block *)
(*$I-*)
blockread(v_file, block.vid, recs_per_block);
(*$I+*)
ios := IOresult;
status := succes;
IF ios <> IO_succes THEN
BEGIN
status := failure;
writeln(error_out, 'Failed to read block.');
END;
IF test( (.t_10.) ) THEN
BEGIN
write(test_out, 'GET C BLOCK ');
write_status(test_out, status);
write(test_out, ' IOS: ', hex_2(ios) );
write(test_out, ' BLOCK_KIND: ',ord( block.kind ));
writeln(test_out);
END;
END; (* get_current_block *)
PROCEDURE get_block(VAR status: status_type
;VAR error_out: text
;VAR v_file: v_file_type
; psn: psn_type
; recs_per_block: integer
;VAR block: block_type
);
BEGIN (* get_block *)
position(status, error_out, v_file, psn);
IF status = succes THEN
get_current_block(status, error_out, v_file, recs_per_block, block);
END; (* get_block *)
PROCEDURE open_c_file(VAR status: status_type
;VAR error_out: text
;VAR c_file: c_file_type
;VAR c_file_name: c_file_name_type
; fil: text_8
; ext: text_2
);
VAR
ios_c_file: byte;
suffix: char;
c_file_name_length: byte;
BEGIN (* open_c_file *)
(* build cp/m file name from versados fil and ext *)
(* repeatedly attempt to open modifying file name in case of conflict *)
IF test( (.t_5,t_9.) ) THEN
BEGIN
write(test_out, 'OP C FILE = ');
write(test_out, ' FIL: ', fil:8, ' EXT: ', ext:2);
writeln(test_out);
END;
c_file_name := target_device + fil + '.' + ext;
c_file_name_length := length(c_file_name);
suffix := initial_suffix;
REPEAT
assign(c_file, c_file_name);
(*$I-*)
reset(c_file);
(*$I+*)
ios_c_file := IOresult;
IF test( (.t_9.) ) THEN
BEGIN
write(test_out, 'OP C FILE 2 ');
write(test_out, ' IOS(reset): ', hex_2(ios_c_file) );
writeln(test_out);
END;
IF ios_c_file <> IO_nosuchfile THEN
BEGIN
close(c_file);
IF suffix = initial_suffix THEN
c_file_name := c_file_name + suffix
ELSE
insert(suffix, c_file_name, c_file_name_length);
suffix := succ(suffix)
END;
IF test( (.t_9.) ) THEN
BEGIN
write(test_out, 'OP C FILES 3');
write(test_out, ' IOS(reset): ', hex_2(ios_c_file) );
write(test_out, ' c_file_name: ', c_file_name:14);
write(test_out, ' suffix: ', suffix);
writeln(test_out);
END;
UNTIL (ios_c_file = IO_nosuchfile) or (suffix > 'Y');
IF ios_c_file = IO_nosuchfile THEN
BEGIN
(*$I-*)
rewrite(c_file);
(*$I+*)
IF ios_c_file = IO_succes THEN
status := succes
ELSE
status := failure
END
ELSE
status := fatal;
IF test( (.t_5,t_9.) ) THEN
BEGIN
write(test_out, 'OP C FILE 4 ');
write_status(test_out, status);
write(test_out, ' c_file_name: ', c_file_name:14);
writeln(test_out);
END;
END; (* open_c_file *)
PROCEDURE close_erase_c_file(VAR status:status_type
;VAR error_out: text
;VAR c_file: c_file_type
; deletion: boolean
);
VAR
ios_c_file: byte;
retry_count: byte;
BEGIN (* close_erase_c_file *)
IF test( (.t_5,t_9.) )THEN
BEGIN
write(test_out, 'CE C FILE = ');
write(test_out, ' DELETION: ', deletion:5);
writeln(test_out);
END;
status := succes;
retry_count := 0;
REPEAT
retry_count := retry_count + 1;
(*$I-*)
close(c_file);
(*$I+*)
ios_c_file := IOresult;
IF test( (.t_9.) ) THEN
BEGIN
write(test_out, 'CE C FILE 2 ');
write(test_out, ' IOS(close): ', hex_2(ios_c_file) );
write(test_out, ' RETRY_CNT: ', retry_count:2);
writeln(test_out);
END;
UNTIL (ios_c_file = IO_succes) or (retry_count > 10);
IF ios_c_file <> IO_succes THEN
BEGIN
writeln(error_out, 'Failed to close file proporly.');
status := failure
END;
IF deletion THEN
BEGIN
retry_count := 0;
REPEAT
(*$I-*)
erase(c_file);
(*$I+*)
ios_c_file := IOresult;
IF test( (.t_9.) ) THEN
BEGIN
write(test_out, 'CE C FILE 3 ');
write(test_out, ' IOS(close): ', hex_2(ios_c_file) );
write(test_out, ' RETRY_CNT: ', retry_count:2);
writeln(test_out);
END;
UNTIL (ios_c_file = IO_succes) or (retry_count > 10);
IF ios_c_file <> IO_succes THEN
BEGIN
writeln(error_out, 'Failed to erase file proporly.');
status := failure
END;
END;
IF test( (.t_5,t_9.) )THEN
BEGIN
write(test_out, 'CE C FILE 4 ');
write_status(test_out, status);
writeln(test_out);
END;
END; (* close_erase_c_file *)
«eof»