|
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: 7168 (0x1c00)
Types: TextFile
Names: »VC-003.BAK«
└─⟦398ae89d3⟧ Bits:30009789/_.ft.Ibm2.50007353.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »VC-003.BAK«
(******************************************************************************)
(* *)
(* *)
(* This file contains parts of the *)
(* source text for program VERSACON *)
(* *)
(* Copyright (C) 1985 by Lars G. Jakobsen and Metanic Aps. *)
(* *)
(* *)
(******************************************************************************)
(******************************************************************************)
(* *)
(* 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 *)
record_number := s_i_32(psn);
IF (record_number > 0) or equal_psn(psn, null_psn) THEN
BEGIN
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, '*** Filposition hinsides "eof".');
END;
END
ELSE
BEGIN
status := failure;
writeln(error_out, '*** Filposition hinsides implementationsgrænse.');
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
;VAR block: block_type
);
VAR
ios: byte;
BEGIN (* get_current_block *)
(*$I-*)
blockread(v_file, block.vid.vol, recs_per_block);
(*$I+*)
ios := IOresult;
status := succes;
IF ios <> IO_succes THEN
BEGIN
status := failure;
writeln(error_out, '*** Læsefejl.');
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 ));
write(test_out, ' FILEPOS: ', filepos(v_file):4 );
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;
c_file_name_length := pos(' ', c_file_name);
IF c_file_name_length <= 0 THEN (* 1985.03.29 lgj *)
c_file_name_length := 11; (* 1985.03.29 lgj *)
delete(c_file_name, c_file_name_length, 14);
c_file_name := c_file_name + '.' + 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
IF suffix <> initial_suffix THEN
delete(c_file_name, c_file_name_length + 1, 14);
c_file_name := c_file_name + suffix;
suffix := succ(suffix)
END;
close(c_file);
IF test( (.t_9.) ) THEN
BEGIN
write(test_out, 'OP C FILE 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+*)
ios_c_file := IOresult;
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, ' IOS(rewrite): ', hex_2(ios_c_file) );
write(test_out, ' c_file_name: ', c_file_name:14);
writeln(test_out);
END;
END; (* open_c_file *)
«eof»