[INHERIT ( 'SYS$LIBRARY:STARLET', 'SYS$LIBRARY:OSIT' )]

PROGRAM pascal_send (input, output);

{
*
* 			Copyright (c) 1987
*	DIGITAL EQUIPMENT CORPORATION, Maynard, Massachusetts, USA
*
* This software is furnished under a license and may be  used  and  copied 
* only in accordance with the terms of such licence and with the inclusion
* of the above copyright notice.   This  software,  or  any  other  copies
* thereof, may not be provided or otherwise made available  to  any  other
* person. No title to and ownership of the software is hereby transferred.
*
* The information in this software is subject  to  change  without  notice
* and should not  be  construed  as  a  commitment  by  DIGITAL  EQUIPMENT
* CORPORATION.
*
* DIGITAL assumes no responsibility for the use or the reliability of  its 
* software on equipment which is not supplied by DIGITAL.
*
**++
**  FACILITY:
**
**      VOTS Example Program
**
**  ABSTRACT:
**
**	SEND PROGRAM
**      This program is one of a pair of demonstration programs which will
**	transfer data entered at the terminal from one VAX to another  via
**	the VAX OSI Transport Service.
**
**  ENVIRONMENT:
**
**	Native mode VAX processor, User mode.
**
**  COMPILATION/LINKAGE:
**
**	$ PASCAL this_prog
**	$ LINK this_prog, sys$library:osit$library/lib, sys$library:starlet/lib
**	$ RUN this_prog
**
**  AUTHORS:
**
**
**  CREATION DATE:
**
**	30-SEP-1987
**
**  MODIFICATION HISTORY:
**
**	19-NOV-1987   SMcL  Changed qio data structure to item list.
**
**--
}





CONST	    c_target		= 'TARGET';
	    c_size_target	= 6;

	    c_tsap		= 'VOTS_RECEIVE1';
	    c_size_tsap		= 13;

	    c_iobsz		= 70;





TYPE	    t_word	= [word] -32768..32767;	    { 16bits 2bytes signed   }
	    t_long	= [long] integer;	    { 32bits 4bytes signed   }
	    t_ubyte	= [byte] 0..255;	    { 08bits 1byte  unsigned }
	    t_uword	= [word] 0..65535;	    { 16bits 2bytes unsigned }
	    t_ulong	= [long] unsigned;	    { 32bits 4bytes unsigned }
	    t_uquad	= [quad, unsafe]    RECORD
					        l0,l1:unsigned
					    END;    { 64bits 8bytes unsigned }



	    t_mbx_buf	=   RECORD
				msg_typ	: t_uword;
				unit	: t_uword;
 				name_sz	: t_ubyte;
				name	: PACKED ARRAY [1..15] OF char;
				info_sz	: t_ubyte;
				info	: PACKED ARRAY [1..15] OF char
			    END;

	    t_iosb	=   RECORD
				status,
				null	: t_uword;
				iosb_1	: t_ulong
			    END;

	    t_itm_ptr	=   [volatile, unsafe] ^_osit_item;





VAR	    target		:   PACKED ARRAY [1..c_size_target]
						OF char := c_target;

	    tsap		:   PACKED ARRAY [1..c_size_tsap]
						OF char := c_tsap;

	    protoc		:   t_ulong := OSIT$K_OSI_PROTOCOL;

	    item_ptr		:   ARRAY [1..4] OF t_itm_ptr;

	    item_list		:   [volatile] ARRAY
					[0..OSIT$K_MAX_OUTPUT_ITEM_LIST - 1]
							OF t_ubyte;

	    item_list_size	:   integer;

	    zero		:   [volatile] integer := 0;

	    osi			:   [volatile] PACKED ARRAY [1..11]
						    OF char := 'OSIT$DEVICE';

	    item_list_desc,
	    osi_desc		:   [volatile] DSC1$TYPE;

	    mbx_msg		:   t_mbx_buf;

	    iosb		:   t_iosb;

	    io_buf		:   PACKED ARRAY [1..c_iobsz] OF char;

	    status		:   t_uword;

	    mbx_channel,
	    vots_channel	:   t_word := 0;





{   $QIOW1 redefines $QIOW formal parameters p1 and p2 for VOTS use   }

[asynchronous,external(SYS$QIOW)] FUNCTION $qiow1 (
	%immed efn		: unsigned := %immed 0;
	%immed chan		: integer;
	%immed func		: integer;
	var    iosb		: [volatile] t_uquad := %immed 0;
	%immed [unbound, asynchronous] procedure astadr := %immed 0;
	%immed astprm		: unsigned := %immed 0;
	%immed p1		: [unsafe] integer := %immed 0;
	%immed p2		: [unsafe] integer := %immed 0;
	var    p3		: [unsafe] integer := %immed 0;
	%immed p4		: integer := %immed 0;
	%immed p5		: integer := %immed 0;
	%immed p6		: integer := %immed 0) : integer; external;



[asynchronous,external(LIB$ASN_WTH_MBX)] FUNCTION $asn_wth_mbx (
	%ref	dev_nam		: [unsafe] array [$l8..$u8:integer]
						    of t_ubyte := %immed  0;
	%ref	max_msg		: t_long := %immed 0;
	%ref	buf_quo		: t_long := %immed 0;
	var	dev_chn		: t_word := %immed 0;
	var	mbx_chn		: t_word := %immed 0) : integer; external;















PROCEDURE build_item_list;

{   Builds an item list which is used to create the transport connection.
    item_list is a block of memory reserved for the item records.
    item_ptr[n] is set to point to the next free byte in that block
    to ensure that the individual item records are stored contiguously.  }

