F1142S30%unika1@germany.CSNET ("Juergen Renz, 7530 Pforzheim") (07/22/87)
{
File: TIMER.PAS
This program is an example of how to use a mailbox to pass
commands to a subprocess.
( At our site we have VMS V4.5 and PASCAL V3.4 )
$ pascal timer
$ link timer /notraceback
$ run timer
Timer>
:
Timer> *EXIT*
$
}
[INHERIT('SYS$LIBRARY:STARLET')]
program timer;
type
word = [WORD] 0..65535;
quadword = array [1..2] of unsigned;
procedure lib$emul(
multiplier,
multiplicand,
addend: integer;
var product: quadword ); extern;
function lib$getdvi(
item_code: integer;
channel: unsigned := %immed 0;
dev_name: [CLASS_S] packed array [l1..u1:integer] of char := %immed 0;
var out_value: unsigned := %immed 0;
var out_string: [CLASS_S] packed array [l2..u2:integer] of char := %immed 0;
var out_len: word := %immed 0
): integer; extern;
function lib$getjpi(
item_code: integer;
var pidadr: unsigned := %immed 0;
prcnam: [CLASS_S] packed array [l1..u1:integer] of char := %immed 0;
var out_value: unsigned := %immed 0;
var out_string: [CLASS_S] packed array [l2..u2:integer] of char := %immed 0;
var out_len: word := %immed 0
): integer; extern;
function lib$get_ef( var efn: integer ): integer; extern;
function lib$get_input(
var input_buffer: [CLASS_S] packed array [l1..u1: integer] of char;
prompt_buffer: [CLASS_S] packed array [l2..u2: integer] of char := %immed 0;
var length: word := %immed 0
): integer; extern;
function lib$put_output(
buffer: [CLASS_S] packed array [l..u: integer] of char
): integer; extern;
function lib$spawn(
command_string: [CLASS_S] packed array [l1..u1: integer] of char := %immed 0;
input_file: [CLASS_S] packed array [l2..u2: integer] of char := %immed 0;
output_file: [CLASS_S] packed array [l3..u3: integer] of char := %immed 0;
flags: [UNSAFE] unsigned := %immed 0;
process_name: [CLASS_S] packed array [l4..u4: integer] of char := %immed 0;
var process_id: unsigned := %immed 0;
var completion_status: integer := %immed 0;
completion_efn: integer := %immed 0;
%immed [ASYNCHRONOUS,UNBOUND] procedure astadr( astprm: integer ) := %immed 0;
completion_astprm: [UNSAFE] integer := %immed 0;
prompt: [CLASS_S] packed array [l11..u11: integer] of char := %immed 0;
cli: [CLASS_S] packed array [l12..u12: integer] of char := %immed 0
): integer; extern;
function lib$subx(
minuend,
subtrahend: quadword;
var difference: quadword
): integer; extern;
function lib$sys_fao(
ctrstr: [CLASS_S] packed array [l1..u1:integer] of char;
var outlen: word := %immed 0;
var outbuf: [CLASS_S] packed array [l2..u2:integer] of char;
%immed arglst: [LIST,UNSAFE] integer
): integer; extern;
var
old_cpu,
old_bufio,
old_dirio,
old_faults: unsigned := 0;
old_tim: quadword;
pid: unsigned;
spawn_efn: integer;
status: integer;
mbx_chan: word;
mbx_name: packed array [1..16] of char;
cmd_given: boolean := false;
procedure display_timer;
var
new_cpu,
new_bufio,
new_dirio,
new_faults: unsigned;
new_tim,
cpu_tim: quadword;
buffer: varying [128] of char;
begin
$gettim( new_tim );
lib$getjpi( JPI$_CPUTIM, pid, , new_cpu );
lib$getjpi( JPI$_BUFIO, pid, , new_bufio );
lib$getjpi( JPI$_DIRIO, pid, , new_dirio );
lib$getjpi( JPI$_PAGEFLTS, pid, , new_faults );
if cmd_given and (new_cpu <> old_cpu) then
begin
lib$subx( old_tim, new_tim, new_tim );
lib$emul( -100000, int(new_cpu-old_cpu), 0, cpu_tim );
lib$sys_fao(
'ELAPSED: !%T, CPU: !%T, BUFIO: !SL, DIRIO: !SL, FAULTS: !SL'
, , %descr buffer
, %ref new_tim
, %ref cpu_tim
, new_bufio-old_bufio
, new_dirio-old_dirio
, new_faults-old_faults );
lib$put_output( buffer );
end;
old_cpu := new_cpu;
old_bufio := new_bufio;
old_dirio := new_dirio;
old_faults := new_faults;
end;
procedure set_readattn_ast;
[unbound] procedure readattn_ast;
var
status: integer;
buffer: packed array [1..1024] of char;
buflen: word;
begin
display_timer;
status := lib$get_input( buffer, 'Timer> ', buflen );
if status = RMS$_EOF then
$qiow( chan := mbx_chan
, func := io$_writeof )
else if not odd(status) then
$exit(status)
else
begin
$gettim( old_tim );
$qiow( chan := mbx_chan
, func := io$_writevblk
, p1 := %ref buffer
, p2 := buflen );
end;
cmd_given := true;
set_readattn_ast;
end;
begin
$qiow( chan := mbx_chan
, func := io$_setmode+io$m_readattn
, p1 := %immed readattn_ast );
end;
procedure send_command( buf: packed array [l..u:integer] of char );
begin
$qiow( chan := mbx_chan
, func := io$_writevblk+IO$M_NOW
, p1 := %ref buf
, p2 := u );
end;
begin
status := lib$get_ef( spawn_efn );
if not odd(status) then $exit(status);
status := $crembx( chan := mbx_chan
, bufquo := 512
, promsk := %XF0FF );
if not odd(status) then $exit(status);
status := lib$getdvi( DVI$_DEVNAM, mbx_chan, out_string := mbx_name );
if not odd(status) then $exit(status);
set_readattn_ast;
status := lib$spawn( input_file := mbx_name
, flags := CLI$M_NOWAIT
, process_id := pid
, completion_efn := spawn_efn );
if not odd(status) then $exit(status);
send_command( 'set noon' );
send_command( 'define /nolog sys$command sys$output' );
send_command( 'define /nolog sys$input sys$output' );
send_command( 'define /nolog tt sys$output' );
$waitfr( spawn_efn );
end.