|
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: 7552 (0x1d80)
Types: TextFile
Names: »VC-003.INC«
└─⟦398ae89d3⟧ Bits:30009789/_.ft.Ibm2.50007353.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »VC-003.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: Subroutine pos called from open_c_file will return 0
(zero) if search string is not found. This is the case
when the file name assumes its full extent
(8 characters). Test and modification inserted to avoid
index range error while calling the delete subroutine.
*)
(******************************************************************************)
(* *)
(* 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»