VAR	next_free_byte	: integer;



BEGIN
    {   ITEM: Target Address   }
    item_ptr[1]			    := address(item_list[0]);
    item_ptr[1]^.OSIT$W_ITEM_LENGTH := size(target) + 4;
    item_ptr[1]^.OSIT$W_ITEM_TYPE   := OSIT$K_ITEM_ADDRESS;
    item_ptr[1]^.OSIT$T_ITEM_STRING := target;
    next_free_byte		    := size(target) + 4;

    {   ITEM: TSAP   }
    item_ptr[2]			    := address(item_list[next_free_byte]);
    item_ptr[2]^.OSIT$W_ITEM_LENGTH := size(tsap) + 4;
    item_ptr[2]^.OSIT$W_ITEM_TYPE   := OSIT$K_ITEM_CALLED_TSAP;
    item_ptr[2]^.OSIT$T_ITEM_STRING := tsap;
    next_free_byte		    := next_free_byte + size(tsap) + 4;

    {   ITEM: Protocol   }
    item_ptr[3]			    := address(item_list[next_free_byte]);
    item_ptr[3]^.OSIT$W_ITEM_LENGTH := size(protoc) + 4;
    item_ptr[3]^.OSIT$W_ITEM_TYPE   := OSIT$K_ITEM_PROTOCOL_TYPE;
    item_ptr[3]^.OSIT$L_ITEM_LONG   := protoc;
    next_free_byte		    := next_free_byte + size(protoc) + 4;

    item_list_size		    := next_free_byte;

    IF item_list_size > OSIT$K_MAX_OUTPUT_ITEM_LIST
    THEN BEGIN
	    writeln('Item list is too big');
	    $EXIT(SS$_NORMAL)
	 END;

END;   { build_item_list }







PROCEDURE build_descriptors;

{   Build osi & item list descriptors   }



BEGIN
    WITH item_list_desc DO
	BEGIN
	    DSC$W_MAXSTRLEN	:= item_list_size;
	    DSC$B_DTYPE		:= DSC$K_DTYPE_T;
	    DSC$B_CLASS		:= DSC$K_CLASS_S;
	    DSC$A_POINTER	:= address(item_list[0])
	END;

    WITH osi_desc DO
	BEGIN
	    DSC$W_MAXSTRLEN	:= size(osi);
	    DSC$B_DTYPE		:= DSC$K_DTYPE_T;
	    DSC$B_CLASS		:= DSC$K_CLASS_S;
	    DSC$A_POINTER	:= address(osi)
	END;

END;   { build_descriptors }







PROCEDURE check_status( status: t_uword; iosb: t_iosb );

{   Check System Service return status and VOTS return code   }

BEGIN
    IF status <> SS$_NORMAL
    THEN $EXIT(status)
    ELSE IF iosb.status <> SS$_NORMAL
	 THEN BEGIN
		  $PUTMSG(iosb.status);   {output VMS return code}
		  $EXIT(iosb.iosb_1)      {output VOTS return code}
              END
END;   { check_status }





BEGIN	{ main }
    writeln('VOTS Sender');

    build_item_list;
    build_descriptors;



    {   Create mailbox and assign the channel to OSIT$DEVICE
	( 'zero' points to a longword containing 0,
	  causing VMS to supply a default value )		}

    writeln('Calling $asn_wth_mbx');

    status := $asn_wth_mbx(	dev_nam	:= osi_desc,
				max_msg	:= zero,
				buf_quo	:= zero,
				dev_chn	:= vots_channel,
				mbx_chn	:= mbx_channel  );

    IF NOT odd(status) THEN $EXIT(status);









    {	Create Transport connection to the remote task   }

    writeln('Creating transport connection');

    status := $qiow1(	chan	:= vots_channel,
			func	:= IO$_ACCESS,
			iosb	:= iosb,
			p1	:= address(item_list_desc) );

    check_status(status, iosb);



    {	Read mailbox to get status of transport connection  }

    writeln('Reading mailbox');

    status := $QIOW(	chan	:= mbx_channel,
			func	:= IO$_READVBLK,
			iosb	:= iosb,
			p1	:= mbx_msg,
			p2	:= size(mbx_msg));

    check_status(status, iosb);





    {   Check that first word of the message contains the
        MSG$_CONFIRM message identifier                    }

    writeln('Checking MSG$_CONFIRM');

    IF mbx_msg.msg_typ <> MSG$_CONFIRM THEN $EXIT(mbx_msg.msg_typ);





    {	Send user's message to the remote task   }

    write('Enter line> ');
    readln(io_buf);
    status := $QIOW(    chan    := vots_channel,
			func    := IO$_WRITEVBLK,
			iosb    := iosb,
			p1	:= io_buf,
			p2	:= size(io_buf) );

    check_status(status, iosb);



    {	Wait for notification that remote task has terminated
	the transport connections by reading from the mailbox   }

    writeln('Calling $qiow, waiting for remote task to end');

    status := $QIOW(	chan	:= mbx_channel,
			func	:= IO$_READVBLK,
			iosb	:= iosb,
			p1	:= mbx_msg,
			p2	:= size(mbx_msg));

    check_status(status, iosb);





    {   Check that first word of the message is
        MSG$_ABORT disconnect message identifier  }

    writeln('Checking MSG$_ABORT');

    IF mbx_msg.msg_typ <> MSG$_ABORT THEN $EXIT(mbx_msg.msg_typ);

    $EXIT(SS$_NORMAL)

END.