Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Path: utzoo!mnetor!uunet!seismo!husc6!think!ames!ucbcad!ucbvax!germany.CSNET!F1142S30%unika1 From: F1142S30%unika1@germany.CSNET ("Juergen Renz, 7530 Pforzheim") Newsgroups: comp.os.vms Subject: Re: Writing to Mailboxes, Example with a subprocess Message-ID: <8707230302.AA14566@ucbvax.Berkeley.EDU> Date: Wed, 22-Jul-87 03:31:00 EDT Article-I.D.: ucbvax.8707230302.AA14566 Posted: Wed Jul 22 03:31:00 1987 Date-Received: Sat, 25-Jul-87 02:31:54 EDT Sender: daemon@ucbvax.BERKELEY.EDU Distribution: world Organization: The ARPA Internet Lines: 219 { 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.