Programmer's ROM - The Computer Language Library

home *** CD-ROM | disk | FTP | other *** search

/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / defdata / tcpwicat.src < prev next >

Wrap

Text File | 1988-05-03 | 374.3 KB | 9,642 lines

--:::::::::::::: --buffer.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01175-100(-) -- E-Systems, Inc. August 07, 1985 -- -- buffer.txt Author : Jim Baldo -- ----------------------------------------------------------------------- -- FILE : BUFFER AUTHOR : JIM BALDO -- 5/24/85 3:20 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/28/85 10:39 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/28/85 11:38 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT with SYSTEM; use SYSTEM; package BUFFER_DATA is ----------------------------------------------------------------------------- --This package represents the data abstraction of a message that travels -- --through each layer in the DoD reference model. Upon recieving a message -- --the protocol uses a pointer to gain access to the beginning of its -- --header. The package is implementation dependent. Its intend is to -- --facilatate the portibility of this communications program by narrowing -- --the packages to be change to an absolute minimum for different machines. -- -- -- --design: -- -- -- -- -- -- The packed bit stream buffer definition. -- -- A buffer record contains the following information: -- -- STATUS : indicating the current owner, if any. A process must not -- -- free a buffer if it is owned by any other process. -- -- TELNET_PTR : indicates the position of the first byte of data for -- -- Telnet. -- -- TCP_PTR : indicates the position of the first byte of data for TCP.-- -- IP_PTR : indicates the position of the first byte of data for IP. -- -- SUBNET_PTR : Indicates the position of the first byte of data -- -- for SUBNET -- -- SIZE : total size in bytes -- -- BYTE : The actual transmitted data, in an array of packed bytes.-- -- NEXT : A link field used to manage free buffers. -- -- -- -- -- -- -- -- Organization of buffer -- -- Note that unused portion of the buffer is at the front or the back-- -- of the buffer. -- -- -- -- +-------------+ -- -- | | -- -- | unused | -- -- | | -- -- +-------------+ <-------- SUBNET_PTR -- -- | | -- -- | SUBNET | -- -- | header | -- -- | | -- -- +-------------+ <-------- IP_PTR -- -- | | -- -- | IP | -- -- | header | -- -- | | -- -- +-------------+ <-------- TCP_PTR -- -- | | -- -- | TCP | -- -- | header | -- -- | | -- -- +-------------+ <-------- TELNET_PTR -- -- | | -- -- | TELNET | -- -- | data | -- -- | | -- -- +-------------+ -- -- | | -- -- | unused | -- -- | | -- -- +-------------+ -- -- -- ----------------------------------------------------------------------------- --&MT subtype THIRTYTWO_BITS is INTEGER; -- DEC/Ada subtype THIRTYTWO_BITS is LONG_INTEGER; --Telesoft Ada version 1.5 --&MT subtype SIXTEEN_BITS is SHORT_INTEGER; -- DEC/Ada subtype SIXTEEN_BITS iS INTEGER; --Telesoft Ada version 1.5 --&MT subtype SYSTEM_BYTE is UNSIGNED_BYTE; -- DEC/Ada subtype SYSTEM_BYTE is SYSTEM.BYTE; -- Telesoft Ada version 1.5 MAXIMUM_DATAGRAM_SIZE : constant SIXTEEN_BITS := 576; type BUFFER_STATUS is (NONE, OWNER_TELNET, OWNER_TCP, OWNER_IP, OWNER_X25); --&MT type BUFFER_AREA IS ARRAY(1..MAXIMUM_DATAGRAM_SIZE) OF SYSTEM_BYTE; type BUFFER_AREA IS ARRAY(1..576) OF SYSTEM_BYTE; TELNET_SIZE : constant SIXTEEN_BITS := 512; --for efficent block transfer TCP_SIZE : constant SIXTEEN_BITS := 512; IP_SIZE : constant SIXTEEN_BITS := 512; SUBNET_SIZE : constant SIXTEEN_BITS := 512; --set appropiately to SUBNET --specification subtype TELNET_PTR_TYPE is SIXTEEN_BITS range 0..TELNET_SIZE; subtype TCP_PTR_TYPE is SIXTEEN_BITS range 0..TCP_SIZE; subtype IP_PTR_TYPE is SIXTEEN_BITS range 0..IP_SIZE; subtype SUBNET_PTR_TYPE is SIXTEEN_BITS range 0..SUBNET_SIZE; type PACKED_BUFFER; type PACKED_BUFFER_PTR is access PACKED_BUFFER; type PACKED_BUFFER is record STATUS : BUFFER_STATUS := NONE; IN_USE : BOOLEAN := false; -- THE LAYER USING IT MAY NOT -- BE THE OWNER. SIZE : SIXTEEN_BITS range 0..MAXIMUM_DATAGRAM_SIZE ; TELNET_PTR : TELNET_PTR_TYPE; TCP_PTR : TCP_PTR_TYPE; IP_PTR : IP_PTR_TYPE; SUBNET_PTR : SUBNET_PTR_TYPE; BYTE : BUFFER_AREA; NEXT : PACKED_BUFFER_PTR; end record; --type BUFFER_ERROR_TYPE is (RETURNING_A_BUFFER,OUT_OF_FREE_BUFFERS); procedure INIT; --This subprogram is called when the system is intialize to --create a finite number of buffers. procedure BUFFREE ( BUFPTR : in out PACKED_BUFFER_PTR; BUFFTYPE : in SIXTEEN_BITS ); --This subprogram frees a buffer to be used again. --Change buffer status to free and place it on a free list --of buffers. procedure BUFFGET ( BUFPTR : in out PACKED_BUFFER_PTR; BUFFTYPE : in SIXTEEN_BITS ); --This subprogram obtains a buffer to be used. end BUFFER_DATA; -- 5/24/85 3:20 PM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT -- 5/28/85 10:39 AM : REVISED FOR USE WITH THE DEC COMPILER -- OLD CODE (TELESOFT) MARKED WITH --&MT -- 5/28/85 11:40 AM : REVISED FOR USE WITH TELESOFT COMPILER -- OLD CODE (DEC) MARKED WITH --&MT with UNCHECKED_CONVERSION; with TEXT_IO; use TEXT_IO, LONG_INTEGER_IO; ---------------------------------------------------------------------------- -- -- Implementation for DEC VAX installation only! -- ---------------------------------------------------------------------------- package body BUFFER_DATA is --&MT THE FOLLOWING LINE SHOULD BE DELETED WHEN USING TELESOFT : --&MT package INT_IO is new INTEGER_IO( THIRTYTWO_BITS ); HEAD : PACKED_BUFFER_PTR; -- The pointer to the head of the buffer free BUFFER_COUNT : THIRTYTWO_BITS ; BUFFER_PRINT_FLAG : THIRTYTWO_BITS := 1; procedure BUFFREE ( BUFPTR : in out PACKED_BUFFER_PTR; BUFFTYPE : in SIXTEEN_BITS ) is begin if BUFPTR = null then TEXT_IO.PUT_LINE("JUST RECEIVED A NULL POINTER IN BUFFREE"); else if BUFPTR.STATUS = NONE and then NOT BUFPTR.IN_USE then BUFFER_COUNT := BUFFER_COUNT + 1; -- if BUFFER_PRINT_FLAG /= 0 then --for debug only(JB 1/25/85) --TEXT_IO.NEW_LINE; --TEXT_IO.PUT("FREEING A BUFFER. NUMBER OF FREE BU"); --TEXT_IO.LONG_INTEGER_IO.PUT(BUFFER_COUNT); --TEXT_IO.NEW_LINE; -- end if; bufptr.in_use := true; BUFPTR.NEXT := HEAD; HEAD := BUFPTR; bufptr := null; -- return a null pointer end if; end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in BUFFREE"); when others => --&MT put_line("ERROR IN BUFFREE") ; text_io.put_line ("UNKNOWN ERROR IN BUFFREE") ; end BUFFREE; procedure BUFFGET (BUFPTR : in out PACKED_BUFFER_PTR; BUFFTYPE : in SIXTEEN_BITS ) is begin BUFPTR := HEAD; if HEAD /= null then HEAD := HEAD.NEXT; bufptr.in_use := false ; bufptr.telnet_ptr := 255 ; bufptr.tcp_ptr := 255 ; bufptr.ip_ptr := 255 ; bufptr.subnet_ptr := 255 ; bufptr.status := NONE ; else text_io.put_line("BUFFER_ERROR OUT_OF_FREE_BUFFERS") ; -- for debug end if ; if BUFFER_COUNT /= 0 then BUFFER_COUNT := BUFFER_COUNT - 1; end if; -- if BUFFER_PRINT_FLAG /= 0 then--for debug only (JB 1/25/85) -- if BUFFER_COUNT /= 0 then -- TEXT_IO.NEW_LINE; -- TEXT_IO.PUT -- ("GETTING A BUFFER. NUMBER OF FREE BU"); -- TEXT_IO.INTEGER_IO.PUT(BUFFER_COUNT); -- TEXT_IO.NEW_LINE; -- else -- TEXT_IO.PUT_LINE("NO FREE BUFFERS ON BUFFER GET"); -- end if; -- end if; exception when others => TEXT_IO.PUT_LINE("ERROR IN BUFFER GET"); raise ; end BUFFGET; procedure INIT is I : THIRTYTWO_BITS ; NEXT_BUFFER : PACKED_BUFFER_PTR; begin -- get one hundred-fifty and one buffers. HEAD := new PACKED_BUFFER; NEXT_BUFFER := new PACKED_BUFFER; HEAD.NEXT := NEXT_BUFFER; for I in 1..50 loop next_buffer := new packed_buffer; buffree(next_buffer,0) ; end loop; BUFFER_COUNT := 50; --if BUFFER_PRINT_FLAG /= 0 then --TEXT_IO.PUT("THE NUMBER OF INITIAL BUFFERS IS "); --&MT INT_IO.PUT(BUFFER_COUNT); --INTEGER_IO.PUT(50) ; --TEXT_IO.NEW_LINE; --end if; exception when STORAGE_ERROR => TEXT_IO.PUT_LINE("OUT OF ROOM TO INITIALIZE BUFFERS"); when others => TEXT_IO.PUT_LINE("ERROR IN INITIALIZE BUFFERS"); end INIT; -- -- Package initialization -- begin BUFFER_COUNT := 0; -- initialize buffer count. end BUFFER_DATA; --:::::::::::::: --icmp.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01176-100(-) -- E-Systems, Inc. August 07, 1985 -- -- icmp.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with SYSTEM; use SYSTEM; with BUFFER_DATA; use BUFFER_DATA; with IP_GLOBALS; use IP_GLOBALS; package UTILITIES_FOR_ICMP is ---------------------------------------------------- --This implementation is for use with DEC/ADA -- --compiler. -- ---------------------------------------------------- -- TEMPORARY FOR TESTING -- UNTIL TCP MODULES ARE COMBINED type TCP_PORT_ADDRESS_TYPE is array(1..2) of SYSTEM.BYTE; function ICMP_CHECKSUM( START_PTR : SIXTEEN_BITS ; END_PTR : SIXTEEN_BITS ; PACKED_BUFFER : PACKED_BUFFER_PTR) return SIXTEEN_BITS ; --This function requires a pointer to the beginning of --the ICMP control message, pointer to the end of the IP header, --and pointer to the datagram. This function is compatible with --MIL-STD-1777 section 9.4.6.2.4. procedure ICMP_MESSAGE_PROCESSOR( ICMP_MESSAGE : in out PACKED_BUFFER_PTR; BUFPTR : IP_GLOBALS.BUFFER_POINTER); --This subprogram will determine what type of ICMP message has --been sent by a remote host and process the message appropiately. procedure SEND_ICMP_MESSAGE( ICMP_MESSAGE : in out PACKED_BUFFER_PTR); --This subprogram takes an ICMP message datagram and sends it to --the subnet protocol. end UTILITIES_FOR_ICMP; with BUFFER_DATA; with IP_UNPACK_AND_PACK_UTILITIES; with UNCHECKED_CONVERSION; with WITH_TCP_COMMUNICATE; with TEXT_IO; use TEXT_IO, INTEGER_IO ; package body UTILITIES_FOR_ICMP is type ERROR_TYPE is ( PARAM_PROBLEM,EXPIRED_TTL,PROTOCOL_UNREACH ); function ICMP_CHECKSUM( START_PTR : SIXTEEN_BITS ; END_PTR : SIXTEEN_BITS ; PACKED_BUFFER : BUFFER_DATA.PACKED_BUFFER_PTR) return SIXTEEN_BITS is --This function performs a checksum on the ICMP control message --For purpose of computing the checksum, the checksum field --(octets 2-3) is set to zero. Implementation dependent action. type TWO_WORDS is array (1..2) of SIXTEEN_BITS ; type TELESOFT_FIXUP is array (1..1) of THIRTYTWO_BITS ; function CONVERSION is new UNCHECKED_CONVERSION( TELESOFT_FIXUP,TWO_WORDS ); HIGH_BYTE : BOOLEAN := TRUE; ICMP_CHECKSUM : THIRTYTWO_BITS := 0; CSUM : TWO_WORDS := ( 0,0 ); CHECKSUM : TELESOFT_FIXUP; begin for I in 0..END_PTR-1 loop if ( I /= 2 ) and then ( I /= 3 ) then if HIGH_BYTE then HIGH_BYTE := FALSE; ICMP_CHECKSUM := ICMP_CHECKSUM + THIRTYTWO_BITS ( PACKED_BUFFER.BYTE( START_PTR + I ) ) * THIRTYTWO_BITS ( 2**8 ); else HIGH_BYTE := TRUE; ICMP_CHECKSUM := ICMP_CHECKSUM + THIRTYTWO_BITS ( PACKED_BUFFER.BYTE( START_PTR + I ) ); end if; end if; end loop; -- Take one's complement of ICMP_CHECKSUM ICMP_CHECKSUM := -ICMP_CHECKSUM; ICMP_CHECKSUM := ICMP_CHECKSUM - 1; -- This is a parameter passing problem globally specific to Telesoft CHECKSUM(1) := ICMP_CHECKSUM; -- Get both words and return low word. CSUM := CONVERSION( CHECKSUM ); return CSUM( 2 ); exception when constraint_error => TEXT_IO.PUT_LINE( "Checksum Error in package UTILITIES_FOR_ICMP "); TEXT_IO.PUT_LINE( "function CHECKSUM )" ); INTEGER_IO.PUT( START_PTR ); -- SYSTEM.REPORT ERROR when others => TEXT_IO.PUT_LINE( "Checksum Error in package UTILITIES_FOR_ICMP "); TEXT_IO.PUT_LINE( "function CHECKSUM )" ); end ICMP_CHECKSUM; procedure SEND_ICMP_MESSAGE (ICMP_MESSAGE : in out BUFFER_DATA.PACKED_BUFFER_PTR) is --This subprogram takes an ICMP message datagram and sends it to --the subnet protocol. begin -- X_25_DATA.LOCAL_DESTINATION_ADDRESS := ICMP_BUFPTR.DEST; -- X_25_DATA.TYPE_OF_SERVICE := ICMP_BUFPTR.TOS; -- X_25_DATA.LENGTH := ICMP_BUFPTR.TOT_LEN; -- X_25_DATA.DTGM := ICMP_MESSAGE; -- X_25_SEND(X_25_DATA); null; exception when constraint_error => TEXT_IO.PUT_LINE("constraint error in package UTILITES_FOR_ICMP "); TEXT_IO.PUT_LINE( "procedure SEND_ICMP_MESSAGE"); when others => TEXT_IO.PUT_LINE("error OTHERS in package UTILITES_FOR_ICMP procedure "); TEXT_IO.PUT_LINE( "SEND_ICMP_MESSAGE"); end SEND_ICMP_MESSAGE; procedure ICMP_MESSAGE_PROCESSOR (ICMP_MESSAGE : in out BUFFER_DATA.PACKED_BUFFER_PTR; BUFPTR : IP_GLOBALS.BUFFER_POINTER) is type GOOD_OR_BAD IS (GOOD,BAD); type TWO_BYTE is array(1..2) of SYSTEM.BYTE; type TELEGOOFUP is array(1..1) of SIXTEEN_BITS ; function CONVERT_TO_TWO_BYTES is new UNCHECKED_CONVERSION(TELEGOOFUP, TWO_BYTE); WORD_TO_CONVERT : TELEGOOFUP; TEMP : TWO_BYTE; IHL_IN_OCTETS : SIXTEEN_BITS := 0; ULP_SOURCE_PORT : TCP_PORT_ADDRESS_TYPE; ULP_DESTINATION_PORT : TCP_PORT_ADDRESS_TYPE; ICMP_ERROR_MESSAGE : STRING(1..80); IP_SOURCE_ADDRESS_TEMPORARY_SAVE_FRONT : SYSTEM.BYTE; IP_SOURCE_ADDRESS_TEMPORARY_SAVE_BACK : SYSTEM.BYTE; IP_HEADER_INFO : IP_GLOBALS.BUFFER_POINTER; IP_HEADER_POINTER : SIXTEEN_BITS := 0; IP_DATAGRAM_TOTAL_LENGTH : SIXTEEN_BITS := 0; VERSIONS : SIXTEEN_BITS := 0; IHL : SIXTEEN_BITS := 0; ICMP_TYPE : SIXTEEN_BITS := 0; ICMP_CODE : SIXTEEN_BITS :=0; START_PTR_FOR_ICMP_CHECKSUM : SIXTEEN_BITS := 0; END_PTR_FOR_ICMP_CHECKSUM : SIXTEEN_BITS := 0; TELNET_PTR : constant SIXTEEN_BITS := ICMP_MESSAGE.TELNET_PTR; TCP_PTR : constant SIXTEEN_BITS := ICMP_MESSAGE.TCP_PTR; IP_PTR : constant SIXTEEN_BITS := ICMP_MESSAGE.IP_PTR; function CHECK_ICMP_CHECKSUM return GOOD_OR_BAD is type INT_ARRAY is array(1..1) of SIXTEEN_BITS ; type TWO_BYTES is array(1..2) of SYSTEM.BYTE; function CONVERT_TO_INTEGER is new UNCHECKED_CONVERSION(TWO_BYTES,INT_ARRAY); BUF_CSUM : TWO_BYTES; CARRIER_CSUM : INT_ARRAY; INCOMING_ICMP_DATAGRAM_CHECKSUM_CARRIER : INT_ARRAY; INCOMING_ICMP_DATAGRAM_CHECKSUM_CALCULATED : INT_ARRAY; START_PRT_FOR_ICMP_CHECKSUM : SIXTEEN_BITS := 0; END_PTR_FOR_ICMP_CHECKSUM : SIXTEEN_BITS := 0; begin BUF_CSUM(1) := ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 2); BUF_CSUM(2) := ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 3); INCOMING_ICMP_DATAGRAM_CHECKSUM_CARRIER := CONVERT_TO_INTEGER(BUF_CSUM); START_PTR_FOR_ICMP_CHECKSUM := IP_HEADER_POINTER + IHL; END_PTR_FOR_ICMP_CHECKSUM := IP_HEADER_POINTER + IP_DATAGRAM_TOTAL_LENGTH; INCOMING_ICMP_DATAGRAM_CHECKSUM_CALCULATED(1) := ICMP_CHECKSUM (START_PRT_FOR_ICMP_CHECKSUM,END_PTR_FOR_ICMP_CHECKSUM,ICMP_MESSAGE); if INCOMING_ICMP_DATAGRAM_CHECKSUM_CARRIER = INCOMING_ICMP_DATAGRAM_CHECKSUM_CALCULATED then return GOOD; else return BAD; end if; end CHECK_ICMP_CHECKSUM; procedure PACK_ICMP_MESSAGE_FOR_ULP( ULP_SOURCE_PORT, ULP_DESTINATION_PORT : in TCP_PORT_ADDRESS_TYPE; ICMP_ERROR_MESSAGE : in STRING) is type STUPID is array(1..1) of CHARACTER; type A_BYTE is array(1..1) of SYSTEM.BYTE; function CONVERT_STRING_TO_SYSTEM_BYTE is new UNCHECKED_CONVERSION(STUPID,A_BYTE); OFFSET : SIXTEEN_BITS ; SLICE_SAVER : STUPID; begin -- Load message OFFSET := ICMP_ERROR_MESSAGE'LENGTH; -- Convert string to system byte for I in 0..OFFSET-1 loop -- SLICE_SAVER(1) := ICMP_ERROR_MESSAGE( I ); -- ICMP_MESSAGE.BYTE(TELNET_PTR + I) -- := CONVERT_STRING_TO_SYSTEM_BYTE(SLICE_SAVER)(1) ; null;--temp end loop; -- TCP Header Setput -- Load Source Port for I in 1..2 loop ICMP_MESSAGE.BYTE(TCP_PTR + SIXTEEN_BITS ( I ) -1) := ULP_SOURCE_PORT(I); end loop; -- Load Destination Port for I in 1..2 loop ICMP_MESSAGE.BYTE(TCP_PTR + SIXTEEN_BITS ( I ) + 2 -1) := ULP_DESTINATION_PORT(I); end loop; end PACK_ICMP_MESSAGE_FOR_ULP; procedure OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT : out TCP_PORT_ADDRESS_TYPE; IHL : SIXTEEN_BITS ) is VERSION_SENT_DATAGRAM : SIXTEEN_BITS ; IHL_SENT_DATAGRAM : SIXTEEN_BITS ; IHL_PORT_POINTER : SIXTEEN_BITS ; IHL_PORT_POINTER_SENT_DATAGRAM : SIXTEEN_BITS ; begin VERSION_SENT_DATAGRAM := SIXTEEN_BITS ( ICMP_MESSAGE.BYTE(IP_PTR + IHL + 4)/2**4 ) ; IHL_SENT_DATAGRAM := SIXTEEN_BITS ( ICMP_MESSAGE.BYTE(IP_PTR + IHL + 4) ) - (VERSION_SENT_DATAGRAM * (2**4)) * 4; IHL_PORT_POINTER_SENT_DATAGRAM := IP_PTR + IHL + 4 + IHL_SENT_DATAGRAM; ULP_SOURCE_PORT(1) := ICMP_MESSAGE.BYTE(IHL_PORT_POINTER); ULP_SOURCE_PORT(2) := ICMP_MESSAGE.BYTE(IHL_PORT_POINTER + 1); ULP_DESTINATION_PORT(1) := ICMP_MESSAGE.BYTE(IHL_PORT_POINTER + 2); ULP_DESTINATION_PORT(2) := ICMP_MESSAGE.BYTE(IHL_PORT_POINTER + 3); end OBTAIN_ULP_SOURCE_DESTINATION; begin IP_HEADER_POINTER := ICMP_MESSAGE.IP_PTR; -- Convert IHL from 32-bit word size to 8-bit OCTETS IHL_IN_OCTETS := BUFPTR.IHL * 4; ICMP_TYPE := SIXTEEN_BITS ( ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + IHL_IN_OCTETS)) ; ICMP_CODE := SIXTEEN_BITS ( ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + IHL_IN_OCTETS + 1)) ; if (BUFPTR.PROT = 1) and (CHECK_ICMP_CHECKSUM = GOOD) then case ICMP_TYPE is when 0 => -- echo reply message -- Presently not supported by this implementation version TEXT_IO.PUT_LINE(" Recieved echo reply message "); TEXT_IO.PUT_LINE(" package UTILITIES_FOR_ICMP "); TEXT_IO.PUT_LINE( "procedure ICMP_MESSAGE_PROCESSOR "); -- never recieved; always sent when 3=> -- destination unreachable messasge case ICMP_CODE is when 0 => -- net unreachable OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message for net unreachable to be displayed by ULP ICMP_ERROR_MESSAGE(1..38) := " ICMP Error Message : Net Unreachable "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 1 => -- host unreachable OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message for host unreachable to be displayed by ULP ICMP_ERROR_MESSAGE(1..39) := " ICMP Error Message : Host Unreachable "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 2 => -- protocol unreachable OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message for protocol unreachable to be displayed -- by ULP ICMP_ERROR_MESSAGE(1..43) := " ICMP Error Message : Protocol Unreachable "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 3 => -- port unreachable OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message for port unreachable to be displayed by ULP ICMP_ERROR_MESSAGE(1..39) := " ICMP Error Message : Port Unreachable "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 4 => -- fragmentation needed and Don't Fragment -- Flag is set OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..74) := " ICMP Error Message : fragmentation needed and Don't Fragment Flag is set "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 5 => -- source route failed OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..42) := " ICMP Error Message : source route failed "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when others => TEXT_IO.PUT_LINE(" Error message package UTILITIES_FOR_ICMP "); TEXT_IO.PUT_LINE( "procedure ICMP_MESSAGE_PROCESSOR case exhaustive error "); TEXT_IO.PUT_LINE(" Bogus ICMP message #3 code field "); end case; when 4 => -- Source Quench Message OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..44) := " ICMP Error Message : source quench message "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 5 => -- Redirect Message case ICMP_CODE is when 0 => -- redirect datagrams for the Network OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..57) := " ICMP Error Message : redirect datagrams for the Network "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 1 => -- redirect datagrams for the Host OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..54) := " ICMP Error Message : redirect datagrams for the Host "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 2 => -- redirect datagrams for the type of service and network OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..76) := "ICMP Error Message : redirect datagrams for the type of service and network "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 3 => -- redirect datagrams for the type of service and host OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..74) := " ICMP Error Message : redirect datagrams for the type of service and host "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when others => TEXT_IO.PUT_LINE(" Error message package UTILITIES_FOR_ICMP "); TEXT_IO.PUT_LINE( "procedure ICMP_MESSAGE_PROCESSOR case exhaustive error "); TEXT_IO.PUT_LINE(" Bogus ICMP message #5 code field "); end case; when 8 => -- Echo Message ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + IHL_IN_OCTETS) := 0; -- Echo Reply Message Type ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + IHL_IN_OCTETS + 1) := 0; -- Code field IP_SOURCE_ADDRESS_TEMPORARY_SAVE_FRONT := ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 6); IP_SOURCE_ADDRESS_TEMPORARY_SAVE_BACK := ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 7); ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 6) := ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 8); ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 7) := ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 9); ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 8) := IP_SOURCE_ADDRESS_TEMPORARY_SAVE_FRONT; ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + 9) := IP_SOURCE_ADDRESS_TEMPORARY_SAVE_BACK; START_PTR_FOR_ICMP_CHECKSUM := IP_HEADER_POINTER + IHL_IN_OCTETS; END_PTR_FOR_ICMP_CHECKSUM := IP_HEADER_POINTER + IP_DATAGRAM_TOTAL_LENGTH; -- load icmp checksum WORD_TO_CONVERT(1) := ICMP_CHECKSUM(START_PTR_FOR_ICMP_CHECKSUM,END_PTR_FOR_ICMP_CHECKSUM, ICMP_MESSAGE); TEMP := CONVERT_TO_TWO_BYTES(WORD_TO_CONVERT); -- implementation dependent (VAX) ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + IHL_IN_OCTETS + 2) := TEMP(2); ICMP_MESSAGE.BYTE(IP_HEADER_POINTER + IHL_IN_OCTETS + 3) := TEMP(1); SEND_ICMP_MESSAGE(ICMP_MESSAGE); when 12 => -- Parameter Problem Message OBTAIN_ULP_SOURCE_DESTINATION(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, IHL); -- load error message to be displayed by ULP ICMP_ERROR_MESSAGE(1..48) := " ICMP Error Message : Parameter Problem Message "; -- format ICMP error message for ULP PACK_ICMP_MESSAGE_FOR_ULP(ULP_SOURCE_PORT, ULP_DESTINATION_PORT, ICMP_ERROR_MESSAGE); when 13 => -- Timestamp Message -- not implemented null; when 14 => -- Timestamp Message Reply -- not implemented null; when 15 => -- Information Request Message -- not implemented null; when 16 => -- Information Reply -- not implemented null; when others => TEXT_IO.PUT_LINE(" Error message package UTILITIES_FOR_ICMP "); TEXT_IO.PUT_LINE( "procedure ICMP_MESSAGE_PROCESSOR case exhaustive error "); TEXT_IO.PUT_LINE(" Bogus ICMP type "); end case; else if BUFPTR.PROT /= 1 then --for fault tolertant software reliability to protect against users of --package this should never happen if package is understood by user or --runtime system is functionally properly TEXT_IO.PUT_LINE("Error message : package UTILITES_FOR_ICMP "); TEXT_IO.PUT_LINE( "procedure ICMP_MESSAGE_PROCESSOR"); TEXT_IO.PUT_LINE("procedure called with wrong protocol number"); end if; if CHECK_ICMP_CHECKSUM = BAD then TEXT_IO.PUT_LINE("Error message : package UTILITES_FOR_ICMP "); TEXT_IO.PUT_LINE( "procedure ICMP_MESSAGE_PROCESSOR"); TEXT_IO.PUT_LINE("ICMP_CHECKSUM message was BAD"); end if; end if; end ICMP_MESSAGE_PROCESSOR; end UTILITIES_FOR_ICMP; --:::::::::::::: --iparrive.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01177-100(-) -- E-Systems, Inc. August 07, 1985 -- -- iparrive.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; --WITH COMMUNICATE_AND_QUEUE; --USE COMMUNICATE_AND_QUEUE; package IP_ARRIVE_PROCESSING is ----------------------------------------------------- --This implementation is for use with the Telesoft -- --Ada compiler version 1.5 . -- ----------------------------------------------------- ------------------------------------------------------------------------------ -- THIS PACKAGE IS RESPONSIBLE FOR PROCESSING AN ARRIVED DATAGRAM RECEIVED -- -- FROM THE CHANNEL PROTOCOL MODULE. -- ------------------------------------------------------------------------------ procedure IP_DATAGRAM_ARRIVE(PACKED_BUFF : in out PACKED_BUFFER_PTR; BYTE_COUNT : in out SIXTEEN_BITS); --This subprogram is called by the ip controller when a --datagram arrives for the IP. end IP_ARRIVE_PROCESSING; with UNCHECKED_CONVERSION; with SYSTEM; with TEXT_IO; use TEXT_IO; with IP_GLOBALS; use IP_GLOBALS; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with IP_UNPACK_AND_PACK_UTILITIES; use IP_UNPACK_AND_PACK_UTILITIES; with UTILITIES_FOR_ICMP; with REASSEMBLY_UTILITIES; package body IP_ARRIVE_PROCESSING is function PHYSICAL_ADDRESS is new UNCHECKED_CONVERSION(THIRTYTWO_BITS, SYSTEM.ADDRESS); PRINT_DATAGRAM_FLAG : SIXTEEN_BITS := 1;--for debug PRINT_FLAG : SIXTEEN_BITS := 1;--for debug procedure IP_DATAGRAM_ARRIVE(PACKED_BUFF : in out PACKED_BUFFER_PTR; BYTE_COUNT : in out SIXTEEN_BITS) is --This subprogram will accept an arrived datagram check it for --correctness and if correct return it to the user layer --(TCP in our case). -- -- RESTRICTIONS : -- --We do not do any fragment reassembly or any option processing, --other than the options required by the TCP (security and precedence.) type INT_ARRAY is array(1..1) of SIXTEEN_BITS; type TWO_BYTES is array(1..2) of SYSTEM.BYTE; function CONVERT_TO_INTEGER is new UNCHECKED_CONVERSION(TWO_BYTES, INT_ARRAY); BUF_CSUM : TWO_BYTES; CARRIED_CSUM : INT_ARRAY; SECURITY_OPTION : SECURITY_OPTION_TYPE; X, IP_LENGTH_IN_OCTETS, HEADER_CHECKSUM : SIXTEEN_BITS; I : SIXTEEN_BITS := 1; DESTINATION_FAKE_HOST : BOOLEAN := FALSE; -- TEMPORARY FOR TEST *** BAD_OPTION : BOOLEAN := FALSE; BUFPTR : BUFFER_POINTER; OPTIONS_EXIST : BOOLEAN; TASK_MESSAGE : MESSAGE; IP_PARAMS : SEG_ARRIVE_PARAMS; BUFFTYPE : SIXTEEN_BITS; -- CURRENTLY IGNORED. --OUTPUT : SIXTEEN_BITS := 0; OUTPUT : FILE_TYPE; REASSEMBLY_TABLE_ELEMENT : REASSEMBLY_UTILITIES.REASSEMBLY_TABLE_POINTER; function ADDRESS_FOR_ME(ADDRESS : in THIRTYTWO_BITS) return BOOLEAN is RESULT : BOOLEAN := FALSE; begin --REMOVE RESULT := TRUE; return RESULT; --REMOVE for I in 1..MAX_HOSTS loop --***DID EXPLICIT TYPE CONVERSION TO PROVIDE CLEAN COMPILE, KELLI if ADDRESS = THIRTYTWO_BITS(MY_IP_ADDRESS(I)) then RESULT := TRUE; end if; end loop; return RESULT; end ADDRESS_FOR_ME; function ADDRESS_LEGAL(X : THIRTYTWO_BITS) return BOOLEAN is --This function searches a table in the IP global package for --the address. All legal addresses are in there. If the --address is correct a value of true is returned false --otherwise. RESULT : BOOLEAN := FALSE; I : SIXTEEN_BITS := 1; begin while I <= NUMBER_OF_ADDRESSES and (not RESULT) loop if X = VALID_ADDRESS_LIST(I) then RESULT := TRUE; end if; I := I + 1; end loop; return RESULT; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN THE ADDRESS CHECKER"); INTEGER_IO.PUT(I); when others => PUT_LINE("UNKNOWN ERROR IN THE ADDRESS CHECKER"); end ADDRESS_LEGAL; begin -- IP_LENGTH_IN_OCTETS := BUFPTR.IHL * 4; -- IT WILL WORK FOR HIGH BET SET IN A BYTE. IP_LENGTH_IN_OCTETS := (PACKED_BUFF.BYTE(PACKED_BUFF.IP_PTR) MOD 16) * 4; -- LOW 4 BITS. * 4 BYTES PER 32 BITS. -- NOTE UPPER BOUND MUST BE MOVED LATER. if IP_LENGTH_IN_OCTETS >= 20 AND (IP_LENGTH_IN_OCTETS <= 60) then -- OK HEADER_CHECKSUM := CHECKSUM(PACKED_BUFF.IP_PTR, IP_LENGTH_IN_OCTETS, PACKED_BUFF); BUF_CSUM(1) := PACKED_BUFF.BYTE(PACKED_BUFF.IP_PTR+11); -- FIRST BYTE OF CSUM BUF_CSUM(2) := PACKED_BUFF.BYTE(PACKED_BUFF.IP_PTR+10); -- LOW BYTE OF CSUM CARRIED_CSUM := CONVERT_TO_INTEGER(BUF_CSUM); else --ERROR PUT_LINE("BAD IP LENGTH"); HEADER_CHECKSUM := 0; CARRIED_CSUM(1) := 4; end if; BUFPTR := IP_UNPACK_AND_PACK_UTILITIES.UNPACK (PACKED_BUFF); -- UNPACK IT. if HEADER_CHECKSUM = CARRIED_CSUM(1) then BUFPTR := IP_UNPACK_AND_PACK_UTILITIES.UNPACK (PACKED_BUFF); -- UNPACK IT. -- SET OPTIONS EXIST FLAG. -- TESTING -- FOR VAX TESTING ***************** PRINT_DATAGRAM_FLAG := 0; OPTIONS_EXIST := BUFPTR.IP_OPTIONS(1) /= 0; if ADDRESS_LEGAL(BUFPTR.DEST) and ADDRESS_LEGAL(BUFPTR.SOURCE) then if ADDRESS_FOR_ME(BUFPTR.DEST) then -- IT'S FOR ME. if BUFPTR.TTL > 0 then -- WE CAN PROCESS IT. -- ONLY IF WE ARE PASSING IT ON WHICH WE --CURRENTLY DO NOT. --/ DECREMENT TTL BY THE TIME IT TAKES TO --DO INTERNET PROCESSING /*** -- DO ALL NECESSARY OPTION CHECKING while OPTIONS_EXIST loop case BUFPTR.IP_OPTIONS(I) is -- THE OPTION TYPE IS? when 0 => OPTIONS_EXIST := FALSE; when 1 => I := I + 1; -- A NO OPERATION. when 130 => -- SECURITY, COMPARTMENTS, HANDLING --RESTRICTIONS, AND -- TRANSMISSION CONTROL CODE OPTION. if BUFPTR.IP_OPTIONS(I + 1) = 11 and (BUFPTR.IP_OPTIONS(I + 2) <= 7) and (BUFPTR.IP_OPTIONS(I + 3) <= 7) and (BUFPTR.IP_OPTIONS(I + 2) >= 0) and (BUFPTR.IP_OPTIONS(I + 3) >= 0) and (BUFPTR.IP_OPTIONS(I + 4) = 0) and (BUFPTR.IP_OPTIONS(I + 5) = 0) and (BUFPTR.IP_OPTIONS(I + 2) = BUFPTR.IP_OPTIONS(I + 3)) then -- WE ARE OK. A GOOD OPTION -- SET UP SECURITY OPTION FOR TCP. for INDEX in I+2..I+10 loop SECURITY_OPTION(INDEX - I - 1) := BUFPTR.IP_OPTIONS(INDEX); end loop; I := I + 11; else BAD_OPTION := TRUE; OPTIONS_EXIST := FALSE; end if; when 131 => -- LOOSE SOURCE AND RECORD -- ROUTE FROM THE SOURCE -- ONLY FOR GATEWAYS OR RELAYS -- AND WE ARE CURRENTLY NOT ONE. I := I + BUFPTR.IP_OPTIONS(I + 1); when 137 => -- STRICT SOURCE AND RECORD -- ROUTE. INFORMATION TO BE -- USED BY GATEWAYS AND TO -- RECORD THE ROUTE INFORMATION -- WE ARE NOT A GATEWAY NOR DO -- WE PASS STUFF ON. I := I + BUFPTR.IP_OPTIONS(I + 1); when 7 => -- SAVE THE RETURN ROUTE, -- UNNECESSARY IF NOT A RELAY. -- PUT OUR ADDRESS IN AT PROPER -- POINT. MOVE OTHER DATA -- BEHIND ADDRESS TO ENABLE IT -- TO BE PUT IN. IF THIS -- FORCES TO USE PART OF A 32 -- BIT FIELD THEN DO ANY -- PADDING NECESSARY. I := I + BUFPTR.IP_OPTIONS(I + 1); when 136 => -- STREAM IDENTIFIER -- ACTION TBD. I := I + 4; when 68 => -- INTERNET TIMESTAMP -- ACTION TBD. I := I + BUFPTR.IP_OPTIONS(I + 1); when others => BAD_OPTION := TRUE; OPTIONS_EXIST := FALSE; end case; end loop; if not BAD_OPTION then if DESTINATION_FAKE_HOST then -- /PUT IN FAKE HOST QUEUE/ null; else -- HERE WE GIVE THE DATAGRAM TO THE TO TCP -- QUEUE TASK. THIS NOTIFIES -- THE TCP OF A DATAGRAM AS PER THE SPEC. -- TCP TAKING IT OUT OF THE -- QUEUE IS DOING AN IMPLICIT CALL ON THE -- IP. THE NECESSARY PARAMETERS -- WILL BE IN THE QUEUE RECORD. -- ALL REQUIRED FIELDS ARE IN THE BUFFER -- EXCEPT FOR THE LENGTH WHICH -- IS EXPLICITLY RETURNED. -- SET THE BYTE COUNT. THIS IS THE TCP -- LENGTH IN OCTETS. BYTE_COUNT := BUFPTR.TOT_LEN - (BUFPTR.IHL * 4); -- if PRINT_FLAG /= 0 then -- PUT_LINE("THE POINTER FOR THE BUFFER TO TCP"); -- INTEGER_IO.PUT(PACKED_BUFF.TCP_PTR); -- end if; if BUFPTR.PROT =1 then UTILITIES_FOR_ICMP.ICMP_MESSAGE_PROCESSOR (PACKED_BUFF,BUFPTR); end if; if REASSEMBLY_UTILITIES.A_FRAG (PACKED_BUFF,BUFPTR) = REASSEMBLY_UTILITIES.NO then IP_PARAMS := ( PACKED_BUFF, BYTE_COUNT, BUFPTR.SOURCE, BUFPTR.DEST, BUFPTR.PROT, BUFPTR.TOS, SECURITY_OPTION); TASK_MESSAGE := (DATA_FROM_IP, IP_PARAMS); MESSAGE_FOR_TCP(TASK_MESSAGE);--SEND TO THE TCP --if PRINT_FLAG /= 0 then --PUT("A GOOD MESSAGE FOR THE TCP"); --end if; else REASSEMBLY_UTILITIES.REASSEMBLY (PACKED_BUFF,REASSEMBLY_TABLE_ELEMENT,BUFPTR); if REASSEMBLY_UTILITIES.REASS_DONE (REASSEMBLY_TABLE_ELEMENT,BUFPTR) = REASSEMBLY_UTILITIES.YES then IP_PARAMS := (PACKED_BUFF, BYTE_COUNT, BUFPTR.SOURCE, BUFPTR.DEST, BUFPTR.PROT, BUFPTR.TOS, SECURITY_OPTION); TASK_MESSAGE := (DATA_FROM_IP, IP_PARAMS); --SEND TO THE TCP. MESSAGE_FOR_TCP(TASK_MESSAGE); --if PRINT_FLAG /= 0 then --PUT(OUTPUT,"A GOOD MESSAGE FOR THE TCP"); --end if; end if; end if; end if; else --/ERROR EXIT: ILLEGAL OPTION/ -- DELETE DATAGRAM PUT(OUTPUT,"BAD OPTION");--**TESTING BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- WE HAVE TIMED OUT SO DROP THE DATAGRAM. PUT(OUTPUT, "TIMED OUT");--** TESTING BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- /ERROR EXIT: NOT FOR ME/ -- DELETE DATAGRAM PUT(OUTPUT,"NOT FOR ME");--- DEBUG BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- / ERROR: ILLEGAL DESTINATION/ PUT(OUTPUT,"BAD DEST, OR AN INVALID SOURCE ADDRESS"); BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- BAD CHECKSUM. COUNT IT AND GET OUT PUT("BAD CHECKSUM"); BAD_CHECKSUM := BAD_CHECKSUM + 1; BUFFREE(PACKED_BUFF, BUFFTYPE); end if; --if PRINT_FLAG /= 0 then --PUT_LINE("END OF PACKET"); --NEW_LINE; -- ** TESTING ON VAX --end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN IPARRIVE"); INTEGER_IO.PUT(I); when others => PUT_LINE("ERROR IN IPARRIVE");---DEBUG raise; end IP_DATAGRAM_ARRIVE; END IP_ARRIVE_PROCESSING; -- PACKAGE --:::::::::::::: --ipcntsnd.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01178-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ipcntsnd.txt Author : Jim Baldo -- ----------------------------------------------------------------------- package INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING is ----------------------------------------------------------- --This implementation is for use with the Telesoft ada -- --compiler version 1.3d . -- ----------------------------------------------------------- ----------------------------------------------------------------------------- -- THIS PACKAGE WILL CONTAIN THE INTERNET CONTROLLER TASK AS WELL AS -- -- ALL PROCEDURES AND FUNCTIONS NECESSARY FOR IP TO TRANSMIT A DATAGRAM -- -- PER A TCP REQUEST. -- ----------------------------------------------------------------------------- procedure IP_CONTROLLER; --This subprogram gets a message from the communicate and queue --procedure it then decodes the message and calls the appropriate --procedure or function to perform the necessary action. end INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING; with IP_UNPACK_AND_PACK_UTILITIES; use IP_UNPACK_AND_PACK_UTILITIES; with UNCHECKED_CONVERSION; with TEXT_IO; use TEXT_IO, INTEGER_IO ; with IP_ARRIVE_PROCESSING; use IP_ARRIVE_PROCESSING; with IP_GLOBALS; use IP_GLOBALS; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with BUFFER_DATA; use BUFFER_DATA; with SUBNET_CALLS; use SUBNET_CALLS; with SYSTEM;---DEBUG package body INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING is procedure IP_ERROR_HANDLER(ERROR_NUMBER : SIXTEEN_BITS) is --This subprogram will be called to handle errors that occur during --the course of IP processing. begin PUT_LINE("IP ERROR HANDLER WAS CALLED"); end IP_ERROR_HANDLER; procedure SEND_IP(SRC, DEST : THIRTYTWO_BITS; TOS, TTL : SIXTEEN_BITS; PACKED_BUFF : in out PACKED_BUFFER_PTR; LEN, ID, DF : SIXTEEN_BITS; OPTIONS : in IP_GLOBALS.OPTION_TYPE) is --This subprogram takes a segment from the user layer(TCP) and wraps --it in a datagram. It checks to make sure a viable call has been --made. It will send a formatted datagram to the subnet protocol --SUBNET. It is called by the IP controller after the TCP has --requested that a segment be sent wrapped in a datagram. The --following is a description of the parameters: -- -- SRC - THE SOURCE ADDRESS OF THE DATAGRAM. -- DEST - THE DESTINATION OF THE DATAGRAM. -- TOS - THE TYPE OF SERVICE DESIRED BY THE TCP(USER APPLICATION). -- TTL - THE TIME TO LIVE FOR THE DATAGRAM. -- LEN - THE NUMBER OF OCTETS IN THE BUFFER. -- ID - VARIABLE THAT IS SET BY THE SENDER TO HELP IN REASSEMBLING -- FRAGMENTS. -- DF - THE DONT FRAGMENT BIT. ALWAYS SET IN OUR CASE. -- OPTIONS - THE ARRAY THAT CONTAINS THE OPTIONS THAT THE TCP OR -- USER WISHES TO HAVE IMPLEMENTED. type TEST_RESULT is (CORRECT, INCORRECT); ROUTINE_VAR : PRECEDENCE_TYPE := ROUTINE; NORMAL_REL_VAR : RELIABILITY_TYPE := NORMAL; NORMAL_DEL_VAR : DELAY_TYPE := NORMAL; NORMAL_THRO_VAR : THROUGHPUT_TYPE := NORMAL; TASK_MESSAGE : MESSAGE; IP_PARAMS : SEG_ARRIVE_PARAMS; BUFPTR : IP_GLOBALS.BUFFER_POINTER; BYTE_COUNT : SIXTEEN_BITS := 0; CURRENT_VERSION : constant SIXTEEN_BITS := 4; TCP : constant SIXTEEN_BITS := 5; INDEX : SIXTEEN_BITS := 1; ERROR : SIXTEEN_BITS; PROPER_DESTINATION, OPTION_CHECK : TEST_RESULT; OPTIONS_REQUESTED_BY_IP_EXIST : BOOLEAN := FALSE;-- NONE NOW TCP_OPTIONS : WITH_TCP_COMMUNICATE.SECURITY_OPTION_TYPE ; function OPTION_CHECKER ( OPTIONS : IP_GLOBALS.OPTION_TYPE) return TEST_RESULT is --This function will check that the options have been --correctly supplied in the option array. It will return the --result of the test. --The security values have been mapped to the integers in the --following manner: -- -- 00000000 00000000 - UNCLASSIFIED => 0 -- 11110001 00110101 - CONFIDENTIAL => 1 -- 01111000 10011010 - EFTO => 2 -- 10111100 01001101 - MMMM => 3 -- 01011110 00100110 - PROG => 4 -- 10101111 00010011 - RESTRICTED => 5 -- 11010111 10001000 - SECRET => 6 -- 01101011 11000101 - TOP SECRET => 7 RESULT : TEST_RESULT := CORRECT; OPTION_NOT_CORRECT, OPTIONS_EXIST : BOOLEAN; I : SIXTEEN_BITS := 1; begin while OPTIONS(I) /= 0 and then (RESULT = CORRECT) loop -- WE MUST DETERMINE THE TYPE AND CHECK THE TYPE --VALIDITY. case OPTIONS(I) is when 1 => null; when 130 => -- SECURITY OPTION if OPTIONS(I + 1) /= 11 then RESULT := INCORRECT; else case OPTIONS(I + 2) is -- 0 - 7 MAP TO THE 8 --LEGAL VALUES FOR SECURITY. when 0 | 1 |2 | 3 | 4 | 5 | 6 | 7 => null; when others => RESULT := INCORRECT; end case; if RESULT = CORRECT then case OPTIONS(I + 3) is -- 0 - 7 MAP TO THE 8 LEGAL --VALUES FOR SECURITY. when 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 => null; when others => RESULT := INCORRECT; end case; end if; if RESULT = CORRECT and (OPTIONS(I + 4) = 0) and (OPTIONS(I + 5) = 0) then if OPTIONS(I + 2) /= OPTIONS(I + 3) then RESULT := INCORRECT; end if; else RESULT := INCORRECT; end if; -- HERE WE WOULD CHECK OTHER --FIELDS WHICH ARE CURRENTLY --UNKNOWN IN FORMAT I := I + 11; end if; when 131 | 137 | 7 => -- LOOSE SOURCE AND RECORD --ROUTE, STRICT SOURCE AND --RECORD ROUTE, AND RECORD --ROUTE OPTIONS RESPECTIVELY. -- WE WILL CHECK FOR A VALID --POINTER. if (OPTIONS(I + 2) < 4) or (OPTIONS(I + 2) > (OPTIONS(I + 1) + 1)) then RESULT := INCORRECT; end if; I := I + OPTIONS(I +1); --UPDATE THE INDEX. when 136 => -- STREAM IDENTIFIER -- CHECK FOR PROPER LENGTH. WE --DON'T KNOW WHAT THE PROPER --STREAM ID IS. if OPTIONS(I + 1) /= 4 then RESULT := INCORRECT; end if; I := I + 4; -- ADVANCE INDEX when 68 => -- THE INTERNET TIMESTAMP OPTION -- CHECK LENGTH AND POINTER if OPTIONS(I + 1) >= 40 or (OPTIONS(I + 1) < 12) then RESULT := INCORRECT; elsif OPTIONS(I + 2) < 5 then RESULT := INCORRECT; end if; I := I + OPTIONS(I + 1); -- ADVANCE INDEX when others => -- A BAD TYPE RESULT := INCORRECT; end case; end loop; return RESULT; end OPTION_CHECKER; function DESTINATION_CHECK (DEST : THIRTYTWO_BITS) return TEST_RESULT is --This subprogram will check that the requested destination is --legal. RESULT : TEST_RESULT := INCORRECT; DONE : BOOLEAN := FALSE; I : SIXTEEN_BITS := 1; begin while I <= NUMBER_OF_ADDRESSES and (not DONE) loop if DEST = VALID_ADDRESS_LIST(I) then RESULT := CORRECT; DONE := TRUE; end if; -- NEXT ENTRY I := I + 1; end loop; return RESULT; end DESTINATION_CHECK; function OPTION_OCTETS(X : IP_GLOBALS.OPTION_TYPE) return SIXTEEN_BITS is --Option_octets will determine how many option octets there --are in an IP header. It determines the number by looking --at the length field of each existent option type and adding --them up. The total is then returned to the caller. This --routine knows the option format. One octet is contained --in each element of the option array x. I : SIXTEEN_BITS := 1; OCTET_COUNT : SIXTEEN_BITS := 0; OPTION_LENGTH : SIXTEEN_BITS; begin -- WE WILL PUT ONE OCTET IN PER 16 BITS. while X(I) /= 0 and then (X(I + 1) > 0) loop OPTION_LENGTH := X(I + 1); OCTET_COUNT := OCTET_COUNT + OPTION_LENGTH; I := I + X(I + 1); -- NEXT OPTION FIELD. end loop; if OCTET_COUNT /= ((OCTET_COUNT/4)*4) then OCTET_COUNT := ((OCTET_COUNT/4) + 1) * 4; -- PAD WITH OCTETS. end if; return OCTET_COUNT; end OPTION_OCTETS; begin -- CHECK ALL PARAMETERS ON SEND CALL HERE. ARE ANY NOT CHECKED?? PROPER_DESTINATION := DESTINATION_CHECK(DEST); ERROR := 0; if PROPER_DESTINATION = INCORRECT then ERROR := 1; elsif (TOS > 256) or (TOS < 0) then ERROR := 2; elsif (TTL > 255) or (TTL < 0) then -- TIMES ARE IN SECONDS. ERROR := 3; else OPTION_CHECK := OPTION_CHECKER(OPTIONS); if OPTION_CHECK = INCORRECT then ERROR := 4; end if; end if; if ERROR /= 0 then NEW_LINE; PUT("BAD PACKET FOR TRANSMIT"); --** TEMP INTEGER_IO.PUT( ERROR); --** TEMP NEW_LINE; PACKED_BUFF.IN_USE := FALSE; BUFFREE(PACKED_BUFF, 1); -- TEMPORARY FOR TEST** IP_ERROR_HANDLER(ERROR); else -- FORMAT AN IP HEADER BUFPTR.VERSION := CURRENT_VERSION; BUFPTR.TOS := TOS; BUFPTR.ID := ID; BUFPTR.FLAGS := 2; -- REALLY THREE BITS (010) MEANS DONT FRAGMENT. BUFPTR.FRAG_OFFSET := 0; -- WE DO NOT FRAGMENT. BUFPTR.TTL := TTL; -- TIME TO LIVE (TBD) BUFPTR.PROT := TCP; -- PROTOCOL NUMBERS DEFINED IN RFC 870 BUFPTR.SOURCE := SRC; BUFPTR.DEST := DEST; -- SET UP TRANSMIT OPTIONS AS REQUESTED BY THE ABOVE --LAYER(TCP). COPY ARRAY. BUFPTR.IP_OPTIONS := OPTIONS; -- CURRENTLY IP WILL NOT REQUEST ANY OPTIONS. LATER -- SWITCHES MAY BE SET. TO CAUSE OPTIONS TO BE USED. while OPTIONS_REQUESTED_BY_IP_EXIST loop --/PUT IN ANY NEW OPTIONS IN THE PROPER PLACE/ --/ INCREMENT OPTIONS_OCTET COUNT THE PROPER AMOUNT./ null; end loop; -- SET UP THE INTERNET HEADER LENGTH BUFPTR.IHL := 5 + OPTION_OCTETS(BUFPTR.IP_OPTIONS)/4; BUFPTR.TOT_LEN := (BUFPTR.IHL * 4) + LEN; -- THE TOTAL NUMBER OF OCTETS IN THE -- DATAGRAM INCLUDING HEADER AND DATA. -- DETERMINE AND FILL IN THE CHECKSUM. DONE ON THE PACK -- PACK THE BUFFER UP IP_UNPACK_AND_PACK_UTILITIES.PACK_BUFFER_INTO_BIT_STREAM (BUFPTR, PACKED_BUFF); --/ SEND IT ON TO THE CHANNEL PROTOCOL MODULE/ SNP.SEND (PACKED_BUFF, LOCAL_ADDRESS_TYPE( DEST ), ROUTINE_VAR, NORMAL_REL_VAR, NORMAL_DEL_VAR, NORMAL_THRO_VAR, DATAGRAM_LENGTH( BUFPTR.TOT_LEN ) ); end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN SEND_IP ROUTINE OF IP SYSTEM"); when others => PUT_LINE("ERROR IN SEND_IP ROUTINE OF IP SYSTEM"); end SEND_IP; procedure IP_CONTROLLER is --This subprogram is responsible for controlling all the IP --functions. It will get messages from the layers above and below. --The only options implemented will be the required security and --precedence as required by the TCP(transmit side). We will accept --but not necessarily process all options (receive side). We do not --implement fragmentation and reassembly currently. We also cannot --act as a gateway at this time. We do not actually get called by the --TCP to return an arrived datagram but it is done in an implicit sort --of fashion described in the IP_DATAGRAM_RECEIVE procedure. MESSAGE_TO_IP : WITH_IP_COMMUNICATE.IP_MESSAGE; begin -- GET THE REQUEST FOR ACTION FROM THE COMMUNICATE TASK. -- COMMUNICATE_BETWEEN_LAYERS.IP_WAIT(MESSAGE_TO_IP); IP_WAIT(MESSAGE_TO_IP); case MESSAGE_TO_IP.EVENT is when RECEIVE_IP => null; -- WE CURRENTLY DO NOT GET -- CALLED BY THE TCP TO RETURN -- A BUFFER. when ERROR_MESSAGE => -- CALL ERROR_HANDLER IP_ERROR_HANDLER(MESSAGE_TO_IP.ERROR_NUMBER); when DATA_FROM_SUBNET => IP_DATAGRAM_ARRIVE( MESSAGE_TO_IP.BUFPTR, MESSAGE_TO_IP.BYTE_COUNT); when IP_SEND => SEND_IP( MESSAGE_TO_IP.SRC, MESSAGE_TO_IP.DEST, MESSAGE_TO_IP.TOS, MESSAGE_TO_IP.TTL, MESSAGE_TO_IP.BUFPTR, MESSAGE_TO_IP.LEN, MESSAGE_TO_IP.ID, MESSAGE_TO_IP.DF, MESSAGE_TO_IP.OPTIONS); when NO_IP_ACTION => --TEXT_IO.PUT_LINE("NO_IP_ACTION"); null; end case; exception when CONSTRAINT_ERROR => PUT_LINE("FAILED IN IPCNTSND/ CONSTRAINT ERROR"); when others => PUT_LINE("FAILED IN IPCNTSND"); end IP_CONTROLLER; end INTERNET_PROTOCOL_CONTROL_AND_SEND_PROCESSING; -- PACKAGE --:::::::::::::: --ipglb.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01179-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ipglb.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA ; use BUFFER_DATA ; with SYSTEM; use SYSTEM; with TEXT_IO; use TEXT_IO; package IP_GLOBALS is ----------------------------------------------- --This implementation is for use with the -- --DEC/Ada compiler . -- ----------------------------------------------- ------------------------------------------------------------------------------ -- THIS SPECIFICATION CONTAINS ALL NECESSARY GLOBAL VARIABLES FOR THE -- -- INTERNET PROTOCOL. -- ------------------------------------------------------------------------------ subtype LOCAL_ADDRESS_TYPE is SIXTEEN_BITS ; NUMBER_OF_ADDRESSES : constant SIXTEEN_BITS := 4; -- TEMPORARY VALUE *** MAX_HOSTS : constant SIXTEEN_BITS := 4; -- TEMP. type MY_ADDRESS_LIST is array(1..MAX_HOSTS) of LOCAL_ADDRESS_TYPE ; type ADDRESS_LIST is array(1..NUMBER_OF_ADDRESSES) of THIRTYTWO_BITS ; VALID_ADDRESS_LIST : constant ADDRESS_LIST := (1, 2, 3, 128); MY_IP_ADDRESS : constant MY_ADDRESS_LIST := (1,2,3,128); -- TEMPORARY ** BAD_CHECKSUM : SIXTEEN_BITS := 0; WHOIAM : constant THIRTYTWO_BITS := 3 ; subtype SEVEN_BITS is SIXTEEN_BITS ; subtype TEN_BITS is SIXTEEN_BITS ; subtype THREE_BITS is SIXTEEN_BITS ; subtype TWO_BITS is SIXTEEN_BITS ; subtype FOUR_OCTETS is THIRTYTWO_BITS ; subtype TWO_OCTETS is SIXTEEN_BITS ; subtype ONE_OCTET is SIXTEEN_BITS ; subtype HALF_OCTET is SIXTEEN_BITS ; subtype SIX_BITS is SIXTEEN_BITS ; subtype ONE_BIT is SIXTEEN_BITS ; subtype BTYPE_TYPE is SIXTEEN_BITS ; subtype OPTION_TYPE_RANGE is SIXTEEN_BITS range 1..50; type OPTION_TYPE is array(OPTION_TYPE_RANGE) of SIXTEEN_BITS ; type BUFFER_POINTER is record BTYPE : BTYPE_TYPE; VERSION : HALF_OCTET; IHL : HALF_OCTET; TOS : ONE_OCTET; TOT_LEN : TWO_OCTETS; ID : TWO_OCTETS; FLAGS : THREE_BITS; FRAG_OFFSET : TWO_OCTETS; TTL : ONE_OCTET; PROT : ONE_OCTET; IPCSUM : TWO_OCTETS; SOURCE : FOUR_OCTETS; DEST : FOUR_OCTETS; --OPTIONS FOR IP HERE. IP_OPTIONS : OPTION_TYPE := (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0); end record; type PRECEDENCE_TYPE is ( NETWORK_CONTROL, -- 111 INTERNETWORK_CONTROL, -- 110 CRITIC_ECP, -- 101 FLASH_OVERRIDE, --100 FLASH, --011 IMMEDIATE, --010 PRIORITY, --001 ROUTINE); --000 type RELIABILITY_TYPE is ( NORMAL, HIGH); type DELAY_TYPE is ( NORMAL, LOW); type THROUGHPUT_TYPE is ( NORMAL, HIGH); subtype DATAGRAM_LENGTH is SIXTEEN_BITS ; type RESULT_TYPE is (OK, NOK); type IP_ACTION is ( IP_SEND, ERROR_MESSAGE, DATA_FROM_SUBNET, FROM_TCP, RECEIVE_IP, NO_IP_ACTION ) ; type IP_MESSAGE(EVENT : IP_ACTION := IP_SEND) is record BUFPTR : PACKED_BUFFER_PTR := null; case EVENT is when IP_SEND => LOCAL_DESTINATION : LOCAL_ADDRESS_TYPE ; PRECEDENCE : PRECEDENCE_TYPE := ROUTINE; RELIABILITY : RELIABILITY_TYPE := NORMAL; DELAY_IP : DELAY_TYPE := NORMAL; THROUGHPUT : THROUGHPUT_TYPE := NORMAL; LENGTH : DATAGRAM_LENGTH := 0 ; when ERROR_MESSAGE => ERROR_NUMBER : SIXTEEN_BITS ; when RECEIVE_IP => SOURCE : THIRTYTWO_BITS ; PROT : SIXTEEN_BITS ; RESULT : RESULT_TYPE; when FROM_TCP => DEST : THIRTYTWO_BITS ; TOS, TTL, LEN, ID, DF : SIXTEEN_BITS ; OPTIONS : OPTION_TYPE ; SRC : THIRTYTWO_BITS ; when DATA_FROM_SUBNET => BYTE_COUNT : SIXTEEN_BITS ; when NO_IP_ACTION => null; end case; end record; end IP_GLOBALS; --:::::::::::::: --lcnkeep.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01180-100(-) -- E-Systems, Inc. August 07, 1985 -- -- lcnkeep.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with T_TCP_GLOBALS_DATA_STRUCTURES; use T_TCP_GLOBALS_DATA_STRUCTURES; package TCB_ALLOCATOR is ----------------------------------------------------------- --This implementation is for use with the DEC/Ada -- --compiler . -- ----------------------------------------------------------- procedure TCB_CLEAR( LCN : in TCB_PTR); --This subprogram reintializes a TCB. procedure TCB_FREE (LCN : in out TCB_PTR); --This subprogram frees a buffer to be used again. --If TCB is not returned null, the TCB was not found --on the TCB_IN_USE_LIST. function TCB_GET return TCB_PTR; --This subprogram obtains a buffer to be used. --If TCB is returned null, the TCB_FREE_LIST resource is --empty. function OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE return TCB_PTR; --The function returns the head of a queue containing --all current active LCNs in use. end TCB_ALLOCATOR; with BUFFER_DATA ; use BUFFER_DATA ; with MODULO; use MODULO; with UNCHECKED_CONVERSION; with TEXT_IO; use TEXT_IO; with SYSTEM; package body TCB_ALLOCATOR is TCB_FREE_LIST_HEAD : TCB_PTR; -- The pointer to the head of the buffer free TCB_FREE_LIST_BUFFER_COUNT : SIXTEEN_BITS ; TCB_IN_USE_LIST_HEAD : TCB_PTR := null; --Pointer to the head of buffers currently --being used. TCB_IN_USE_LIST_BUFFER_COUNT : SIXTEEN_BITS ; function PHYSICAL_ADDRESS is new UNCHECKED_CONVERSION( THIRTYTWO_BITS , SYSTEM.ADDRESS); CURRENT_LIST_POINTER : TCB_PTR; PRIOR_LIST_POINTER : TCB_PTR; procedure TCB_CLEAR( LCN : in TCB_PTR) is begin LCN.STATE := CLOSED; LCN.CONNECTION_STATUS := CONNECTION_CLOSED; LCN.LOCAL_PORT := -1; LCN.LOCAL_NET :=0; LCN.LOCAL_HOST :=3; LCN.SOURCE_ADDRESS := 3; LCN.DESTINATION_ADDRESS := 0; LCN.FOREIGN_PORT := -1; LCN.FOREIGN_HOST := -1; LCN.FOREIGN_NET := -1; LCN.SND_UNA := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 ) ); LCN.SND_UP := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 ) ); LCN.SND_NXT := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 ) ); LCN.SND_WND := 190; LCN.RCV_NXT := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 ) ); LCN.PRECEDENCE := 0; LCN.USER_NOTIFICATION := FALSE; LCN.SECURITY := SECURE_CLEAR; LCN.BUFFSIZE := 0; LCN.RCV_BUFFER_SIZE := -1; LCN.RCV_URGENT_POINTER := 0; LCN.SND_WL1 := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 ) ); LCN.SND_WL2 := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 ) ); LCN.RCV_WINDOW := 190; LCN.INIT_RCV_SEQ_NUM := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 ) ); LCN.ISS := MODULAR_CONVERT( THIRTYTWO_BITS ( 0 )); LCN.RETRANS_INTERVAL := 30; LCN.MAX_RETRY_OF_PACKET := 0; LCN.PROTOCOL :=0; LCN.ACTIVE_PASSIVE := ACTIVE; LCN.CLOSE_PENDING := FALSE; LCN.ERROR_TABLE := ERROR_TABLE_CLEAR; LCN.QHEADS :=INITIAL_QUEUE_HEADER_POINTERS; LCN.IDENT := -1; LCN.RETRANS_IDENT := 0; LCN.NEXT_CONNECTION_TIMEOUT := 0; LCN.NEXT_TIME_WAIT_TIMEOUT := 0; LCN.CONNECTION_TIMEOUT := 180; LCN.CLOSE_OK_NOTIFICATION := FALSE; end TCB_CLEAR; procedure TCB_FREE (LCN : in out TCB_PTR) is begin PRIOR_LIST_POINTER := null; -- intialize --Remove TCB from in_use list CURRENT_LIST_POINTER := TCB_IN_USE_LIST_HEAD; while LCN /= CURRENT_LIST_POINTER and (CURRENT_LIST_POINTER /= null) loop PRIOR_LIST_POINTER := CURRENT_LIST_POINTER; CURRENT_LIST_POINTER := CURRENT_LIST_POINTER.NEXT; end loop; if CURRENT_LIST_POINTER /= null then -- Update TCB_IN_USE_LIST_HEAD and remove from list if PRIOR_LIST_POINTER.NEXT = null and (CURRENT_LIST_POINTER.NEXT /= null ) then --new head TCB_IN_USE_LIST_HEAD := CURRENT_LIST_POINTER.NEXT; elsif PRIOR_LIST_POINTER /= null and ( CURRENT_LIST_POINTER.NEXT /= null ) then PRIOR_LIST_POINTER.NEXT := CURRENT_LIST_POINTER.NEXT; elsif PRIOR_LIST_POINTER /= null and ( CURRENT_LIST_POINTER.NEXT = null ) then PRIOR_LIST_POINTER.NEXT := null ; else -- empty list TCB_IN_USE_LIST_HEAD := null ; end if ; --Place TCB on free list TCB_FREE_LIST_BUFFER_COUNT := TCB_FREE_LIST_BUFFER_COUNT + 1; -- ALWAYS INCREMENT LCN.NEXT := TCB_FREE_LIST_HEAD; TCB_FREE_LIST_HEAD := LCN; LCN := null; -- RETURN A NULL POINTER end if; exception when CONSTRAINT_ERROR => --PUT_LINE("Constraint error in TCB_FREE"); null; when OTHERS => PUT_LINE("UNKNOWN ERROR IN TCB_FREE"); end TCB_FREE; function TCB_GET return TCB_PTR is begin --Remove buffer from free list LCN := TCB_FREE_LIST_HEAD; if TCB_FREE_LIST_HEAD /= null then TCB_FREE_LIST_HEAD := TCB_FREE_LIST_HEAD.NEXT ; --Place buffer on in_use list LCN.NEXT := TCB_IN_USE_LIST_HEAD; TCB_IN_USE_LIST_HEAD := LCN; --Decrement counter TCB_FREE_LIST_BUFFER_COUNT := TCB_FREE_LIST_BUFFER_COUNT - 1; --Increment counter TCB_IN_USE_LIST_BUFFER_COUNT := TCB_IN_USE_LIST_BUFFER_COUNT + 1 ; return LCN; else LCN := null;-- out of buffers return LCN; end if ; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("ERROR/CONSTRAINT IN TCB_GET"); -- SYSTEM.REPORT_ERROR; when others => TEXT_IO.PUT_LINE("ERROR IN TCB_GET"); -- SYSTEM.REPORT_ERROR; end TCB_GET; procedure TCB_INIT is --This subprogram is called when the system is intialize to --create a finite number of buffers. I : SIXTEEN_BITS ; NEXT_BUFFER : TCB_PTR; begin -- Telesoft does not allow the elboration durning instantiation RESERVE := new TRANSMISSION_CONTROL_BLOCK; -- get 20 buffers. TCB_FREE_LIST_HEAD := new TRANSMISSION_CONTROL_BLOCK; NEXT_BUFFER := new TRANSMISSION_CONTROL_BLOCK; TCB_FREE_LIST_HEAD.NEXT := NEXT_BUFFER; for I in 1..18 loop NEXT_BUFFER.NEXT := new TRANSMISSION_CONTROL_BLOCK; -- Link them NEXT_BUFFER := NEXT_BUFFER.NEXT ; end loop; TCB_FREE_LIST_BUFFER_COUNT := 20; TCB_IN_USE_LIST_BUFFER_COUNT := 0; exception when STORAGE_ERROR => TEXT_IO.PUT_LINE("OUT OF ROOM TO INITIALIZE TCB BUFFERS"); end TCB_INIT; function OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE return TCB_PTR is begin return TCB_IN_USE_LIST_HEAD; end OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; begin TCB_FREE_LIST_BUFFER_COUNT := 0; -- initialize buffer count. TCB_INIT; CURRENT_LIST_POINTER := new TRANSMISSION_CONTROL_BLOCK; PRIOR_LIST_POINTER := new TRANSMISSION_CONTROL_BLOCK; end TCB_ALLOCATOR; --:::::::::::::: --modulo.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01181-100(-) -- E-Systems, Inc. August 07, 1985 -- -- modulo.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA ; use BUFFER_DATA ; package MODULO is type MODULAR is private; -- ONLY THE FOLLOWING OPERATIONS ARE DEFINED. function "<" (X,Y: MODULAR) return BOOLEAN; function "<=" (X,Y: MODULAR) return BOOLEAN; function ">" (X,Y: MODULAR) return BOOLEAN; function ">=" (X,Y : MODULAR) return BOOLEAN; function "+" (X,Y: MODULAR) return MODULAR; function "+" (X: MODULAR;Y : THIRTYTWO_BITS) return MODULAR; function "+" (X : THIRTYTWO_BITS;Y : MODULAR) return MODULAR; function "+" (X : MODULAR; Y : SIXTEEN_BITS) return MODULAR; function "+" (X : SIXTEEN_BITS; Y : MODULAR) return MODULAR; function "-" (X : MODULAR; Y : SIXTEEN_BITS) return MODULAR; function "-" (X,Y: MODULAR) return MODULAR; function LONG(X : MODULAR) return THIRTYTWO_BITS; function MODULAR_CONVERT (X : SIXTEEN_BITS) return MODULAR; function MODULAR_CONVERT (X : THIRTYTWO_BITS) return MODULAR; function GET_MODULAR(PP:STRING) return MODULAR; procedure PUT_MODULAR(PP : MODULAR); private type MODULAR is record NUM : THIRTYTWO_BITS; --RANGE 0..2**32 end record; -- CAN DECLARE ANY NECESSARY VARIABLES HERE. end MODULO; with TEXT_IO; package body MODULO is function LONG(X : MODULAR) return THIRTYTWO_BITS is begin return X.NUM; end LONG; function MODULAR_CONVERT (X : SIXTEEN_BITS) return MODULAR is Y : MODULAR; begin Y.NUM := THIRTYTWO_BITS(X); return Y; exception when CONSTRAINT_ERROR => -- PUT_LINE("CONSTRAINT ERROR IN INT MODULAR_CONVERT"); raise; when others => -- PUT_LINE("ERROR IN INT MODULAR_CONVERT"); raise; end; function MODULAR_CONVERT (X : THIRTYTWO_BITS) return MODULAR is Y : MODULAR; begin Y.NUM := X; return Y; exception when CONSTRAINT_ERROR => -- PUT_LINE("CONSTRAINT ERROR IN LONG_INT MODULAR_CONVERT"); raise; when others => -- PUT_LINE("ERROR IN LONG_INT MODULAR_CONVERT"); raise; end; procedure PUT_MODULAR(PP : MODULAR) is begin TEXT_IO.PUT("THE ANSWER IS "); TEXT_IO.LONG_INTEGER_IO.PUT(PP.NUM); TEXT_IO.PUT_LINE(""); end; function GET_MODULAR(PP:STRING) return MODULAR is VAL : MODULAR; begin TEXT_IO.PUT_LINE(PP); -- TEXT_IO.LONG_INTEGER_IO.GET(VAL.NUM); TEXT_IO.PUT_LINE(""); return VAL; end; function "+" (X : SIXTEEN_BITS; Y : MODULAR) return MODULAR is Z : MODULAR; begin Z.NUM := THIRTYTWO_BITS(X) + Y.NUM; return Z; exception when NUMERIC_ERROR => return Z; when CONSTRAINT_ERROR => return Z; end; function "+" (X : MODULAR; Y : SIXTEEN_BITS) return MODULAR is Z : MODULAR; begin Z.NUM := X.NUM + THIRTYTWO_BITS(Y); return Z; exception when NUMERIC_ERROR => return Z; when CONSTRAINT_ERROR => return Z; end; function "+" (X : THIRTYTWO_BITS;Y : MODULAR) return MODULAR is Z : MODULAR; begin Z.NUM := X + Y.NUM; return Z; exception when NUMERIC_ERROR => return Z; when CONSTRAINT_ERROR => return Z; end; function "+" (X : MODULAR;Y : THIRTYTWO_BITS) return MODULAR is Z : MODULAR; begin Z.NUM := X.NUM + Y; return Z; end; function "+" (X,Y: MODULAR) return MODULAR is Z : MODULAR; begin Z.NUM := X.NUM + Y.NUM; return Z; exception when NUMERIC_ERROR => return Z; when CONSTRAINT_ERROR => return Z; end; function "<=" (X,Y : MODULAR) return BOOLEAN is RESULT : BOOLEAN; begin if X = Y then RESULT := TRUE; else if ((X.NUM >= 0) and (Y.NUM >= 0)) or ((X.NUM <= 0) and (Y.NUM <= 0)) then if X.NUM < Y.NUM then RESULT := TRUE; else RESULT := FALSE; end if; elsif (X.NUM < -1048576) or (X.NUM > 1048576) then -- ACTUALL + OR - 2**20 -- WE ARE IN THE MIDDLE if X.NUM < 0 then RESULT := FALSE; else RESULT := TRUE; end if; else -- WRAP AROUND HAS OCCURRED if X.NUM >= 0 then RESULT := FALSE; else RESULT := TRUE; end if; end if; end if; return RESULT; end; function "<" (X,Y : MODULAR) return BOOLEAN is RESULT : BOOLEAN; begin if ((X.NUM >= 0) and (Y.NUM >= 0)) or ((X.NUM <= 0) and (Y.NUM <= 0)) then if X.NUM < Y.NUM then RESULT := TRUE; else RESULT := FALSE; end if; elsif (X.NUM < -1048576) or (X.NUM > 1048576) then -- ACTUALL + OR - 2**20 -- WE ARE IN THE MIDDLE if X.NUM < 0 then RESULT := FALSE; else RESULT := TRUE; end if; else -- WRAP AROUND HAS OCCURRED if X.NUM >= 0 then RESULT := FALSE; else RESULT := TRUE; end if; end if; return RESULT; end; function ">=" (X,Y : MODULAR) return BOOLEAN is RESULT : BOOLEAN; begin if X = Y then RESULT := TRUE; else if ((X.NUM >= 0) and (Y.NUM >= 0)) or ((X.NUM <= 0) and (Y.NUM <= 0)) then if X.NUM < Y.NUM then RESULT := FALSE; else RESULT := TRUE; end if; elsif (X.NUM < -1048576) or (X.NUM > 1048576) then --ACTUALLY + OR -2**20 -- WE ARE IN THE MIDDLE if X.NUM < 0 then RESULT := TRUE; else RESULT := FALSE; end if; else -- WRAP AROUND HAS OCCURRED if X.NUM >= 0 then RESULT := TRUE; else RESULT := FALSE; end if; end if; end if; return RESULT; end; function ">" (X,Y : MODULAR) return BOOLEAN is RESULT : BOOLEAN; begin if ((X.NUM >= 0) and (Y.NUM >= 0)) or ((X.NUM <= 0) and (Y.NUM <= 0)) then if X.NUM <= Y.NUM then RESULT := FALSE; else RESULT := TRUE; end if; elsif (X.NUM < -1048576) or (X.NUM > 1048576) then --ACTUALLY + OR -2**20 -- WE ARE IN THE MIDDLE if X.NUM < 0 then RESULT := TRUE; else RESULT := FALSE; end if; else -- WRAP AROUND HAS OCCURRED if X.NUM >= 0 then RESULT := TRUE; else RESULT := FALSE; end if; end if; return RESULT; end; function "-" (X : MODULAR; Y : SIXTEEN_BITS) return MODULAR is MDIFF : MODULAR; begin if X.NUM >= THIRTYTWO_BITS(Y) then -- NORMAL SUBTRACTION MDIFF.NUM := X.NUM - THIRTYTWO_BITS(Y); else -- X HAS WRAPPED AROUND MDIFF.NUM := X.NUM - THIRTYTWO_BITS(Y) + 2147483647 + 2 + 2147483647; --ADD IN 2**32 -- GET THE ABSOLUTE VALUE OF MDIFF.NUM if MDIFF.NUM < 0 then MDIFF.NUM := -MDIFF.NUM; end if; end if; return MDIFF; exception when NUMERIC_ERROR => return MDIFF; when CONSTRAINT_ERROR => return MDIFF; end; function "-" (X, Y : MODULAR) return MODULAR is MDIFF : MODULAR; begin if X.NUM >= Y.NUM then -- NORMAL SUBTRACTION MDIFF.NUM := X.NUM - Y.NUM; else -- X HAS WRAPPED AROUND MDIFF.NUM := X.NUM - Y.NUM + 2147483647 + 2 + 2147483647; --ADD IN 2**32 -- GET THE ABSOLUTE VALUE OF MDIFF.NUM if MDIFF.NUM < 0 then MDIFF.NUM := -MDIFF.NUM; end if; end if; return MDIFF; exception when NUMERIC_ERROR => return MDIFF; when CONSTRAINT_ERROR => return MDIFF; end; end MODULO; --:::::::::::::: --ncomm.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01182-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ncomm.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; with T_TCP_GLOBALS_DATA_STRUCTURES ; use T_TCP_GLOBALS_DATA_STRUCTURES ; package WITH_TCP_COMMUNICATE is --------------------------------------------------------------- --This implementation is for use with Telesoft version -- --1.3d Ada compiler -- --------------------------------------------------------------- ------------------------------------------------------------------------------- --This package contains all the data abstractions and operations necessary -- --to support the User/TCP interface and TCP/lower-level interface. -- --The enumerated type ACTION represents the type of request primitive -- --that is sent by the upper layer or lower layer protocols. -- ------------------------------------------------------------------------------- subtype LCN_TYPE is TCB_PTR; type ACTION is (OPEN,SEND,RECEIVE,ABOR_T,CLOSE,STATUS,DATA_FROM_IP, TIMER_TIMEOUT, ERROR_MESSAGE, TIMEOUT_IN_RETRANS_QUEUE, TIMEOUT_IN_TIME_WAIT, NO_TCP_ACTION); type SECURITY_OPTION_TYPE is array(1..9) of SIXTEEN_BITS; -- EACH ELEMENT CONTAINS AN -- OCTET OF SECURITY DATA. type TCP_OPTION_TYPE is array(1..50) of SIXTEEN_BITS; type ACKPASS is (PASSIVE, ACTIVE); type TIMER_PARAMS is record MESSAGE_NUMBER : SIXTEEN_BITS; end record; type TIME_WAIT_PARAMS is record LCN : TCB_PTR; end record; type OPEN_PARAMS is record LOCAL_PORT, FOREIGN_PORT : SIXTEEN_BITS; FOREIGN_NET_HOST : THIRTYTWO_BITS; ACTIVE_PASSIVE : ACKPASS; BUFFER_SIZE, TIMEOUT : SIXTEEN_BITS; LCN : TCB_PTR; SECURITY, PRECEDENCE : SIXTEEN_BITS; OPTIONS : TCP_OPTION_TYPE; end record; type STATUS_PARAMS is record LCN : TCB_PTR; end record; type ERROR_PARAMS is record ERROR_INDICATOR : SIXTEEN_BITS; -- THIS MAY CHANGE. end record; type RETRANS_PARAMS is record QUEUE_NUM : SIXTEEN_BITS; end record; type SEG_ARRIVE_PARAMS is record BUFPTR : PACKED_BUFFER_PTR; BYTE_COUNT : SIXTEEN_BITS; SOURCE_ADDRESS, DESTINATION_ADDRESS : THIRTYTWO_BITS; PROTOCOL : SIXTEEN_BITS; TOS : SIXTEEN_BITS; SECURITY : SECURITY_OPTION_TYPE; end record; type SEND_PARAMS is record LCN : TCB_PTR; BUFPTR : PACKED_BUFFER_PTR; BYTE_COUNT, PUSH_FLAG, URG_FLAG, TIMEOUT : SIXTEEN_BITS; end record; type RECEIVE_PARAMS is record LCN : TCB_PTR; BUFPTR : PACKED_BUFFER_PTR; BYTE_COUNT : SIXTEEN_BITS; end record; type ABORT_CLOSE_PARAMS is record LCN : TCB_PTR; end record; --TCP responds to message which are associated with a type of event. The --data abstraction of MESSAGE creates the appropiate message for the given --event. type MESSAGE(EVENT : ACTION := OPEN) is record case EVENT is when ABOR_T | CLOSE => ABORT_CLOSE_PARAMETERS : ABORT_CLOSE_PARAMS; when DATA_FROM_IP => DATA_FROM_IP_PARAMETERS : SEG_ARRIVE_PARAMS; when RECEIVE => RECEIVE_PARAMETERS : RECEIVE_PARAMS; when SEND => SEND_PARAMETERS : SEND_PARAMS; when OPEN => OPEN_PARAMETERS : OPEN_PARAMS; when STATUS => STATUS_PARAMETERS : STATUS_PARAMS; when TIMEOUT_IN_TIME_WAIT => TIME_WAIT_PARAMETERS : TIME_WAIT_PARAMS; when TIMEOUT_IN_RETRANS_QUEUE => RETRANS_PARAMETERS : RETRANS_PARAMS; when ERROR_MESSAGE => ERROR_PARAMETERS : ERROR_PARAMS; when TIMER_TIMEOUT => TIMER_PARAMETERS : TIMER_PARAMS; when NO_TCP_ACTION => NULL; end case; end record; MESSAGE_HOLDER : MESSAGE; procedure MESSAGE_FOR_TCP(TASK_MESSAGE : MESSAGE); --Messages are passed to TCP from the both upper and lower --level protocol(s). Each interface has a queue which the --adjacent protocols place there messages. This subprogram --will pass messages from either queue for processing in a --main queue that will be read and processed by the --TCP_CONTROLLER. -- --Implementation Notes: ----------------------- --Since tasking is not used in this implementation queue --synchronization is not a concern. The current queue sizes --are fixed and can overflow if TCP is flooded by messages. procedure WAIT( TASK_MESSAGE : OUT MESSAGE); --This subprogram will obtain a message from the TCP message --queue. If the if the queue is empty then the message --passed is of the type NO_TCP_ACTION. Otherwise the message --is popped from the queue and passed. end WITH_TCP_COMMUNICATE; with TEXT_IO; use TEXT_IO; with MODULO; use MODULO; package body WITH_TCP_COMMUNICATE is type QUEUE_ELEMENT; type QUEUE_ELEMENT_POINTER is access QUEUE_ELEMENT; subtype Q_ITEM is MESSAGE; type QUEUE_ELEMENT is record ELEMENT : Q_ITEM; NEXT : QUEUE_ELEMENT_POINTER; end RECORD; TYPE QHEADS IS record ELEMENT_COUNT : SIXTEEN_BITS := 0; FIRST_ELEMENT : QUEUE_ELEMENT_POINTER; LAST_ELEMENT : QUEUE_ELEMENT_POINTER; end RECORD; QUEUE_FREE_LIST : QUEUE_ELEMENT_POINTER; MAX_QUEUE_SIZE : CONSTANT SIXTEEN_BITS := 32; NUMBER_OF_QUEUES : CONSTANT SIXTEEN_BITS := 1; TO_TCP_QUEUE_LENGTH : SIXTEEN_BITS := 0; MAX : CONSTANT SIXTEEN_BITS := 32; -- TEMPORARY TO_TCP_QUEUE : QHEADS; NO_ADD_COUNT : SIXTEEN_BITS := 0; procedure INITIALIZE_QUEUES is -- THIS PROCEDURE IS CALLED TO SET UP A FREE LIST OF QUEUE ELEMENTS. -- IT IS CALLED AT SYSTEM INITIALIZATION TIME. -- -- THIS ROUTINE ALLOCATES AND LINKS TOGETHER IN A LIST (POINTED TO BY -- QUEUE_FREE_LIST) OF QUEUE ELEMENTS TO BE USED BY ALL OF THE QUEUE -- ROUTINES. IT ALLOCATES THEM VIA NEW. THEY ARE NEVER DEALLOCATED. -- THEY ARE SIMPLY PUT BACK IN THE FREE QUEUE ELEMENT LIST. -- THE MAX QUEUE SIZE TIMES THE NUMBER OF QUEUES IS THE NUMBER OF QUEUE\ -- ELEMENTS THAT ARE ALLOCATED. NEXT_STRUCTURE : QUEUE_ELEMENT_POINTER; begin QUEUE_FREE_LIST := NEW QUEUE_ELEMENT; NEXT_STRUCTURE := NEW QUEUE_ELEMENT; QUEUE_FREE_LIST.NEXT := NEXT_STRUCTURE; for I in 3..MAX_QUEUE_SIZE*NUMBER_OF_QUEUES loop -- SET UP A FREE LIST OF QUEUE STRUCTURES. NEXT_STRUCTURE.NEXT := NEW QUEUE_ELEMENT; NEXT_STRUCTURE := NEXT_STRUCTURE.NEXT; end loop; end INITIALIZE_QUEUES; function GET_Q_STRUCTURE return QUEUE_ELEMENT_POINTER is X : QUEUE_ELEMENT_POINTER; begin X := QUEUE_FREE_LIST; QUEUE_FREE_LIST := QUEUE_FREE_LIST.NEXT; return X; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN GET_Q_STRUCTURE"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR RAISED IN GET_Q_STRUCTURE"); end GET_Q_STRUCTURE; procedure FREE_Q_STRUCTURE(Q_STRUCTURE : in out QUEUE_ELEMENT_POINTER) is begin Q_STRUCTURE.NEXT := QUEUE_FREE_LIST; QUEUE_FREE_LIST := Q_STRUCTURE; --ADDS TO FRONT OF LIST -- MAKE THE POINTER NULL NOW. Q_STRUCTURE := null; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN FREE_Q_STRUCTURE"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR RAISED IN FREE_Q_STRUCTURE"); end FREE_Q_STRUCTURE; function QUEUE_EMPTY(QUEUE : QHEADS) return BOOLEAN is RESULT : BOOLEAN := FALSE; begin if QUEUE.ELEMENT_COUNT = 0 then RESULT := TRUE; end if; return RESULT; end QUEUE_EMPTY; procedure QUEUE_GET(QHEAD : in out QHEADS; ITEM : in out Q_ITEM) is Q_ELEMENT_TO_BE_FREED : QUEUE_ELEMENT_POINTER; begin if QHEAD.ELEMENT_COUNT > 0 then QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; Q_ELEMENT_TO_BE_FREED := QHEAD.FIRST_ELEMENT; ITEM := QHEAD.FIRST_ELEMENT.ELEMENT; QHEAD.FIRST_ELEMENT := QHEAD.FIRST_ELEMENT.NEXT; if QHEAD.ELEMENT_COUNT = 0 then -- AN EMPTY LIST QHEAD.LAST_ELEMENT := null; end if; FREE_Q_STRUCTURE(Q_ELEMENT_TO_BE_FREED); -- FREE UP THE FORMER FIRST ELEMENT else -- AN EMPTY LIST TEXT_IO.PUT_LINE("A FOOLISH QGET ATTEMPT ON AN EMPTY LIST"); end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN QGET"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR IN QUEUE_GET"); end QUEUE_GET; procedure QUEUE_DELETE(QHEAD : in out QHEADS; ITEM :Q_ITEM) is BEFORE_PTR : QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; CURRENT_ELEMENT_POINTER : QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; FOUND : BOOLEAN := FALSE; begin while CURRENT_ELEMENT_POINTER /= null and (not FOUND) loop if CURRENT_ELEMENT_POINTER.ELEMENT = ITEM then -- FREE IT AND THE BUFFER UP BEFORE_PTR.NEXT := CURRENT_ELEMENT_POINTER.NEXT; -- TAKE CARE OF DELETING FROM THE END OR BEGINNING OF A LIST. if QHEAD.FIRST_ELEMENT = CURRENT_ELEMENT_POINTER then QHEAD.FIRST_ELEMENT := CURRENT_ELEMENT_POINTER.NEXT; end if; if QHEAD.LAST_ELEMENT = CURRENT_ELEMENT_POINTER then -- WE ARE DELETING LAST ELEMENT. if QHEAD.FIRST_ELEMENT /= null then QHEAD.LAST_ELEMENT := BEFORE_PTR; else -- AN EMPTY LIST NOW QHEAD.LAST_ELEMENT := NULL; end if; end if; -- FREE THE ELEMENT AND DECREMENT THE ELEMENT COUNT FREE_Q_STRUCTURE(CURRENT_ELEMENT_POINTER); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; FOUND := TRUE; else BEFORE_PTR := CURRENT_ELEMENT_POINTER; CURRENT_ELEMENT_POINTER := CURRENT_ELEMENT_POINTER.NEXT; end if; end loop; if not FOUND then --ERROR TEXT_IO.PUT_LINE("WAS UNABLE TO DELETE"); end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN QUEUE DELETE"); when others => TEXT_IO.PUT_LINE(" ERROR IN QUEUE DELETE"); end QUEUE_DELETE; procedure QUEUE_CLEAR(QHEAD : in out QHEADS) is X : QUEUE_ELEMENT_POINTER; begin while QHEAD.ELEMENT_COUNT > 0 loop X := QHEAD.FIRST_ELEMENT; QHEAD.FIRST_ELEMENT := X.NEXT; FREE_Q_STRUCTURE(X); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; end loop; -- RESET THE HEAD AND TAIL POINTERS. QHEAD.FIRST_ELEMENT := null; QHEAD.LAST_ELEMENT := null; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN QUEUE CLEAR"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR TYPE IN QUEUE CLEAR"); end QUEUE_CLEAR; procedure QUEUE_ADD(QHEAD : in out QHEADS; ITEM : Q_ITEM) is NEW_ITEM : QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; begin NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if QHEAD.ELEMENT_COUNT < MAX_QUEUE_SIZE theN if QHEAD.ELEMENT_COUNT /= 0 then -- ITS NOT AN EMPTY QUEUE. SO LINK FORMER -- LAST ITEM TO NEW ONE. QHEAD.LAST_ELEMENT.NEXT := NEW_ITEM; else -- FIRST ADD TO THE QUEUE QHEAD.FIRST_ELEMENT := NEW_ITEM; end if; QHEAD.LAST_ELEMENT := NEW_ITEM; QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT + 1; else -- NO ROOM TOO BAD FREE_Q_STRUCTURE(NEW_ITEM); end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN QUEUE ADD"); when others => TEXT_IO.PUT_LINE("ERROR IN QADD"); TEXT_IO.INTEGER_IO.PUT(QHEAD.ELEMENT_COUNT); end QUEUE_ADD; procedure WAIT( TASK_MESSAGE : out MESSAGE) is begin -- GET A TASK MESSAGE if TO_TCP_QUEUE_LENGTH > 0 then -- ADD THE ITEM TO_TCP_QUEUE_LENGTH := TO_TCP_QUEUE_LENGTH - 1; QUEUE_GET(TO_TCP_QUEUE, TASK_MESSAGE); else -- NO MESSAGE TASK_MESSAGE := (EVENT => NO_TCP_ACTION); end if; end WAIT; procedure MESSAGE_FOR_TCP(TASK_MESSAGE : MESSAGE) is begin if TO_TCP_QUEUE_LENGTH < MAX then TO_TCP_QUEUE_LENGTH := TO_TCP_QUEUE_LENGTH + 1; QUEUE_ADD(TO_TCP_QUEUE, TASK_MESSAGE); else NO_ADD_COUNT := NO_ADD_COUNT + 1; end if; exception when others => TEXT_IO.PUT("CAN'T OUTPUT LOCAL PORT NUMBER OR LCN"); end MESSAGE_FOR_TCP; begin -- INITIALIZE THE QUEUES. INITIALIZE_QUEUES; end WITH_TCP_COMMUNICATE; --:::::::::::::: --ncommip.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01183-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ncommip.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; with IP_GLOBALS; use IP_GLOBALS; package WITH_IP_COMMUNICATE is --------------------------------------------------- --This implementation is for use with the -- --Telesoft Ada compiler version 1.3d -- --------------------------------------------------- ------------------------------------------------------------------------------ -- THIS PACKAGE CONTAINS ALL THE ROUTINES RESPONSIBLE FOR COMMUNICATING -- -- WITH THE IP BY ACCEPTING MESSAGES FROM OTHER SOURCES. -- ------------------------------------------------------------------------------ type IP_ACTION is (IP_SEND, ERROR_MESSAGE, DATA_FROM_SUBNET, RECEIVE_IP, NO_IP_ACTION); type RESULT_TYPE is (OK, NOK); type IP_MESSAGE(EVENT : IP_ACTION := IP_SEND) is record BUFPTR : PACKED_BUFFER_PTR := null; DEST : THIRTYTWO_BITS; TOS, TTL, LEN : SIXTEEN_BITS; case EVENT is when IP_SEND => ID, DF : SIXTEEN_BITS; OPTIONS : OPTION_TYPE; SRC : THIRTYTWO_BITS; -- THE SOURCE HOST. when ERROR_MESSAGE => ERROR_NUMBER : SIXTEEN_BITS; when RECEIVE_IP => SOURCE : THIRTYTWO_BITS; PROT : SIXTEEN_BITS; RESULT : RESULT_TYPE; when DATA_FROM_SUBNET => BYTE_COUNT : SIXTEEN_BITS; when NO_IP_ACTION => null; end case; end record; ACTION : IP_ACTION; MESSAGE_TO_IP : IP_MESSAGE; RESULT : RESULT_TYPE; -- USED TO RETURN THE RESULTS OF QUEUE ATTEMPTS. procedure SUBNET_TO_IP( DATAGRAM : in PACKED_BUFFER_PTR); procedure SEND_IP(SRC, DEST : in THIRTYTWO_BITS; TOS, TTL : in SIXTEEN_BITS; BUFFPTR : in out PACKED_BUFFER_PTR; LEN , IDENT : SIXTEEN_BITS; DONT_FRAGMENT : SIXTEEN_BITS; OPTIONS : OPTION_TYPE; RESULT : in out RESULT_TYPE); --This subprogram allows the user to send a message to IP. --The message is placed on the TO_IP_QUEUE. procedure IP_WAIT( MESSAGE_TO_IP : in out IP_MESSAGE); --This subprogram will check to see if the subnet protocol --has a message to send to IP or if not the TO_IP_QUEUE is --examined for a message from TCP. If neither the TCP or --SUBNET has a message a null is returned. This procedure is --used by the IP controller. end WITH_IP_COMMUNICATE; with SYSTEM; -- FOR TESTING with UNCHECKED_CONVERSION; -- FOR TESTING with TEXT_IO; use TEXT_IO; with MODULO; use MODULO; with IP_GLOBALS; use IP_GLOBALS; with SUBNET_CALLS; use SUBNET_CALLS; package body WITH_IP_COMMUNICATE is MAX : constant SIXTEEN_BITS := 16; -- LACK OF MEMORY 32; type QUEUE_ELEMENT; type QUEUE_ELEMENT_POINTER is access QUEUE_ELEMENT; subtype Q_ITEM is IP_MESSAGE; type QUEUE_ELEMENT is record ELEMENT : Q_ITEM; NEXT : QUEUE_ELEMENT_POINTER; end record; type QHEADS is record ELEMENT_COUNT : SIXTEEN_BITS := 0; FIRST_ELEMENT : QUEUE_ELEMENT_POINTER; LAST_ELEMENT : QUEUE_ELEMENT_POINTER; end record; -- FOR TESTING function PHYSICAL_ADDRESS is new UNCHECKED_CONVERSION(THIRTYTWO_BITS, SYSTEM.ADDRESS); PACKET_PRINT_FLAG : SIXTEEN_BITS; NO_ADD_COUNT : SIXTEEN_BITS; for PACKET_PRINT_FLAG use at PHYSICAL_ADDRESS(THIRTYTWO_BITS(16#F06#)); for NO_ADD_COUNT use at PHYSICAL_ADDRESS(THIRTYTWO_BITS(16#F24#)); QUEUE_FREE_LIST : QUEUE_ELEMENT_POINTER; MAX_QUEUE_SIZE : constant SIXTEEN_BITS := 32; NUMBER_OF_QUEUES : constant SIXTEEN_BITS := 1; TO_IP_QUEUE_LENGTH : SIXTEEN_BITS := 0; TO_IP_QUEUE : QHEADS; -- NOTE: ALL QUEUE ROUTINES OPERATE THE SAME AS THOSE IN TCP. THEY ARE -- FULLY EXPLAINED IN TCP'S QUEUE PACKAGE. --****************** --* USER SEMANTICS * --****************** --This subprogram allocates and links together in a list (pointed to by --queue_free_list) of queue elements to be used by all of the queue --routines. It allocates them via new. They are never deallocated. --they are simply put back in the free queue element list. --the max queue size times the number of queues is the number of queue --elements that are allocated. procedure INITIALIZE_QUEUES is NEXT_STRUCTURE : QUEUE_ELEMENT_POINTER; begin QUEUE_FREE_LIST := new QUEUE_ELEMENT; NEXT_STRUCTURE := new QUEUE_ELEMENT; QUEUE_FREE_LIST.NEXT := NEXT_STRUCTURE; for I in 3..MAX_QUEUE_SIZE*NUMBER_OF_QUEUES loop -- SET UP A FREE LIST OF QUEUE STRUCTURES. NEXT_STRUCTURE.NEXT := new QUEUE_ELEMENT; NEXT_STRUCTURE := NEXT_STRUCTURE.NEXT; end loop; end INITIALIZE_QUEUES; function GET_Q_STRUCTURE return QUEUE_ELEMENT_POINTER is X : QUEUE_ELEMENT_POINTER; begin X := QUEUE_FREE_LIST; QUEUE_FREE_LIST := QUEUE_FREE_LIST.NEXT; return X; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN COMM WITH IP GET_Q_STRUCTURE"); when others => PUT_LINE ("UNKNOWN ERROR RAISED IN COMM. WITH IP GET_Q_STRUCTURE"); end GET_Q_STRUCTURE; procedure FREE_Q_STRUCTURE (Q_STRUCTURE : in out QUEUE_ELEMENT_POINTER) is begin Q_STRUCTURE.NEXT := QUEUE_FREE_LIST; QUEUE_FREE_LIST := Q_STRUCTURE; --ADDS TO FRONT OF LIST -- MAKE THE POINTER NULL NOW. Q_STRUCTURE := null; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN FREE_Q_STRUCTURE"); when others => PUT_LINE("UNKNOWN ERROR RAISED IN FREE_Q_STRUCTURE"); end FREE_Q_STRUCTURE; function QUEUE_EMPTY(QUEUE : QHEADS) return BOOLEAN is RESULT : BOOLEAN := FALSE; begin if QUEUE.ELEMENT_COUNT = 0 then RESULT := TRUE; end if; return RESULT; end QUEUE_EMPTY; procedure QUEUE_GET(QHEAD : in out QHEADS; ITEM : in out Q_ITEM) is Q_ELEMENT_TO_BE_FREED : QUEUE_ELEMENT_POINTER; begin if QHEAD.ELEMENT_COUNT > 0 then QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; Q_ELEMENT_TO_BE_FREED := QHEAD.FIRST_ELEMENT; ITEM := QHEAD.FIRST_ELEMENT.ELEMENT; QHEAD.FIRST_ELEMENT := QHEAD.FIRST_ELEMENT.NEXT; IF QHEAD.ELEMENT_COUNT = 0 THEN -- AN EMPTY LIST QHEAD.LAST_ELEMENT := null; end if; FREE_Q_STRUCTURE(Q_ELEMENT_TO_BE_FREED); -- FREE UP THE FORMER FIRST ELEMENT else -- AN EMPTY LIST PUT_LINE("A FOOLISH QGET ATTEMPT ON AN EMPTY LIST"); end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QGET"); when others => PUT_LINE("UNKNOWN ERROR IN QUEUE_GET"); end QUEUE_GET; procedure QUEUE_ADD(QHEAD : in out QHEADS; ITEM : Q_ITEM) is NEW_ITEM : QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; begin NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if QHEAD.ELEMENT_COUNT < MAX_QUEUE_SIZE then if QHEAD.ELEMENT_COUNT /= 0 then -- ITS NOT AN EMPTY QUEUE. SO LINK FORMER -- LAST ITEM TO NEW ONE. QHEAD.LAST_ELEMENT.NEXT := NEW_ITEM; else -- FIRST ADD TO THE QUEUE QHEAD.FIRST_ELEMENT := NEW_ITEM; end if; QHEAD.LAST_ELEMENT := NEW_ITEM; QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT + 1; else -- NO ROOM TOO BAD. PUT Q STRUCTURE -- ON THE FREE LIST. FREE_Q_STRUCTURE(NEW_ITEM); end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QUEUE ADD"); when others => PUT_LINE("ERROR IN QADD"); INTEGER_IO.PUT(QHEAD.ELEMENT_COUNT); end QUEUE_ADD; procedure SUBNET_TO_IP( DATAGRAM : in PACKED_BUFFER_PTR) is begin if DATAGRAM /= null then MESSAGE_TO_IP := ( DATA_FROM_SUBNET, DATAGRAM, 0, 0, 0, 0, 0); else MESSAGE_TO_IP := ( NO_IP_ACTION, null, 0, 0, 0, 0); end if; if TO_IP_QUEUE_LENGTH < MAX_QUEUE_SIZE then TO_IP_QUEUE_LENGTH := TO_IP_QUEUE_LENGTH + 1; QUEUE_ADD( TO_IP_QUEUE, MESSAGE_TO_IP ); else DATAGRAM.IN_USE := FALSE; DATAGRAM.STATUS := NONE; end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT_ERROR in SUBNET_TO_IP"); when others => PUT_LINE("UNKNONW error in SUBNET_TO_IP"); end SUBNET_TO_IP; procedure SEND_IP(SRC, DEST : in THIRTYTWO_BITS; TOS, TTL : in SIXTEEN_BITS; BUFFPTR : in out PACKED_BUFFER_PTR; LEN , IDENT : in SIXTEEN_BITS; DONT_FRAGMENT : in SIXTEEN_BITS; OPTIONS : in OPTION_TYPE; RESULT : in out RESULT_TYPE) is begin --/ PUT ON THE QUEUE FOR THE IP. WE DON'T CARE IF ITS LOST./ -- SET UP IP MESSAGE. RESULT := OK; -- TEMPORARY WILL BE RESULTS OF -- ATTEMPT TO QUEUE IT. MESSAGE_TO_IP := (IP_SEND, BUFFPTR, DEST, TOS, TTL, LEN, IDENT, DONT_FRAGMENT, OPTIONS, SRC); if TO_IP_QUEUE_LENGTH < MAX_QUEUE_SIZE then TO_IP_QUEUE_LENGTH := TO_IP_QUEUE_LENGTH + 1; -- GO AHEAD AND QUEUE IT UP QUEUE_ADD(TO_IP_QUEUE, MESSAGE_TO_IP); RESULT := OK; else RESULT := NOK; -- RELEASE THE BUFFER FROM USE. BUFFPTR.IN_USE := FALSE; end if; end SEND_IP; procedure IP_WAIT(MESSAGE_TO_IP : in out IP_MESSAGE) is -- There is a separate queue for packets -- from the subnet protocol group. The -- subnet protocol(s) maintain this queue. DATAGRAM : PACKED_BUFFER_PTR := null ; begin if TO_IP_QUEUE_LENGTH > 0 then TO_IP_QUEUE_LENGTH := TO_IP_QUEUE_LENGTH - 1; QUEUE_GET( TO_IP_QUEUE, MESSAGE_TO_IP); else MESSAGE_TO_IP := ( NO_IP_ACTION, null, 0,0,0,0); --TEXT_IO.PUT_LINE("TO_IP_QUEUE_LENGTH = 0"); end if; exception when CONSTRAINT_ERROR => NEW_LINE; PUT_LINE(" exception CONSTRAINT_ERROR "); PUT_LINE(" procedure IP_WAIT package WITH_IP_COMMUNICATE "); when others => NEW_LINE; PUT_LINE(" execption others "); PUT_LINE(" procedure IP_WAIT package WITH_IP_COMMUNICATE "); end IP_WAIT; begin -- THE PACKAGE INITIALIZTION. INITIALIZE_QUEUES; end WITH_IP_COMMUNICATE; --:::::::::::::: --ncommu.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01184-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ncommu.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with BUFFER_DATA; use BUFFER_DATA; with T_TCP_GLOBALS_DATA_STRUCTURES ; use T_TCP_GLOBALS_DATA_STRUCTURES ; package WITH_ULP_COMMUNICATE is ---------------------------------------------------------- --This implementation is for use with the Telesoft Ada -- --compiler version 1.5 . -- ---------------------------------------------------------- type STATUS_TYPE is (CONNECTION_OPEN, CONNECTION_CLOSED, OPENING, CLOSING); type SECURITIES is array(1..9) of SIXTEEN_BITS; type STATE_TYPE is (CLOSED, SYN_SENT, SYN_RECEIVED, ESTABLISHED, LISTEN, FIN_WAIT_1, CLOSE_WAIT, FIN_WAIT_2, CLOSING, TIME_WAIT, LAST_ACK); -- SAME AS IN TCPGLB. type STATUS_RECORD is record SOURCE_PORT : SIXTEEN_BITS; SOURCE_ADDRESS : THIRTYTWO_BITS; DESTINATION_PORT : SIXTEEN_BITS; DESTINATION_ADDRESS : THIRTYTWO_BITS; CONNECTION_STATE : STATE_TYPE; STATUS : STATUS_TYPE; LOCAL_RCV_WINDOW : SIXTEEN_BITS; REMOTE_RCV_WINDOW : SIXTEEN_BITS; OCTETS_ON_RETRANSMIT_QUEUE : SIXTEEN_BITS; DATA_WAITING_FOR_ULP : SIXTEEN_BITS; URGENT_STATE : BOOLEAN; PRECEDENCE : SIXTEEN_BITS; SECURITY : SECURITIES; ULP_TIMEOUT : SIXTEEN_BITS; end record; type USER_MESSAGE(MESSAGE_NUMBER : SIXTEEN_BITS := 0) is record LCN : TCB_PTR; case MESSAGE_NUMBER is when 10 | 19 => DATA_BUFFER : PACKED_BUFFER_PTR; when 15 => -- STATUS PARAMETERS STATUS_PARAMS : STATUS_RECORD; when others => null; end case; end record; PROCEDURE WAIT_FOR_TCP_MESSAGE(USER_MESS : IN OUT USER_MESSAGE); --This procedure obtains a message in a queue for the ULP from TCP. PROCEDURE MESSAGE_FOR_USER(USER_MESS : USER_MESSAGE); --This procedure is used by TCP to put a message for the ULP. end WITH_ULP_COMMUNICATE; with TEXT_IO; use TEXT_IO; with ASCII; package body WITH_ULP_COMMUNICATE is ------------------------------------------------------------------------------- -- THE MESSAGE NUMBERS FOR THE USER AND THEIR MEANING FOLLOW -- -- -1 : NO USER ACTION -- -- -- -- 2: CONNECTION ILLEGAL -- -- 3: CONNECTION DOES NOT EXIST -- -- 4: FOREIGN SOCKET UNSPECIFIED -- -- 5: INSUFFICIENT RESOURCES -- -- 6: CONNECTION CLOSING -- -- 7: URGENT DATA -- -- 8: OK ON ABORT -- -- 9: PRECEDENCE NOT ALLOWED -- -- 10: BUFFER FOR USER -- -- 11: SECURITY/COMPARTMENT ILLEGAL -- -- 12: CONNECTION EXISTS -- -- 14: RETURN LCN -- -- 15: TCB POINTER AND STATE -- -- 16: CONNECTION RESET -- -- 17: CONNECTION REFUSED -- -- 18: OK ON CLOSE -- -- 19: PUSHED BUFFER FOR USER -- -- 20: OUT OF BUFFERS -- -- 21: COULDN'T DO RESET -- -- 22: IP OVERLOADED. -- -- 23: CONNECTION IS NOW OPEN. -- ------------------------------------------------------------------------------- UMAX : constant positive := 32; -- TEMPORARY type QUEUE_ELEMENT; type QUEUE_ELEMENT_POINTER is access QUEUE_ELEMENT; subtype Q_ITEM is USER_MESSAGE; type QUEUE_ELEMENT is record ELEMENT : Q_ITEM; NEXT : QUEUE_ELEMENT_POINTER; end record; subtype ELEMENT_COUNT_TYPE is SIXTEEN_BITS; type QHEADS is record ELEMENT_COUNT : ELEMENT_COUNT_TYPE := 0; FIRST_ELEMENT : QUEUE_ELEMENT_POINTER; LAST_ELEMENT : QUEUE_ELEMENT_POINTER; end record; QUEUE_FREE_LIST : QUEUE_ELEMENT_POINTER; MAX_QUEUE_SIZE : constant positive := 32; NUMBER_OF_QUEUES : constant positive := 1; TO_USER_QUEUE_LENGTH : SIXTEEN_BITS := 0; TO_USER_QUEUE : QHEADS; OUTPUT : FILE_TYPE; procedure INITIALIZE_QUEUES is --THIS PROCEDURE IS CALLED TO SET UP A FREE LIST OF QUEUE ELEMENTS. --IT IS CALLED AT SYSTEM INITIALIZATION TIME. THE ROUTINE --ALLOCATES AND LINKS TOGETHER IN A LIST (POINTED TO BY --QUEUE_FREE_LIST) OF QUEUE ELEMENTS TO BE USED BY ALL OF THE QUEUE --ROUTINES. IT ALLOCATES THEM VIA NEW. THEY ARE NEVER DEALLOCATED. --THEY ARE SIMPLY PUT BACK IN THE FREE QUEUE ELEMENT LIST. --THE MAX QUEUE SIZE TIMES THE NUMBER OF QUEUES IS THE NUMBER OF QUEUE\ --ELEMENTS THAT ARE ALLOCATED. NEXT_STRUCTURE : QUEUE_ELEMENT_POINTER; begin QUEUE_FREE_LIST := NEW QUEUE_ELEMENT; NEXT_STRUCTURE := NEW QUEUE_ELEMENT; QUEUE_FREE_LIST.NEXT := NEXT_STRUCTURE; for I in 3..MAX_QUEUE_SIZE*NUMBER_OF_QUEUES loop -- SET UP A FREE LIST OF QUEUE STRUCTURES. NEXT_STRUCTURE.NEXT := NEW QUEUE_ELEMENT; NEXT_STRUCTURE := NEXT_STRUCTURE.NEXT; end loop; end INITIALIZE_QUEUES; FUNCTION GET_Q_STRUCTURE RETURN QUEUE_ELEMENT_POINTER IS X : QUEUE_ELEMENT_POINTER; BEGIN X := QUEUE_FREE_LIST; QUEUE_FREE_LIST := QUEUE_FREE_LIST.NEXT; RETURN X; EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN GET_Q_STRUCTURE"); PUT_LINE("IN COMMUNICATE WITH USER"); WHEN OTHERS => PUT_LINE("IN COMMUNICATE WITH USER"); PUT_LINE("UNKNOWN ERROR RAISED IN GET_Q_STRUCTURE"); END GET_Q_STRUCTURE; PROCEDURE FREE_Q_STRUCTURE(Q_STRUCTURE : IN OUT QUEUE_ELEMENT_POINTER) IS BEGIN Q_STRUCTURE.NEXT := QUEUE_FREE_LIST; QUEUE_FREE_LIST := Q_STRUCTURE; --ADDS TO FRONT OF LIST -- MAKE THE POINTER NULL NOW. Q_STRUCTURE := NULL; EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN FREE_Q_STRUCTURE"); PUT_LINE("IN COMMUNICATE WITH USER"); WHEN OTHERS => PUT_LINE("IN COMMUNICATE WITH USER"); PUT_LINE("UNKNOWN ERROR RAISED IN FREE_Q_STRUCTURE"); END; FUNCTION QUEUE_EMPTY(QUEUE : QHEADS) RETURN BOOLEAN IS RESULT : BOOLEAN := FALSE; BEGIN IF QUEUE.ELEMENT_COUNT = 0 THEN RESULT := TRUE; END IF; RETURN RESULT; END QUEUE_EMPTY; PROCEDURE QUEUE_GET(QHEAD : IN OUT QHEADS; ITEM : IN OUT Q_ITEM) IS Q_ELEMENT_TO_BE_FREED : QUEUE_ELEMENT_POINTER; BEGIN IF QHEAD.ELEMENT_COUNT > 0 THEN QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; Q_ELEMENT_TO_BE_FREED := QHEAD.FIRST_ELEMENT; ITEM := QHEAD.FIRST_ELEMENT.ELEMENT; QHEAD.FIRST_ELEMENT := QHEAD.FIRST_ELEMENT.NEXT; IF QHEAD.ELEMENT_COUNT = 0 THEN -- AN EMPTY LIST QHEAD.LAST_ELEMENT := NULL; END IF; FREE_Q_STRUCTURE(Q_ELEMENT_TO_BE_FREED); -- FREE UP THE FORMER FIRST ELEMENT ELSE -- AN EMPTY LIST PUT_LINE("A FOOLISH QGET ATTEMPT ON AN EMPTY LIST"); END IF; EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QGET"); PUT_LINE("IN COMMUNICATE WITH USER"); WHEN OTHERS => PUT_LINE("IN COMMUNICATE WITH USER"); PUT_LINE("UNKNOWN ERROR IN QUEUE_GET"); END QUEUE_GET; PROCEDURE QUEUE_DELETE(QHEAD : IN OUT QHEADS; ITEM :Q_ITEM) IS BEFORE_PTR : QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; CURRENT_ELEMENT_POINTER : QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; FOUND : BOOLEAN := FALSE; BEGIN WHILE CURRENT_ELEMENT_POINTER /= NULL AND (NOT FOUND) LOOP IF CURRENT_ELEMENT_POINTER.ELEMENT = ITEM THEN -- FREE IT AND THE BUFFER UP BEFORE_PTR.NEXT := CURRENT_ELEMENT_POINTER.NEXT; -- TAKE CARE OF DELETING FROM THE END OR BEGINNING OF A LIST. IF QHEAD.FIRST_ELEMENT = CURRENT_ELEMENT_POINTER THEN QHEAD.FIRST_ELEMENT := CURRENT_ELEMENT_POINTER.NEXT; END IF; IF QHEAD.LAST_ELEMENT = CURRENT_ELEMENT_POINTER THEN -- WE ARE DELETING LAST -- ELEMENT. IF QHEAD.FIRST_ELEMENT /= NULL THEN QHEAD.LAST_ELEMENT := BEFORE_PTR; ELSE -- AN EMPTY LIST NOW QHEAD.LAST_ELEMENT := NULL; END IF; END IF; -- FREE THE ELEMENT AND DECREMENT THE ELEMENT COUNT FREE_Q_STRUCTURE(CURRENT_ELEMENT_POINTER); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; FOUND := TRUE; ELSE BEFORE_PTR := CURRENT_ELEMENT_POINTER; CURRENT_ELEMENT_POINTER := CURRENT_ELEMENT_POINTER.NEXT; END IF; END LOOP; IF NOT FOUND THEN --ERROR PUT_LINE("WAS UNABLE TO DELETE"); END IF; EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QUEUE DELETE"); PUT_LINE("IN COMMUNICATE WITH USER"); WHEN OTHERS => PUT_LINE("IN COMMUNICATE WITH USER"); PUT_LINE(" ERROR IN QUEUE DELETE"); END QUEUE_DELETE; PROCEDURE QUEUE_CLEAR(QHEAD : IN OUT QHEADS) IS X : QUEUE_ELEMENT_POINTER; BEGIN WHILE QHEAD.ELEMENT_COUNT > 0 LOOP X := QHEAD.FIRST_ELEMENT; QHEAD.FIRST_ELEMENT := X.NEXT; FREE_Q_STRUCTURE(X); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; END LOOP; -- RESET THE HEAD AND TAIL POINTERS. QHEAD.FIRST_ELEMENT := NULL; QHEAD.LAST_ELEMENT := NULL; EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QUEUE CLEAR"); PUT_LINE("IN COMMUNICATE WITH USER"); WHEN OTHERS => PUT_LINE("IN COMMUNICATE WITH USER"); PUT_LINE("UNKNOWN ERROR TYPE IN QUEUE CLEAR"); END QUEUE_CLEAR; PROCEDURE QUEUE_ADD(QHEAD : IN OUT QHEADS; ITEM : Q_ITEM) IS NEW_ITEM : QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; BEGIN NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := NULL; IF QHEAD.ELEMENT_COUNT < MAX_QUEUE_SIZE THEN IF QHEAD.ELEMENT_COUNT /= 0 THEN -- ITS NOT AN EMPTY QUEUE. SO LINK FORMER -- LAST ITEM TO NEW ONE. QHEAD.LAST_ELEMENT.NEXT := NEW_ITEM; ELSE -- FIRST ADD TO THE QUEUE QHEAD.FIRST_ELEMENT := NEW_ITEM; END IF; QHEAD.LAST_ELEMENT := NEW_ITEM; QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT + 1; ELSE -- NO ROOM TOO BAD FREE_Q_STRUCTURE(NEW_ITEM); END IF; EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QUEUE ADD"); PUT_LINE("IN COMMUNICATE WITH USER"); WHEN OTHERS => PUT_LINE("ERROR IN QADD"); PUT_LINE("IN COMMUNICATE WITH USER"); INTEGER_IO.PUT(QHEAD.ELEMENT_COUNT); END QUEUE_ADD; procedure MESSAGE_FOR_USER(USER_MESS : USER_MESSAGE) is begin -- PUT ON THE QUEUE FOR THE USER. THERE SHOULD ALWAYS BE ROOM. if TO_USER_QUEUE_LENGTH < UMAX then --QUEUE IT TO_USER_QUEUE_LENGTH := TO_USER_QUEUE_LENGTH + 1; QUEUE_ADD(TO_USER_QUEUE, USER_MESS); end if; case USER_MESS.MESSAGE_NUMBER is when 10 | 19 => if USER_MESS.MESSAGE_NUMBER = 10 then --PUT_LINE("User message is 10"); PUT(ASCII.BEL); else --PUT_LINE("User message is 19"); null; end if; when 15 => --PUT_LINE("User message is 15"); null; when others => --PUT_LINE("User message is other than 10,15, and 19"); --NEW_LINE; --PUT("User Message Number : "); --INTEGER_IO.PUT(USER_MESS.MESSAGE_NUMBER); --NEW_LINE; null; end case; end MESSAGE_FOR_USER; procedure WAIT_FOR_TCP_MESSAGE(USER_MESS : in out USER_MESSAGE) is begin if TO_USER_QUEUE_LENGTH > 0 then --GIVE EM ONE TO_USER_QUEUE_LENGTH := TO_USER_QUEUE_LENGTH - 1; QUEUE_GET(TO_USER_QUEUE, USER_MESS); else -- NOTHING FOR HIM USER_MESS := (-1, null ); -- NO USER ACTION end if; end WAIT_FOR_TCP_MESSAGE; begin -- INITIALIZE THE QUEUES INITIALIZE_QUEUES; END WITH_ULP_COMMUNICATE; --:::::::::::::: --per1.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01185-100(-) -- E-Systems, Inc. August 07, 1985 -- -- per1.txt Author : Jim Baldo -- ----------------------------------------------------------------------- WITH T_tcp_arrives_1 ; with TCP_GLOBALS; use TCP_GLOBALS; with QUEUES; use QUEUES; with T_TCP_GLOBALS_DATA_STRUCTURES; use T_TCP_GLOBALS_DATA_STRUCTURES; with BUFFER_DATA; use BUFFER_DATA; package TCP_ARRIVES_PERIPHERALS is ---------------------------------------------------------- --This implementation is for use with the Telesoft Ada -- --compiler version 1.5 . -- ---------------------------------------------------------- ------------------------------------------------------------------------------ -- THIS PACKAGE CONTAINS ALL THE PROCEDURES AND FUNCTIONS NECESSARY FOR -- -- PROCESSING ARRIVED SEGMENTS. IT ALSO CONTAINS THE HEADER FORMAT ROUTINE. -- ------------------------------------------------------------------------------ --***********************GLOBAL ROUTINES******************************** procedure PROCESS_RESET_IN_DATA_ACCEPTING_STATES( LCN : in TCB_PTR); --This procedure process an arrived reset in the data accepting --states. It basically closes down the connection and clears --the necessary data out of the appropriate queues. procedure SEND_A_RESET( LCN : in TCB_PTR); --This procedure will format and send a reset, for the remote host, to --the ip. procedure FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES ( LCN : in out TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure checks to see if the fin bit is set. If the fin is --set it then puts the TCB in the close-wait state. procedure PROCESS_SEGMENT_TEXT( LCN : in TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure will determine if text exists and if so fill as many --receive buffers as it can and return them to the user. Any data it --can not return it will queue up. procedure PROCESS_URGENT_FLAG( LCN : in TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure checks the urgent bit and if set, it will notify the --user of urgent data (if the urgent pointer is in advance of the data --and the user has not already been notified). procedure PROCESS_A_FIN( LCN : in out TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure will notify the user that the connection is closing, --and return all receives with data if possible. It will also ensure --that an ack was or will be sent for the fin. procedure SEND_A_PIGGYBACKED_ACK( LCN : in out TCB_PTR); --This procedure will send an ack together with data (if available) --to the IP for processing. It will also try to clear the transmit --queue of data. By sending it. It will update everything necessary --in the TCB. procedure SEND_FROM_TRANSMIT_QUEUE( LCN : in out TCB_PTR); --This procedure will send any segments from the transmit queue that --will fit in the window. It will format them for transmission. It --will check upon emptying its queue for the close pending flag and --take appropriate action. function UNPACK( PACKED_BUFFER : in PACKED_BUFFER_PTR; TOTAL_DATA_BYTES : in SIXTEEN_BITS ) return BUFFER_POINTER; --This function will take an array of system.bytes (a bit stream) and --unpack this into an easy to use record. It uses the generic --function unchecked conversion via several functions to move the bits --into the record fields. The system bytes are considered to be --integers. We simply move the proper number of bits into the proper --fields in the record. procedure PROCESS_COMMON_ACK( LCN : in TCB_PTR; BUFPTR : in BUFFER_POINTER; RESULT : out T_TCP_ARRIVES_1.RES); --This procedure does all the processing for an arrived ack in the --established state as per the specification. This processing is --common to the other states also. procedure ENTER_ESTABLISHED_STATE_PROCESSING( LCN : in TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure will perform all the processing of a segment in the --established state, beginning with the check of the urgent flag. --It will also process all the data on the TCP received segment queue. procedure SEND_A_SYN_AND_ACK( LCN : in TCB_PTR); --This procedure will format a segment for a syn and an ack and send it --to the IP bound for the remote host. procedure BAD_SYN_HANDLER( LCN : in TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure checks to make sure that the syn is indeed bad. Then --it sends a reset to the offending host and clears the necessary --queues of entries for this connection. It tells the user that the --connection was reset and closes the connection. procedure SEND_A_RESET_AND_ACK( LCN : in TCB_PTR); --This procedure will format a header for a segment with the reset --and ack control bits set. This will be sent to the IP layer for --transmission to the remote host. -- ******************************************************************* RESULTS : T_TCP_ARRIVES_1.RES; BUFFTYPE : CONSTANT SIXTEEN_BITS := 1; -- ONLY ONE TYPE OF BUFFER FOR NOW. GLOBAL_PACKED_BUFFER : PACKED_BUFFER_PTR; end TCP_ARRIVES_PERIPHERALS; with IP_GLOBALS ; use IP_GLOBALS ; with TEXT_IO; use TEXT_IO; with SYSTEM; with UNCHECKED_CONVERSION; with MODULO; use MODULO; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; with WITH_ULP_COMMUNICATE; use WITH_ULP_COMMUNICATE; with TCB_ALLOCATOR; use TCB_ALLOCATOR; package body TCP_ARRIVES_PERIPHERALS is procedure PROCESS_RESET_IN_DATA_ACCEPTING_STATES( LCN : in TCB_PTR) is UMESSAGE : USER_MESSAGE; NULL_BUFF : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; SOCKET_PARAMS : TCB_PTR; begin QUEUE_CLEAR(TCP_RECEIVED_SEGMENT_QUEUE, LCN); -- WE HAVE NO SEND QUEUE AS SUCH. QUEUE_CLEAR(SEND_QUEUE, LCN); QUEUE_CLEAR(RECEIVE_QUEUE, LCN); QUEUE_CLEAR(TRANSMIT_QUEUE, LCN); QUEUE_CLEAR(TCP_RETRANSMIT_QUEUE, LCN); QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); -- TELL USER -- ERROR: CONNECTION RESET SOCKET_PARAMS := LCN; UMESSAGE := ( 16, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.STATE := CLOSED; -- MAY HAVE TO CLEAR THE TCB HERE. TCB_CLEAR(LCN); exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN RESET PROCESSOR "); PUT_LINE("OF DATA ACCEPTING STATES"); when others => PUT_LINE("UNKNOWN ERROR IN RESET PROCESSOR "); PUT_LINE("OF DATA ACCEPTING STATES"); end PROCESS_RESET_IN_DATA_ACCEPTING_STATES; procedure SEND_A_RESET( LCN : in TCB_PTR) is BUFFTYPE : SIXTEEN_BITS ; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; PACKED_BUFFER : PACKED_BUFFER_PTR; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin -- GET A BUFFER BUFFGET(PACKED_BUFFER, BUFFTYPE); if PACKED_BUFFER = null then -- TELL USER ERROR OUT OF BUFFERS SOCKET_PARAMS := LCN; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFFER.IN_USE := TRUE ; PACKED_BUFFER.STATUS := OWNER_TCP; -- CLEAR THE OPTIONS ARRAY OPTIONS := CLEAR; TCP_HEADER_FORMAT(LCN, BUFPTR, RST, OPTIONS); -- HERE WE MUST SET UP THE SECURITY OPTIONS FOR IP OPTIONS := TCP_SECURITY_OPTIONS; -- PACK UP A BUFFER PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFFER); LEN := BUFPTR.DATA_OFFSET * 4; SEND_IP( LCN.DESTINATION_ADDRESS, LCN.SOURCE_ADDRESS, TOS, TTL, PACKED_BUFFER, LEN, IDENT, DONT_FRAGMENT, OPTIONS, RESULT ); -- UPDATE SEND NEXT IS UNECESSARY. --- LCN.SND_NXT := LCN.SND_NXT + 1; -- if RESULT /= OK then -- TELL USER WE ARE OUT OF SPACE -- SOCKET_PARAMS.LCN := LCN; -- SOCKET_PARAMS.FOREIGN_NET_HOST := LCN.DESTINATION_ADDRESS; -- SOCKET_PARAMS.FOREIGN_PORT := LCN.FOREIGN_PORT; -- UMESSAGE := ( 21, -- SOCKET_PARAMS); -- MESSAGE_FOR_USER(UMESSAGE); -- end if; end if; exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN SEND A RESET"); when others => PUT_LINE("UNKNOWN ERROR IN SEND A RESET"); end SEND_A_RESET; procedure FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES (LCN : in out TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is begin T_TCP_ARRIVES_1.FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES (LCN, BUFPTR); end FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES; procedure PROCESS_SEGMENT_TEXT( LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is begin T_TCP_ARRIVES_1.PROCESS_SEGMENT_TEXT (LCN, BUFPTR) ; end PROCESS_SEGMENT_TEXT; procedure PROCESS_URGENT_FLAG (LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is begin T_TCP_ARRIVES_1.PROCESS_URGENT_FLAG (LCN, BUFPTR) ; end PROCESS_URGENT_FLAG; procedure PROCESS_A_FIN (LCN : in out TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is begin T_TCP_ARRIVES_1.PROCESS_A_FIN (LCN, BUFPTR) ; end PROCESS_A_FIN; procedure SEND_A_PIGGYBACKED_ACK( LCN : in out TCB_PTR) is begin T_TCP_ARRIVES_1.SEND_A_PIGGYBACKED_ACK (LCN) ; end SEND_A_PIGGYBACKED_ACK; procedure SEND_FROM_TRANSMIT_QUEUE(LCN : in out TCB_PTR) is begin T_TCP_ARRIVES_1.SEND_FROM_TRANSMIT_QUEUE (LCN) ; end SEND_FROM_TRANSMIT_QUEUE; function UNPACK( PACKED_BUFFER : in PACKED_BUFFER_PTR; TOTAL_DATA_BYTES : in SIXTEEN_BITS ) return T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER is begin RETURN T_TCP_ARRIVES_1.UNPACK (PACKED_BUFFER, TOTAL_DATA_BYTES) ; end UNPACK; procedure PROCESS_COMMON_ACK( LCN : in TCB_PTR; BUFPTR : in T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; RESULT : out T_TCP_ARRIVES_1.RES) is begin T_TCP_ARRIVES_1.PROCESS_COMMON_ACK ( LCN, BUFPTR, RESULT) ; end PROCESS_COMMON_ACK; procedure ENTER_ESTABLISHED_STATE_PROCESSING ( LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is begin T_TCP_ARRIVES_1.ENTER_ESTABLISHED_STATE_PROCESSING (LCN, BUFPTR) ; end ENTER_ESTABLISHED_STATE_PROCESSING; procedure SEND_A_SYN_AND_ACK( LCN : in TCB_PTR) is BUFFTYPE : SIXTEEN_BITS ; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; PACKED_BUFFER : PACKED_BUFFER_PTR; UMESSAGE : USER_MESSAGE; Q_ITEM : STD_Q_ITEM; SOCKET_PARAMS : TCB_PTR; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin -- CLEAR THE OPTIONS ARRAY AND THE NECESSARY -- EXTRA HEADER OCTETS GET ADDED IN. --TEXT_IO.PUT_LINE("IN SEND A SYN AND ACK"); BUFFGET(PACKED_BUFFER, BUFFTYPE); if PACKED_BUFFER = null then -- TELL USER ERROR OUT OF BUFFERS TEXT_IO.PUT_LINE("OUT OF BUFFERS SEND A SYN ACK"); SOCKET_PARAMS := LCN; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFFER.IN_USE := TRUE; PACKED_BUFFER.STATUS := OWNER_TCP; TCP_HEADER_FORMAT(LCN, BUFPTR, SYN_ACK, OPTIONS); -- HERE WE MUST SET UP THE SECURITY OPTIONS FOR IP OPTIONS := TCP_SECURITY_OPTIONS; -- PACK A BUFFER PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFFER); LEN := BUFPTR.DATA_OFFSET * 4; SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFFER, LEN, IDENT, DONT_FRAGMENT, OPTIONS, RESULT ); -- if RESULT = OK then -- PUT BUFFER ON THE RETRANSMISSION QUEUE. LCN.SND_NXT := LCN.SND_NXT + MODULAR_CONVERT( SIXTEEN_BITS (1) ) ; Q_ITEM := (PACKED_BUFFER, NULL_UNPACKED_BUFFER, LEN); QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); -- else -- -- TELL USER WE ARE OUT OF SPACE -- SOCKET_PARAMS.LCN := LCN; -- SOCKET_PARAMS.FOREIGN_NET_HOST := LCN.DESTINATION_ADDRESS; -- SOCKET_PARAMS.FOREIGN_PORT := LCN.FOREIGN_PORT; -- UMESSAGE := ( 22, -- SOCKET_PARAMS); -- MESSAGE_FOR_USER(UMESSAGE); -- end if; end if; exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN SEND A SYN AND ACK"); when others => PUT_LINE("UNKNOWN ERROR IN SEND A SYN AND ACK"); end SEND_A_SYN_AND_ACK; procedure BAD_SYN_HANDLER( LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is UMESSAGE : USER_MESSAGE; NULL_BUFF : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; SOCKET_PARAMS : TCB_PTR; begin -- THE SYN SHOULD BE IN THE WINDOW OR WE WOULD NOT BE HERE if (BUFPTR.SEQ_NUM >= LCN.RCV_NXT) and (BUFPTR.SEQ_NUM <= LCN.RCV_NXT + LCN.RCV_WINDOW) then SEND_A_RESET(LCN); -- CLEAR THE QUEUES OUT QUEUE_CLEAR(TCP_RECEIVED_SEGMENT_QUEUE, LCN); -- WE HAVE NO SEND QUEUE AS SUCH. QUEUE_CLEAR(SEND_QUEUE, LCN); QUEUE_CLEAR(RECEIVE_QUEUE, LCN); QUEUE_CLEAR(TRANSMIT_QUEUE, LCN); QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); QUEUE_CLEAR(TCP_RETRANSMIT_QUEUE, LCN); -- TELL USER -- ERROR: CONNECTION RESET SOCKET_PARAMS := LCN; UMESSAGE := ( 16, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.STATE := CLOSED; -- MAY HAVE TO CLEAR THE TCB HERE. TCB_CLEAR(LCN); else -- ERROR: WE'VE MADE A MISTAKE TCP_ERROR(9); end if; exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN BAD SYN HANDLER"); when others => PUT_LINE("UNKNOWN ERROR IN BAD SYN HANDLER"); end BAD_SYN_HANDLER; procedure SEND_A_RESET_AND_ACK( LCN : in TCB_PTR) is BUFFTYPE : SIXTEEN_BITS ; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; PACKED_BUFFER : PACKED_BUFFER_PTR; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin -- GET A BUFFER BUFFGET(PACKED_BUFFER, BUFFTYPE); if PACKED_BUFFER = null then -- TELL USER ERROR OUT OF BUFFERS SOCKET_PARAMS := LCN; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFFER.IN_USE := TRUE; PACKED_BUFFER.STATUS := OWNER_TCP; -- CLEAR THE OPTIONS ARRAY OPTIONS := CLEAR; TCP_HEADER_FORMAT(LCN, BUFPTR, RST_ACK, OPTIONS); -- HERE WE MUST SET UP THE SECURITY OPTIONS FOR IP OPTIONS := TCP_SECURITY_OPTIONS; -- PACK BUFFER UP PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFFER); -- THE LENGTH OF THE BUFFER WILL BE HEADER LENGTH ONLY SEND_IP( LCN.DESTINATION_ADDRESS, LCN.SOURCE_ADDRESS, TOS, TTL, PACKED_BUFFER, LEN, IDENT, DONT_FRAGMENT, OPTIONS, RESULT ); -- if RESULT = OK then -- UPDATE SEND NEXT. NOT REALLY NECESSARY. -- null; -- else -- -- TELL USER WE ARE OUT OF SPACE -- SOCKET_PARAMS.LCN := LCN; -- SOCKET_PARAMS.FOREIGN_NET_HOST := LCN.DESTINATION_ADDRESS; -- SOCKET_PARAMS.FOREIGN_PORT := LCN.FOREIGN_PORT; -- UMESSAGE := ( 22, -- SOCKET_PARAMS); -- MESSAGE_FOR_USER(UMESSAGE); -- end if; end if; exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN SEND A RESET AND ACK"); when others => PUT_LINE("UNKNOWN ERROR IN SEND A RESET AND ACK"); end SEND_A_RESET_AND_ACK; end TCP_ARRIVES_PERIPHERALS; --:::::::::::::: --per1b.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01186-100(-) -- E-Systems, Inc. August 07, 1985 -- -- per1b.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_ULP_COMMUNICATE; use WITH_ULP_COMMUNICATE; with TCP_GLOBALS; use TCP_GLOBALS; with QUEUES; use QUEUES; with T_TCP_GLOBALS_DATA_STRUCTURES; use T_TCP_GLOBALS_DATA_STRUCTURES; with BUFFER_DATA; use BUFFER_DATA; package T_TCP_ARRIVES_1 is ---------------------------------------------------------- --This implementation is for use with the Telesoft Ada -- --compiler version 1.5 . -- ---------------------------------------------------------- ------------------------------------------------------------------------------ -- THIS PACKAGE CONTAINS SOME OF THE PROCEDURES AND FUNCTIONS NECESSARY FOR -- -- PROCESSING ARRIVED SEGMENTS. PCKG. REQUIRED TO REDUCE FILE SIZE -- ------------------------------------------------------------------------------ type RES is (GOOD, BAD); --***********************GLOBAL ROUTINES******************************** procedure FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES ( LCN : in out TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure checks to see if the fin bit is set. If the fin is --set it then puts the TCB in the close-wait state. procedure PROCESS_SEGMENT_TEXT( LCN : in TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure will determine if text exists and if so fill as many --receive buffers as it can and return them to the user. Any data it --can not return it will queue up. procedure PROCESS_URGENT_FLAG( LCN : in TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure checks the urgent bit and if set, it will notify the --user of urgent data (if the urgent pointer is in advance of the data --and the user has not already been notified). procedure PROCESS_A_FIN( LCN : in out TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure will notify the user that the connection is closing, --and return all receives with data if possible. It will also ensure --that an ack was or will be sent for the fin. procedure SEND_A_PIGGYBACKED_ACK( LCN : in out TCB_PTR); --This procedure will send an ack together with data (if available) --to the IP for processing. It will also try to clear the transmit --queue of data. By sending it. It will update everything necessary --in the TCB. procedure SEND_FROM_TRANSMIT_QUEUE( LCN : in out TCB_PTR); --This procedure will send any segments from the transmit queue that --will fit in the window. It will format them for transmission. It --will check upon emptying its queue for the close pending flag and --take appropriate action. function UNPACK( PACKED_BUFFER : in PACKED_BUFFER_PTR; TOTAL_DATA_BYTES : in SIXTEEN_BITS ) return BUFFER_POINTER; --This function will take an array of system.bytes (a bit stream) and --unpack this into an easy to use record. It uses the generic --function unchecked conversion via several functions to move the bits --into the record fields. The system bytes are considered to be --integers. We simply move the proper number of bits into the proper --fields in the record. procedure PROCESS_COMMON_ACK( LCN : in TCB_PTR; BUFPTR : in BUFFER_POINTER; RESULT : out RES); --This procedure does all the processing for an arrived ack in the --established state as per the specification. This processing is --common to the other states also. procedure ENTER_ESTABLISHED_STATE_PROCESSING( LCN : in TCB_PTR; BUFPTR : in out BUFFER_POINTER); --This procedure will perform all the processing of a segment in the --established state, beginning with the check of the urgent flag. --It will also process all the data on the TCP received segment queue. -- ******************************************************************* RESULTS : RES; BUFFTYPE : CONSTANT SIXTEEN_BITS := 1; -- ONLY ONE TYPE OF BUFFER FOR NOW. GLOBAL_PACKED_BUFFER : PACKED_BUFFER_PTR; end T_TCP_ARRIVES_1 ; with IP_GLOBALS ; use IP_GLOBALS ; with TEXT_IO; use TEXT_IO, INTEGER_IO; with SYSTEM; with UNCHECKED_CONVERSION; with MODULO; use MODULO; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with TCB_ALLOCATOR; use TCB_ALLOCATOR; package body T_TCP_ARRIVES_1 is procedure FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES( LCN : in out TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is begin if BUFPTR.FIN = BIT_SET then PROCESS_A_FIN(LCN, BUFPTR); LCN.STATE := CLOSE_WAIT; end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN FIN CHECKER"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR IN FIN CHECKER"); end FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES; procedure PROCESS_SEGMENT_TEXT( LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is NEW_DATA : SIXTEEN_BITS := BUFPTR.DATA_LEN; NULL_BUFFER : PACKED_BUFFER_PTR := NULL; PACKED_BUFF, RECEIVE_BUFFER, QUEUED_DATA_BUFFER : PACKED_BUFFER_PTR; BUFFTYPE, LENGTH, DATA_LENGTH : SIXTEEN_BITS ; UMESSAGE : USER_MESSAGE; Q_ITEM : STD_Q_ITEM; LCN_OUT : TCB_PTR := LCN; -- NECESSARY TO PASS OUT THE LCN DATA_QUEUED_FOR_USER : BOOLEAN := TRUE; SOCKET_PARAMS : TCB_PTR; begin while not QUEUE_EMPTY(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN_OUT) and then (NOT QUEUE_EMPTY(RECEIVE_QUEUE, LCN_OUT)) loop -- SO DATA EXISTS AND A RECEIVE -- GET A BUFFER OFF OF THE PROCESSED QUEUE QUEUE_GET(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN, Q_ITEM); QUEUED_DATA_BUFFER := Q_ITEM.BUFFER; DATA_LENGTH := Q_ITEM.LENGTH; QUEUE_GET(RECEIVE_QUEUE, LCN, Q_ITEM); RECEIVE_BUFFER := Q_ITEM.BUFFER; LENGTH := Q_ITEM.LENGTH; if RECEIVE_BUFFER /= null then -- SHOULD NEVER HAPPEN THAT IT IS NULL -- FILL A RECEIVE BUFFER AND RETURN IT TO THE USER INSERT_TEXT_IN_BUFFER(LENGTH, RECEIVE_BUFFER, DATA_LENGTH, QUEUED_DATA_BUFFER); -- SET UP MESSAGE SOCKET_PARAMS := LCN; UMESSAGE := ( 10, SOCKET_PARAMS, RECEIVE_BUFFER); MESSAGE_FOR_USER(UMESSAGE); -- FREE UP THE BUFFER FROM THE PROCESSED Q SINCE ONE EXISTS. BUFFREE(QUEUED_DATA_BUFFER, BUFFTYPE); -- GO TRY TO GET A NEW ONE. else -- PUT IT BACK ON THE QUEUE -- RESTORE THE Q_ITEM. Q_ITEM.BUFFER := QUEUED_DATA_BUFFER; Q_ITEM.LENGTH := DATA_LENGTH; QUEUE_ADD_TO_FRONT(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN, Q_ITEM); TEXT_IO.PUT_LINE("A STRANGE RESULT IN PROCESS TEXT"); end if; end loop; if NEW_DATA > 0 then QUEUE_GET(RECEIVE_QUEUE, LCN, Q_ITEM); RECEIVE_BUFFER := Q_ITEM.BUFFER; LENGTH := Q_ITEM.LENGTH; if RECEIVE_BUFFER /= null then -- WE GOT ONE -- PUT IN THE DATA RECEIVE_BUFFER.BYTE (RECEIVE_BUFFER.TCP_PTR..RECEIVE_BUFFER.TCP_PTR + NEW_DATA - 1) := BUFPTR.DATA(1..NEW_DATA); RECEIVE_BUFFER.TELNET_PTR := RECEIVE_BUFFER.TCP_PTR + NEW_DATA - 1; if BUFPTR.PUSH_FLAG = BIT_SET then -- NOTIFY USER WHEN DATA IS RETURNED -- SET UP PROPER MESSAGE RECORD SOCKET_PARAMS := LCN; UMESSAGE := ( 19, SOCKET_PARAMS, NULL_BUFFER); MESSAGE_FOR_USER(UMESSAGE); end if; -- GIVE IT TO THE USER -- SET UP MESSAGE SOCKET_PARAMS := LCN; UMESSAGE := ( 10, SOCKET_PARAMS, RECEIVE_BUFFER); MESSAGE_FOR_USER(UMESSAGE); else -- TRY TO QUEUE IT ON UP BUFFGET(PACKED_BUFF, BUFFTYPE); if PACKED_BUFF = null then TCP_ERROR(7); DATA_QUEUED_FOR_USER := FALSE; else -- SET UP THE POINTER AND INSERT ALL THE DATA. PACKED_BUFF.STATUS := OWNER_TCP; PACKED_BUFF.IN_USE := TRUE; PACKED_BUFF.TCP_PTR := 10; -- PUT THE DATA IN THE BUFFER PACKED_BUFF.BYTE(10..9+NEW_DATA) := BUFPTR.DATA(1..NEW_DATA); Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, NEW_DATA); QUEUE_ADD(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN, Q_ITEM); end if; end if; end if; -- IF WE GOT SOME TEXT WE WILL UPDATE RCV_NXT -- AND SEND A PIGGYBACKED ACK. if NEW_DATA > 0 and (DATA_QUEUED_FOR_USER) then LCN.RCV_NXT := LCN.RCV_NXT + NEW_DATA; if BUFPTR.FIN = BIT_SET then -- ADVANCE RCV NEXT OVER THE FIN ALSO. THIS WILL -- CAUSE IT TO ALSO BE ACKED. LCN.RCV_NXT := LCN.RCV_NXT + MODULAR_CONVERT( SIXTEEN_BITS( 1 ) ) ; end if; SEND_A_PIGGYBACKED_ACK(LCN_OUT); end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN PROCESS SEGMENT TEXT"); INTEGER_IO.PUT(RECEIVE_BUFFER.TCP_PTR); INTEGER_IO.PUT(NEW_DATA); TEXT_IO.PUT_LINE(""); when others => TEXT_IO.PUT_LINE("ERROR IN PROCESS SEGMENT TEXT"); end PROCESS_SEGMENT_TEXT; procedure PROCESS_URGENT_FLAG (LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; begin if BUFPTR.URG_FLAG = BIT_SET then if LCN.RCV_URGENT_POINTER < BUFPTR.URG_PTR then LCN.RCV_URGENT_POINTER := BUFPTR.URG_PTR; end if; if (LCN.USER_NOTIFICATION = FALSE) and (LCN.RCV_URGENT_POINTER > BUFPTR.DATA_LEN) then -- TELL USER -- URGENT DATA IS ON THE WAY. SOCKET_PARAMS := LCN; UMESSAGE := ( 7, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.USER_NOTIFICATION := TRUE; end if; else LCN.USER_NOTIFICATION := FALSE; end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN PROCESS URGENT FLAG"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR IN PROCESS URGENT FLAG"); end PROCESS_URGENT_FLAG; procedure PROCESS_A_FIN( LCN : in out TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is UMESSAGE : USER_MESSAGE ; LENGTH, DATA_LENGTH, INDEX, INDEX1 : SIXTEEN_BITS ; RECEIVED_PACKED_BUFFER, PACKED_BUFFER : PACKED_BUFFER_PTR ; BUFFTYPE : SIXTEEN_BITS ; Q_ITEM : STD_Q_ITEM ; SOCKET_PARAMS : TCB_PTR ; begin -- NOTE THAT THE FIN IMPLIES A PUSH FUNCTION -- WHICH WE CURRENTLY DO NOT IMPLEMENT. -- TELL USER CONNECTION CLOSING IF HE HAS -- NOT ALREADY REQUESTED A CLOSE. if LCN.STATE /= T_TCP_GLOBALS_DATA_STRUCTURES.FIN_WAIT_1 and (LCN.STATE /= T_TCP_GLOBALS_DATA_STRUCTURES.FIN_WAIT_2) then SOCKET_PARAMS := LCN; UMESSAGE := ( 6, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; QUEUE_GET(RECEIVE_QUEUE, LCN, Q_ITEM); RECEIVED_PACKED_BUFFER := Q_ITEM.BUFFER; LENGTH := Q_ITEM.LENGTH; while RECEIVED_PACKED_BUFFER /= null loop QUEUE_GET(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN, Q_ITEM); PACKED_BUFFER := Q_ITEM.BUFFER; DATA_LENGTH := Q_ITEM.LENGTH; if PACKED_BUFFER /= null then -- FILL RECEIVE BUFFER WITH DATA, INDICATE A -- PUSH AND DELETE DATA FROM Q. -- A PUSH IS AUTOMATICALLY IMPLIED AND Q ROUTINE -- PERFORMS DELETE. RETURN THE DATA INSERT_TEXT_IN_BUFFER(LENGTH, RECEIVED_PACKED_BUFFER, DATA_LENGTH,PACKED_BUFFER); -- FREE UP THE UNEEDED BUFFER FROM PROCESSED Q. PACKED_BUFFER.STATUS := NONE; BUFFREE(PACKED_BUFFER, BUFFTYPE); -- GET THE NEXT RECEIVE. QUEUE_GET(RECEIVE_QUEUE, LCN, Q_ITEM); RECEIVED_PACKED_BUFFER := Q_ITEM.BUFFER; LENGTH := Q_ITEM.LENGTH; else -- PUT RECEIVE BACK ON QUEUE Q_ITEM := (RECEIVED_PACKED_BUFFER, NULL_UNPACKED_BUFFER, LENGTH); QUEUE_ADD_TO_FRONT(RECEIVE_QUEUE, LCN, Q_ITEM); RECEIVED_PACKED_BUFFER := NULL; -- DID NOT GET ANY TEXT end if; end loop; -- DETERMINE IF FIN WAS ACKED PREVIOUSLY, -- IF NOT ADVANCE RCV.NXT AND ACK IT if LCN.RCV_NXT <= BUFPTR.SEQ_NUM then -- ADVANCE IT AND SEND AN ACK LCN.RCV_NXT := LCN.RCV_NXT + MODULAR_CONVERT( SIXTEEN_BITS ( 1 ) ) ; SEND_A_PIGGYBACKED_ACK(LCN); end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN PROCESS A FIN"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR IN PROCESS A FIN"); end PROCESS_A_FIN; procedure SEND_A_PIGGYBACKED_ACK( LCN : in out TCB_PTR) is TRANS_BUFFER : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; LENGTH, BUFFTYPE : SIXTEEN_BITS ; QUEUE_EMPTY : BOOLEAN; TYPE_FLAG : HEADER_TYPE; PACKED_BUFFER : PACKED_BUFFER_PTR; Q_ITEM : STD_Q_ITEM; ACK_BUFFER_EXISTS : BOOLEAN := TRUE; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; procedure SET_UP_TO_SEND_AN_ACK is -- EVERTHING IS EXTERNAL TO THIS PROCEDURE. -- WHICH GETS A BUFFER,SETS THE TYPE FLAG AND UPDATES SND_NXT. begin -- MUST GET A BUFFER BUFFGET(PACKED_BUFFER, BUFFTYPE); if PACKED_BUFFER = null then --WE HAVE A BAD ERROR TCP_ERROR(7); ACK_BUFFER_EXISTS := FALSE; else PACKED_BUFFER.IN_USE := FALSE; PACKED_BUFFER.STATUS := NONE; TYPE_FLAG := ACK; end if; end SET_UP_TO_SEND_AN_ACK; begin -- GET A BUFFER FROM THE TRANSMIT QUEUE IF POSSIBLE. QUEUE_GET(TRANSMIT_QUEUE, LCN, Q_ITEM); PACKED_BUFFER := Q_ITEM.BUFFER; LENGTH := Q_ITEM.LENGTH; QUEUE_EMPTY := PACKED_BUFFER = null; if not QUEUE_EMPTY then if LCN.SND_WND + LCN.SND_UNA >= (LENGTH + LCN.SND_NXT) then --IT IS OFF THE QUEUE TYPE_FLAG := SEG_ACK; else -- SEND THE ACK ANYWAY -- PUT THE BUFFER BACK ON THE QUEUE. QUEUE_ADD_TO_FRONT(TRANSMIT_QUEUE, LCN, Q_ITEM); -- THIS PROCEDURE GETS A BUFFER AND DOES THE -- OTHER NECESSARY THINGS TO SEND AN ACK ONLY. SET_UP_TO_SEND_AN_ACK; end if; else -- JUST SEND AN ACK -- THIS PROCEDURE GETS A BUFFER AND DOES THE OTHER -- NECESSARY THINGS TO SEND AN ACK ONLY. SET_UP_TO_SEND_AN_ACK; end if; -- NOW WE SEND OUT AN ACK OR PIGGYBACKED ACK -- CLEAR OPTIONS ARRAY if ACK_BUFFER_EXISTS then -- DO IT OPTIONS := CLEAR; TCP_HEADER_FORMAT(LCN, TRANS_BUFFER, TYPE_FLAG, OPTIONS); -- HERE WE MUST SET UP THE SECURITY OPTIONS FOR IP OPTIONS := TCP_SECURITY_OPTIONS; -- PACK THE BUFFER PACK_BUFFER_INTO_BIT_STREAM(TRANS_BUFFER, PACKED_BUFFER); LEN := TRANS_BUFFER.DATA_OFFSET * 4 + LENGTH; SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFFER, LEN, IDENT, DONT_FRAGMENT, OPTIONS, RESULT ); -- UPDATE SND_NXT -- WE DO NOT CHANGE THE SEQUENCE NUMBER IF WE ONLY SEND AN ACK if LENGTH > 0 then LCN.SND_NXT := LCN.SND_NXT + LENGTH; -- A PIGGYBACKED ACK WAS SENT end if; if TYPE_FLAG = SEG_ACK then -- PUT IT ON THE RETRANSMIT QUEUE Q_ITEM :=(PACKED_BUFFER, NULL_UNPACKED_BUFFER, LEN); QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); end if; -- SEE IF WE CAN SEND SOME MORE SEGMENTS FROM THE TRANSMIT Q. if NOT QUEUE_EMPTY then SEND_FROM_TRANSMIT_QUEUE(LCN); end if; end if; exception when others => TEXT_IO.PUT_LINE("PROBLEM IN PIGGYBACKED ACK ROUTINE"); end SEND_A_PIGGYBACKED_ACK; procedure SEND_FROM_TRANSMIT_QUEUE(LCN : in out TCB_PTR) is TRANS_BUFFER : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; CAN_SEND : BOOLEAN := TRUE; PACKED_BUFF : PACKED_BUFFER_PTR; DATA_LENGTH, INDEX : SIXTEEN_BITS ; Q_ITEM : STD_Q_ITEM; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin -- TRY TO GET THE INITIAL BUFFER OF DATA FOR TRANSMIT. -- DATA LENGTH WILL BE THE NUMBER OF DATA OCTETS IN THE BUFFER. -- THEY WILL BE THE ONLY THINGS IN THE BUFFER. QUEUE_GET(TRANSMIT_QUEUE, LCN, Q_ITEM); PACKED_BUFF := Q_ITEM.BUFFER; DATA_LENGTH := Q_ITEM.LENGTH; while PACKED_BUFF /= null and CAN_SEND loop if LCN.SND_WND + LCN.SND_UNA >= (LCN.SND_NXT + DATA_LENGTH) then -- WE CAN SEND IT. -- CLEAR OPTIONS ARRAY. IF ANY OPTIONS WENT -- HERE WE WOULD ADD TO THE HEADER LENGTH APPROPRIATELY. OPTIONS := CLEAR; -- PUT THE DATA IN THE BUFFER. -- CURRENTLY MAX OF ONE OCTET SO JUST PUT IT IN. INDEX := PACKED_BUFF.TCP_PTR; TRANS_BUFFER.DATA(1..DATA_LENGTH) := PACKED_BUFF.BYTE(INDEX..INDEX + DATA_LENGTH - 1); TCP_HEADER_FORMAT(LCN, TRANS_BUFFER, SEGMENT, OPTIONS); -- HERE WE MUST SET UP THE SECURITY OPTIONS FOR IP OPTIONS := TCP_SECURITY_OPTIONS; -- PACK THE BUFFER PACK_BUFFER_INTO_BIT_STREAM(TRANS_BUFFER, PACKED_BUFF); LEN := TRANS_BUFFER.DATA_OFFSET * 4 + DATA_LENGTH; -- TOTAL TCP LENGTH SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFF, LEN, IDENT, DONT_FRAGMENT, OPTIONS, RESULT ); -- UPDATE SND_NXT LCN.SND_NXT := LCN.SND_NXT + TRANS_BUFFER.DATA_LEN; -- PUT IT ON THE RETRANSMIT QUEUE Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER,LEN); QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); -- GET ANOTHER BUNCH OF DATA TO BE SENT QUEUE_GET(TRANSMIT_QUEUE, LCN, Q_ITEM); PACKED_BUFF := Q_ITEM.BUFFER; DATA_LENGTH := Q_ITEM.LENGTH; else CAN_SEND := FALSE; -- PUT IT BACK ON THE QUEUE IN THE FIRST SPOT QUEUE_ADD_TO_FRONT(TRANSMIT_QUEUE, LCN, Q_ITEM); end if; end loop; if QUEUE_EMPTY(TRANSMIT_QUEUE, LCN) then -- CHECK FOR CLOSE PENDING if LCN.CLOSE_PENDING then if LCN.STATE = T_TCP_GLOBALS_DATA_STRUCTURES.CLOSE_WAIT then LCN.STATE := CLOSING; else LCN.STATE := T_TCP_GLOBALS_DATA_STRUCTURES.FIN_WAIT_1; end if; end if; end if; exception when constraint_error => TEXT_IO.PUT_LINE("A CONSTRAINT ERROR IN SEND "); TEXT_IO.PUT_LINE("FROM TRANSMIT QUEUE"); when others => TEXT_IO.PUT_LINE("AN UNKNOWN ERROR IN SEND FROM TRANSMIT QUEUE"); end SEND_FROM_TRANSMIT_QUEUE; function UNPACK( PACKED_BUFFER : in PACKED_BUFFER_PTR; TOTAL_DATA_BYTES : in SIXTEEN_BITS ) return T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER is type ARRAY_OF_BITS is array(1..6) of SIXTEEN_BITS ; UNPACKED_BUFFER : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; INDEX : SIXTEEN_BITS := PACKED_BUFFER.TCP_PTR; BIT_ARRAY : ARRAY_OF_BITS; TCP_DATA_BYTES : SIXTEEN_BITS := TOTAL_DATA_BYTES; function CONVERT_BYTE_TO_BITS( LENGTH : SIXTEEN_BITS ; BYTE : SYSTEM_BYTE) return ARRAY_OF_BITS is -- THIS FUNCTION IS CALLED TO CONVERT A BYTE INTO ITS -- COMPONENT 'LENGTH' BITS -- -- AN ARRAY OF BITS. EACH ELEMENT OF THE ARRAY IS EITHER 0 OR 1. -- IT IS 0 IF -- THE CORRESPONDING BIT IN BYTE IS NOT SET AND ONE OTHERWISE. -- -- PROCESSING : -- -- IF THE BYTE'S VALUE IS GREATER THAT 2**LENGTH-1 AND IF SO IT -- KNOWS THAT THE BIT IS SET. IT THEN DECREMENTS LENGTH AND -- SUBTRACTS 2**LENGTH-1 FROM BYTE IF THE BIT WAS SET. THIS PROCESS -- IS CONTINUED UNTIL 0 IS REACHED. -- -- RESTRICTIONS : -- TEMP : SIXTEEN_BITS := SIXTEEN_BITS ( BYTE ) ; BIT_ARRAY : ARRAY_OF_BITS; begin for I in reverse 0..LENGTH-1 loop if TEMP >= 2 ** I then BIT_ARRAY( I + 1 ) := 1; TEMP := TEMP - 2 ** I ; else BIT_ARRAY( I + 1 ) := 0; end if; end loop; return BIT_ARRAY; exception when others => TEXT_IO.PUT_LINE("ERROR IN UNPACK CONVERT BYTES TO BITS"); INTEGER_IO.PUT(INDEX); end CONVERT_BYTE_TO_BITS; function CONVERTED_LONG_INTEGER( INDEX : in SIXTEEN_BITS ) return THIRTYTWO_BITS is -- THIS FUNCTION TAKES FOUR SYSTEM.BYTES FROM THE ARRAY POINTED TO BY -- PACKED_BUFFER AND MOVES THEM INTO A LONG_INTEGER WITH THE FUNCTION -- UNCHECKED_CONVERSION. IT FIRST MOVES THE SYSTEM BYTES INTO A -- TEMPORARY ARRAY OF FOUR SYSTEM BYTES AND PUTS THESE IN A ONE -- ELEMENT LONG_INTEGER ARRAY. type HOLD_LONG_INTEGER is array(1..1) of THIRTYTWO_BITS ; type FOUR_BYTES is array(1..4) of SYSTEM.BYTE; function CONVERT_BYTES_TO_LONG_INTEGER is new UNCHECKED_CONVERSION(FOUR_BYTES,HOLD_LONG_INTEGER); HOLD_LONG_INT : HOLD_LONG_INTEGER; FOUR_BYTE_HOLDER : FOUR_BYTES; begin for I in 1..4 loop FOUR_BYTE_HOLDER(5 - I) := PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS(I) - 1 ) ; end loop; HOLD_LONG_INT := CONVERT_BYTES_TO_LONG_INTEGER(FOUR_BYTE_HOLDER); return HOLD_LONG_INT(1); exception when others => TEXT_IO.PUT_LINE("ERROR IN UNPACK CONVERTED LONG INTEGER"); INTEGER_IO.PUT(INDEX); end CONVERTED_LONG_INTEGER; function CONVERTED_INTEGER( INDEX : in SIXTEEN_BITS ) return SIXTEEN_BITS is -- THIS FUNCTION USES UNCHECKED_CONVERSION TO ALLOW AN ARRAY OF TWO -- SYSTEM BYTES TO BE PLACED IN A ONE ELEMENT INTEGER ARRAY. THIS -- ARRAY ELEMENT IS THEN RETURNED. type TWO_BYTES is array(1..2) of SYSTEM.BYTE; type HOLD_AN_INTEGER is array(1..1) of SIXTEEN_BITS ; function CONVERT_BYTES_TO_INTEGER is new UNCHECKED_CONVERSION(TWO_BYTES,HOLD_AN_INTEGER); TWO_BYTE_HOLDER : TWO_BYTES; HOLD_INTEGER : HOLD_AN_INTEGER; begin TWO_BYTE_HOLDER(1) := PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS(2) - 1 ) ; TWO_BYTE_HOLDER(2) := PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS(1) - 1 ) ; HOLD_INTEGER := CONVERT_BYTES_TO_INTEGER(TWO_BYTE_HOLDER); return HOLD_INTEGER(1); exception when others => TEXT_IO.PUT_LINE("ERROR IN UNPACK CONVERTED INTEGER"); INTEGER_IO.PUT(INDEX); end CONVERTED_INTEGER; begin -- MAIN -- PUT UNPACKED DATA IN THE BUFFER --NEW_LINE; --TEXT_IO.PUT_LINE("UNPACKING THE TCP_HEADER"); UNPACKED_BUFFER.SOURCE_PORT := CONVERTED_INTEGER(INDEX); --TEXT_IO.PUT_LINE("SOURCE_PORT := "); --INTEGER_IO.PUT(UNPACKED_BUFFER.SOURCE_PORT); --NEW_LINE; INDEX := INDEX + 2; UNPACKED_BUFFER.DESTINATION_PORT := CONVERTED_INTEGER(INDEX); INDEX := INDEX + 2; UNPACKED_BUFFER.SEQ_NUM := MODULAR_CONVERT(CONVERTED_LONG_INTEGER(INDEX)); INDEX := INDEX + 4; UNPACKED_BUFFER.ACK_NUM := MODULAR_CONVERT(CONVERTED_LONG_INTEGER(INDEX)); INDEX := INDEX + 4; UNPACKED_BUFFER.DATA_OFFSET := SIXTEEN_BITS(PACKED_BUFFER.BYTE(INDEX))/ (2**4) ; -- THE HIGH 4 BITS INDEX := INDEX + 1; -- SET THE TCP FLAGS BIT_ARRAY := CONVERT_BYTE_TO_BITS(6, PACKED_BUFFER.BYTE(INDEX)); UNPACKED_BUFFER.URG_FLAG := BIT_ARRAY(6); UNPACKED_BUFFER.ACK := BIT_ARRAY(5); UNPACKED_BUFFER.PUSH_FLAG := BIT_ARRAY(4); UNPACKED_BUFFER.RST := BIT_ARRAY(3); UNPACKED_BUFFER.SYN := BIT_ARRAY(2); UNPACKED_BUFFER.FIN := BIT_ARRAY(1); INDEX := INDEX + 1; UNPACKED_BUFFER.WINDOW := CONVERTED_INTEGER(INDEX); INDEX := INDEX + 2; UNPACKED_BUFFER.TCP_CSUM := CONVERTED_INTEGER(INDEX); INDEX := INDEX + 2; UNPACKED_BUFFER.URG_PTR := CONVERTED_INTEGER(INDEX); INDEX := INDEX +2; -- HERE WE WOULD CONVERT THE CURRENTLY UNIMPLEMENTED -- OPTIONS. if UNPACKED_BUFFER.DATA_OFFSET > 5 then TEXT_IO.PUT_LINE("ERROR IN UNPACKING A BUFFER"); TCP_ERROR(10); end if; -- UNPACK THE DATA TCP_DATA_BYTES := TCP_DATA_BYTES - UNPACKED_BUFFER.DATA_OFFSET * 4; -- WE UNPACKED_BUFFER.DATA_LEN := TCP_DATA_BYTES;-- SET UP THE DATA LENGTH IN BUFFER -- ARE PASSED THE TOTAL BYTES(OCTETS) IN THE TCP. -- WE ONLY WANT DATA. for I in 1..TCP_DATA_BYTES loop UNPACKED_BUFFER.DATA(I) := PACKED_BUFFER.BYTE(INDEX+I-1); end loop; return UNPACKED_BUFFER; exception when others => TEXT_IO.PUT_LINE("ERROR IN UNPACK MAIN"); INTEGER_IO.PUT(INDEX); end UNPACK; procedure PROCESS_COMMON_ACK( LCN : in TCB_PTR; BUFPTR : in T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; RESULT : out RES) is LOC_CON_NAME : TCB_PTR := LCN; NULL_ITEM : STD_Q_ITEM := (NULL, NULL_UNPACKED_BUFFER, 0); begin RESULT := GOOD; if BUFPTR.ACK_NUM > LCN.SND_NXT then -- IT ACKS SOMETHING NOT YET SENT SEND_A_PIGGYBACKED_ACK(LOC_CON_NAME); RESULT := BAD; else if BUFPTR.ACK_NUM <= LCN.SND_UNA then -- IGNORE IT, SINCE IT IS A DUPLICATE. -- THE SEGMENT IS OK, HOWEVER. SO THE RESULT IS GOOD. RESULT := GOOD; else -- UPDATE THE SENT UNACKNOWLEDGED FIELD OF THE TCB. LCN.SND_UNA := BUFPTR.ACK_NUM; -- REMOVE ALL BUFFERS THAT ARE FULLY ACKNOWLEDGED -- FROM THE RETRANS QUEUE. -- RETURN SEND BUFFERS TO USER WITH OK RESPONSE. -- THESE ARE BOTH DONE BY RETRANSMIT QUEUE. DELETE_FROM_RETRANS_QUEUE(LCN, LCN.SND_UNA); if (LCN.SND_WL1 < BUFPTR.SEQ_NUM) or ((LCN.SND_WL1 = BUFPTR.SEQ_NUM) and (LCN.SND_WL2 <= BUFPTR.ACK_NUM)) then LCN.SND_WND := BUFPTR.WINDOW; LCN.SND_WL1 := BUFPTR.SEQ_NUM; LCN.SND_WL2 := BUFPTR.ACK_NUM; end if; -- SEE IF WE CAN SEND ANYTHING WITHIN THE SEND WINDOW -- FROM THE TRANSMIT Q SEND_FROM_TRANSMIT_QUEUE(LOC_CON_NAME); end if; end if; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN PROCESS COMMON ACK"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR IN PROCESS COMMON ACK"); end PROCESS_COMMON_ACK; procedure ENTER_ESTABLISHED_STATE_PROCESSING( LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER) is MORE_THAN_ONCE : BOOLEAN := FALSE; NEW_LCN : TCB_PTR; ITEM : STD_Q_ITEM := (NULL, NULL_UNPACKED_BUFFER, 0); TEMP_BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; begin LCN.CONNECTION_STATUS := CONNECTION_OPEN; NEW_LCN := LCN; -- NECESSARY FOR A IN OUT PARAM. IN FIN CHECK CALL. TEMP_BUFPTR := BUFPTR;-- SAVE THE BUFFER. -- PROCESS THE REST OF FIRST BUFFER AND -- THEN ALL PARTIALLY PROCESSED BUFFERS -- ON THE TCP_RETRANSMIT_QUEUE while not MORE_THAN_ONCE or (ITEM.LENGTH > 0 ) loop PROCESS_URGENT_FLAG(LCN, BUFPTR); PROCESS_SEGMENT_TEXT(LCN, BUFPTR); FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES(NEW_LCN, BUFPTR); -- CHECK THE RECEIVED SEGMENT QUEUE TO -- DETERMINE IF THERE ARE ANY SEG -- THAT NEED CONTINUED PROCESSING ON IT. QUEUE_GET(TCP_RECEIVED_SEGMENT_QUEUE, LCN, ITEM); MORE_THAN_ONCE := TRUE; BUFPTR := ITEM.UNPACKED_BUFFER; end loop; BUFPTR := TEMP_BUFPTR; -- RESTORE THE BUFFER -- HERE WE WILL TRANSMIT ALL DATA WAITING -- TO GO ON THE SEND QUEUE SEND_FROM_TRANSMIT_QUEUE(NEW_LCN); exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN ENTER ESTABLISHED "); TEXT_IO.PUT_LINE("STATE PROCESSING"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR IN ENTER ESTABLISHED "); TEXT_IO.PUT_LINE("STATE PROCESSING"); end ENTER_ESTABLISHED_STATE_PROCESSING; end T_tcp_arrives_1 ; --:::::::::::::: --reassem.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01187-100(-) -- E-Systems, Inc. August 07, 1985 -- -- reassem.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with SYSTEM; use SYSTEM; with BUFFER_DATA; use BUFFER_DATA; with IP_GLOBALS; use IP_GLOBALS; package REASSEMBLY_UTILITIES is ---------------------------------------------------------- --This implementation is for use with the DEC/Ada -- --compiler. -- ---------------------------------------------------------- ------------------------------------------------------------------------------ --This package contains the necessary functions and subprograms needed -- --to support the reassembly mechnism of IP as specified by MIL-STD-1777. -- ------------------------------------------------------------------------------ MAXIMUM_DATA_RECEIVED_IN_FRAGMENT : constant SIXTEEN_BITS := 512; MAXIMUM_DATAGRAM_SIZE : constant SIXTEEN_BITS := 576; type STATE_NAME_TYPE is ( INACTIVE, REASSEMBLING ); type DATA_AREA is array(1..MAXIMUM_DATA_RECEIVED_IN_FRAGMENT) of SYSTEM.BYTE; type BIT_MAP is array(1..MAXIMUM_DATAGRAM_SIZE) of SIXTEEN_BITS ; subtype PROTOCOL_TYPE is SIXTEEN_BITS ; --should be a set of DoD accepted protocols subtype IDENTIFICATION_TYPE is SIXTEEN_BITS ; --should have a range constraint type BUFID_TYPE is record SOURCE : THIRTYTWO_BITS ; DESTINATION : THIRTYTWO_BITS ; PROTOCOL : PROTOCOL_TYPE; IDENTIFICATION : IDENTIFICATION_TYPE; end record; type YES_OR_NO is (YES,NO); MAXIMUM_REASSEMBLY_TIMEOUT : constant SIXTEEN_BITS := 225; subtype TIMER_TYPE is SIXTEEN_BITS range 15..MAXIMUM_REASSEMBLY_TIMEOUT; type REASSEMBLY_TABLE_TYPE; type REASSEMBLY_TABLE_POINTER is access REASSEMBLY_TABLE_TYPE; type REASSEMBLY_TABLE_TYPE is record PRIOR_ENTRY_REASSEMBLY_TABLE : REASSEMBLY_TABLE_POINTER; REASSEMBLY_DATAGRAM : BUFFER_DATA.PACKED_BUFFER_PTR; NEXT_ENTRY_REASSEMBLY_TABLE : REASSEMBLY_TABLE_POINTER; -- reassembly information BUFID : BUFID_TYPE; STATE_NAME : STATE_NAME_TYPE := INACTIVE; HAS_FRAGMENT_ZERO_ARRIVED : BOOLEAN := FALSE; REASSEMBLY_MAP : BIT_MAP; TIMER : TIMER_TYPE := 15; TOTAL_DATA_LENGTH :SIXTEEN_BITS range 1..MAXIMUM_DATAGRAM_SIZE; DATA : DATA_AREA; HEADER : IP_GLOBALS.BUFFER_POINTER; end record; type REASSEMBLY_ERROR_TYPE is (NO_MORE_FREE_BUFFER_SPACE,NO_ERROR,NO_MORE_REASSEMBLY_BUFFER_SPACE); --****************** --* USER Semantics * --****************** --This function will return a true value if the incoming datagram --is part of a fragment. function A_FRAG ( PACKED_BUFFER : in BUFFER_DATA.PACKED_BUFFER_PTR; BUFPTR : in IP_GLOBALS.BUFFER_POINTER ) return YES_OR_NO; --************************** --* PACKAGE BODY Semantics * --************************** --The following algorithm is completly compatible with MIL-STD-1777 --section 9.4.6.2.1. -- -- Data examine: -- FROM_SNP.DTGM.FRAGMENT_OFFSET -- FROM_SNP.DTGM.MORE_FRAG_FLAG -- -- if ((FROM_SNP.DTGM.FRAGMENT_OFFSET = 0) -- and (FROM_SNP.DTGM.MORE_FRAG_FLAG = 0)) -- then return false -- else return true; -- end if; --****************** --* USER Semantics * --****************** --This function will return a true value if the incoming datagram --completes the fragment being reassembled. function REASS_DONE ( REASSEMBLY_BUFFER : in REASSEMBLY_TABLE_POINTER; BUFPTR : IP_GLOBALS.BUFFER_POINTER ) return YES_OR_NO; --************************** --* PACKAGE BODY Semantics * --************************** -- The total data length of the original datagram, as computed -- from "tail" fragment, must be known before completion is -- possible. -- -- Data examined: -- STATE_VECTOR.REASSEMBLY_MAP -- STATE_VECTOR.TOTAL_DATA_LENGTH -- FROM_SNP.DTGM.TOTAL_LENGTH -- FROM_SNP.DTGM.MORE_FRAG_FLAG -- FROM_SNP.DTGM.HEADER_LENGTH -- -- if ( STATE_VECTOR.TOTAL_DATA_LENGTH = 0 ) then -- Check incoming datagram for "tail." -- if ( FROM_SNP.DTGM.MORE_FRAG_FLAG = false ) then -- Compute total data length and see if data in -- this fragment fill out reasembly map. -- if ( STATE_VECTOR.REASEMBLY_MAP from 0 to -- (((FROM_SNP.DTGM.TOTAL_LENGTH - -- (FROM_SNP.DTGM.HEADER_LENGTH*4) + 7 ) / 8 ) -- + 7 ) / 8 is set ) -- then return true; -- end if; -- else -- Reassembly cannot be complete if total data length -- unknown. -- return false; -- end if; -- else -- Total data length is already known. See if data in this -- fragment fill out reassembly map. -- if ( all reassembly map from 0 to -- (STATE_VECTOR.TOTAL_DATA_LENGTH + 7 ) / 8 is set ) -- then -- return YES; -- else -- return NO; -- end if; --****************** --* USER Semantics * --****************** --This subprogram will generate an error datgram to the source IP informing --it of the datagram's expiration during reassembly. procedure REASSEMBLY_TIMEOUT ( REASSEMBLY_DATAGRAM_THAT_TIMED_OUT : in out REASSEMBLY_TABLE_POINTER; BUFPTR : in IP_GLOBALS.BUFFER_POINTER ); --************************** --* PACKAGE BODY Semantics * --************************** -- -- Data examined: -- STATE_VECTOR.HEADER -- STATE_VECTOR.DATA -- -- Data modified: -- TO_SNP.DTGM TO_SNP.TYPE_OF_SERVICE_INDICATORS -- TO_SNP.LENGTH TO_SNP.HEADER_LENGTH -- -- Format and transmit an error datagram to the source IP. -- -- TO_SNP.DTGM.VERSION := 4; -- standard IP version -- TO_SNP.DTGM.HEADER_LENGTH := 5; -- standard header size -- TO_SNP.DTGM.TYPE_OF_SERVICE := 0; -- routine service quality -- TO_SNP.DTGM.IDENTIFICATION := new value selected -- TO_SNP.DTGM.MORE_FRAG_FLAG := false; -- TO_SNP.DTGM.DONT_FRAG_FLAG := false; -- TO_SNP.DTGM.FRAGMENT_OFFSET := 0; -- TO_SNP.DTGM.TIME_TO_LIVE := 60; -- TO_SNP.DTGM.PROTOCOL := this number will be assigned -- by the DoD Executive Agent for -- Protocols; -- TO_SNP.DTGM.SOURCE_ADDR := STATE_VECTOR.HEADER.DESTINATION_ADDR; -- TO_SNP.DTGM.DESTINATION_ADDR := STATE_VECTOR.HEADER.SOURCE_ADDR; -- If the fragment received is the first fragment, then the data section -- caries the ICMP error message, the header of the timed-out datagram, -- and its first 64 bytes of data. If fragment zero is not available -- then no time exceeded need be sent at all. -- -- TO_SNP.DTGM.DATA[0] := 12; -- ICMP type = Time Exceeded -- TO_SNP.DTGM.DATA[1] := 1; -- Code = fragment reassembly timeout -- -- Copy in the timed-out datagram's header plus the first -- 64 bytes of its data section (asumed to be of length "N" ). -- -- TO_SNP.DTGM.DATA[8..N+3] := STATE_VECTOR[0..N-1]; -- TO_SNP.DTGM.TOTAL_LENGTH := TO_SNP.HEADER_LENGTH * 4 + N + 8; -- COMPUTE_ICMP_CHECKSUM; -- -- Compute datagram's header checksum, determine the route for the -- datagram, the type of service indicators, and the datagram size -- for the SNP. -- -- COMPUTE_CHECKSUM; -- TO_SNP.TYPE_OF_SERVICE_INDICATORS := 0; -- TO_SNP.LENGTH := TO_SNP.DTGM.TOTAL_LENGTH; -- ROUTE; -- -- Request the execution environment to pass the contents of -- TO_SNP to the local subnet protocol for transmision. -- -- TRANSFER TO_SNP to the SNP. --****************** --* USER Semantics * --****************** --This subprogram will add a fragment to a reassembling datagram. procedure REASSEMBLY ( PACKED_BUFFER : in out BUFFER_DATA.PACKED_BUFFER_PTR; REASSEMBLY_TABLE_ELEMENT : in out REASSEMBLY_TABLE_POINTER; BUFPTR : IP_GLOBALS.BUFFER_POINTER ); --************************** --* PACKAGE BODY Semantics * --************************** --The following algorithm is completly compatible with MIL-STD-1777 --section 9.4.6.2.2. -- -- Data examined: -- FROM_SNP.DTGM -- -- Data modified: -- STATE_VECTOR.REASSEMBLY_MAP -- STATE_VECTOR.TIMER -- STATE_VECTOR.TOTAL_DATA_LENGTH -- STATE_VECTOR.HEADER -- STATE_VECTOR.DATA -- -- Local variables: -- j -- loop counter -- DATA_IN_FRAG -- the number of octets of data in received -- -- fragment -- -- DATA_IN_FRAG := ( FROM_SNP.DTGM.TOTAL_LENGTH - FROM_SNP. -- DTGM.HEADER_LENGTH*4 ); -- -- Put data in its relative position in the data area of the state -- vector. -- -- STATE_VECTOR.DATA[FROM_SNP.DTGM.FRAGMENT_OFFSET*8.. -- FROM_SNP.DTGM.FRAGMENT_OFFSET*8+DATA_IN_FRAG] := -- FROM SNP.DTGM.DATA[0..DATA_IN_FRAG-1]; -- -- Fill in the corresponding entries of the reassembly map -- frpresenting each 8-octet unit of received data. -- -- for j in ( FOR_SNP.DTGM.FRAGMENT_OFFSET ) .. -- (( FROM_SNP.DTGM.FRAGMENT_OFFSET + DATA_IN_FRAG + -- 7)/8 ) loop -- STATE_VECTOR.REASSEMBLY_MAP[J] := 1; -- end if; -- -- Compute the total datagram length from the "tail-end" -- fragment. -- -- if ( FROM_SNP.DTGM.MORE_FRAG_FLAG = false ) -- then STATE_VECTOR.TOTAL_DATA_LENGTH := -- FROM_SNP.DTGM.FRAGMENT_OFFSET*8 + -- DATA_IN_FRAG; -- end if; -- -- Record the header of the "head-end" fragment. -- -- if ( FROM_SNP.DTGM.FRAGMENT_OFFSET = 0 ) -- then STATE_VECTOR.HEADER := FROM_SNP.DTGM; -- end if; -- -- Reset the reassembly timer if its current value is less -- than the time-to-live field of the received datagram. -- -- if ( STATE_VECTOR.TIMER < FROM_SNP.DTGM.TIME_TO_LIVE ) -- then STATE_VECTOR.TIMER := MAXIMUM -- (FROM_SNP.DTGM.TIME_TO_LIVE, STATE_VECTOR.TIMER ); -- -- Mandatory Requirements -- a.) IP module must have the capacity to receive a -- datagram of 576 octets in length(either in one piece -- or in fragments). -- b.) if (FROM_SNP.DTGM.FRAGMENT_OFFSET = 0 ) then -- fragment header becomes the header of the -- reassembling datagram -- c.) The total length of the reassembling datagram is calculated -- from the fragment with FROM_SNP.DTGM.MORE_FRAG_FLAG -- equal to zero(i.e., the "tail-end" fragment ). -- d.) A reassembly timer is associated with each datagram -- being reassembled. The current recommendation for the -- initial timer setting is 15 seconds. Note that the choice -- of this parameter value is related to the buffer capacity -- available and the data rate of the transmission medium. -- e.) As each fragment arrives, the reassembly timer is reset -- to: STATE_VECTOR.TIMER := MAXIMUM -- (FROM_SNP.DTGM.TIME_TO_LIVE, STATE_VECTOR.TIMER ); -- -- f.) The first fragment of the datagram being reassembled must -- contain all options, except padding and no-op octets. -- g.) The SOURCE_ADDR, DESTINATION_ADDR, PROTOCOL, and IDENTIFIER -- of the first fragment received must be recorded. All -- subsequent fragments' SOURCE_ADDR, DESTINATION_ADDR, -- PROTOCOL, and IDENTIFIER will be compared against those -- recorded. -- h.) As each fragment arrives, the security and precedence -- fields, if available, must be checked. If the security -- level of the fragment does not match the security level -- of datagram or if the precedence level of the fragment -- does not match the precedence level of the datagram, the -- datagram being assembled is discarded. Also, an error -- datagram is returned to the source IP to report the -- "mismatched security/precedence" error. -- i.) If the reassembly timer expires, the datagram being -- reassembled is discarded. Also, an error datagram is -- returned to the source IP to report the "time exceeded -- during reassembly" error. --****************** --* USER Semantics * --****************** --This subprogram transforms a datagram that has been reassembled in the --state vector into interface parameters and data, then delivers them to a --ULP. procedure REASSEMBLED_DELIVERY ( PACKED_BUFFER : in BUFFER_DATA.PACKED_BUFFER_PTR ); --************************** --* PACKAGE BODY Semantics * --************************** -- Data examined: -- -- STATE_VECTOR.HEADER.DESTINATION_ADDR -- STATE_VECTOR.HEADER.SOURCE_ADDR -- STATE_VECTOR.HEADER.PROTOCOL -- STATE_VECTOR.HEADER.TYPE_OF_SERVICE -- STATE_VECTOR.HEADER.HEADER_LENGTH -- STATE_VECTOR.HEADER.TOTAL_LENGTH -- STATE_VECTOR.HEADER.OPTIONS -- STATE_VECTOR.DATA -- -- Data modified: -- -- TO_ULP.DESTINATION_ADDR TO_ULP.LENGTH -- TO_ULP.SOURCE_ADDR TO_ULP.DATA -- TO_ULP.PROTOCOL TO_ULP.OPTIONS -- TO_ULP.TYPE_OF_SERVICE -- -- TO_ULP.DESTINATION_ADDR := STATE_VECTOR.HEADER.DESTINATION_ADDR; -- TO_ULP.SOURCE_ADDR := STATE_VECTOR.HEADER.SOURCE_ADDR; -- TO_ULP.PROTOCOL := STATE_VECTOR.HEADER.PROTOCOL; -- TO_ULP.TYPE_OF_SERVICE := STATE_VECTOR.HEADER.TYPE_OF_SERVICE; -- TO_ULP.LENGTH := STATE_VECTOR.HEADER.TOTAL_LENGTH - -- STATE_VECTOR.HEADER.HEADER_LENGTH * 4; -- TO_ULP.OPTIONS := STATE_VECTOR.HEADER.OPTIONS; -- TO_ULP.DATA := STATE_VECTOR.DATA; --****************** --* USER Semantics * --****************** --This subprogram decomposes a datagram arriving from a remote IP into --interface parameters and data and delivers them to the destination ULP. procedure REMOTE_DELIVERY ( PACKED_BUFFER : in BUFFER_DATA.PACKED_BUFFER_PTR ); --************************** --* PACKAGE BODY Semantics * --************************** -- -- Data examined: -- FROM_SNP.DTGM.SOURCE_ADDR -- FROM_SNP.DTGM.DESTINATION_ADDR -- FROM_SNP.DTGM.PROTOCOL -- FROM_SNP.DTGM.TYPE_OF_SERVICE -- FROM_SNP.DTGM.TOTAL_LENGTH -- FROM_SNP.DTGM.HEADER_LENGTH -- FROM_SNP.DTGM.DATA -- FROM_SNP.DTGM.OPTIONS -- -- Data modified: -- TO_ULP.DESTINATION_ADDR TO_ULP.LENGTH -- TO_ULP.SOURCE_ADDR TO_ULP.DATA -- TO_ULP.PROTOCOL TO_ULP.OPTIONS -- TO_ULP.TYPE_OF_SERVICE -- -- TO_ULP.DESTINATION_ADDR := FROM_SNP.DTGM.DESTINATION_ADDR; -- TO_ULP.SOURCE_ADDR := FROM_SNP.DTGM.SOURCE_ADDR; -- TO_ULP.PROTOCOL := FROM_SNP.DTGM.PROTOCOL; -- TO_ULP.TYPE_OF_SERVICE := FROM_SNP.DTGM.TYPE_OF_SERVICE; -- TO_ULP.LENGTH := FROM_SNP.DTGM.TOTAL_LENGTH - -- FROM_SNP.DTGM.HEADER_LENGTH * 4; -- TO_ULP.DATA := FROM_SNP.DTGM.DATA; -- TO_ULP.OPTIONS := FROM_SNP.DTGM.OPTIONS; --************************** --* PACKAGE BODY SEMANTICS * --************************** --This procedure is invoked upon system intialization or recovery --to initialize the reassembly queue procedure INITIALIZE_REASSEMBLY_QUEUE; end REASSEMBLY_UTILITIES; with IP_UNPACK_AND_PACK_UTILITIES; with UNCHECKED_CONVERSION; with TEXT_IO; use TEXT_IO, INTEGER_IO ; with IP_GLOBALS; with UTILITIES_FOR_ICMP; package body REASSEMBLY_UTILITIES is --------------------------------------------------------- --This implementation is for the DEC/Ada compiler -- --------------------------------------------------------- FREE_LIST_REASSEMBLY_ELEMENTS : REASSEMBLY_TABLE_POINTER; TOP_OF_REASSEMBLY_TABLE_POINTER : REASSEMBLY_TABLE_POINTER; COUNTER_REASSEMBLY_ENTRIES : SIXTEEN_BITS range 0..20; TOP_OF_REASSEMBLY_FREE_LIST : REASSEMBLY_TABLE_POINTER; REASSEMBLY_FREE_LIST_ELEMENT_COUNT : SIXTEEN_BITS range 0..20; MAXIMUM_TABLE_SIZE : constant SIXTEEN_BITS := 20; procedure INITIALIZE_REASSEMBLY_QUEUE is --This procedure is invoked upon system intialization or recovery --to initialize the reassembly queue NEW_ELEMENT : REASSEMBLY_TABLE_POINTER; LIST_GENERATOR : REASSEMBLY_TABLE_POINTER; begin REASSEMBLY_FREE_LIST_ELEMENT_COUNT := 20; COUNTER_REASSEMBLY_ENTRIES := 0; TOP_OF_REASSEMBLY_TABLE_POINTER := null; TOP_OF_REASSEMBLY_FREE_LIST := new REASSEMBLY_TABLE_TYPE; TOP_OF_REASSEMBLY_FREE_LIST .PRIOR_ENTRY_REASSEMBLY_TABLE := null; TOP_OF_REASSEMBLY_FREE_LIST .NEXT_ENTRY_REASSEMBLY_TABLE := null; -- To be used durning FREE_LIST construction LIST_GENERATOR := TOP_OF_REASSEMBLY_FREE_LIST; -- Set up free queue list for I in 2..MAXIMUM_TABLE_SIZE loop NEW_ELEMENT := new REASSEMBLY_TABLE_TYPE; LIST_GENERATOR.NEXT_ENTRY_REASSEMBLY_TABLE := NEW_ELEMENT; NEW_ELEMENT.PRIOR_ENTRY_REASSEMBLY_TABLE := LIST_GENERATOR; NEW_ELEMENT.NEXT_ENTRY_REASSEMBLY_TABLE := null; LIST_GENERATOR := NEW_ELEMENT; end loop; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure INITIALIZE_REASSEMBLY_QUEUE "); when others => TEXT_IO.PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure INITIALIZE_REASSEMBLY_QUEUE "); end INITIALIZE_REASSEMBLY_QUEUE; function OBTAIN_TOP_OF_REASSEMBLY_TABLE return REASSEMBLY_TABLE_POINTER is begin return TOP_OF_REASSEMBLY_TABLE_POINTER; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure OBTAIN_TOP_OF_REASSEMBLY_TABLE "); when others => TEXT_IO.PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure OBTAIN_TOP_OF_REASSEMBLY_TABLE "); end OBTAIN_TOP_OF_REASSEMBLY_TABLE; procedure ADD_ENTRY_TO_REASSEMBLY_TABLE(NEW_DATAGRAM_FRAGMENT : REASSEMBLY_TABLE_POINTER; ERROR : out REASSEMBLY_ERROR_TYPE) is begin if COUNTER_REASSEMBLY_ENTRIES < 20 then ERROR := NO_ERROR; COUNTER_REASSEMBLY_ENTRIES := COUNTER_REASSEMBLY_ENTRIES + 1; NEW_DATAGRAM_FRAGMENT.PRIOR_ENTRY_REASSEMBLY_TABLE := null; NEW_DATAGRAM_FRAGMENT.NEXT_ENTRY_REASSEMBLY_TABLE := TOP_OF_REASSEMBLY_TABLE_POINTER; TOP_OF_REASSEMBLY_TABLE_POINTER := NEW_DATAGRAM_FRAGMENT; else -- reassembly resources full -- send ICMP message ERROR := NO_MORE_REASSEMBLY_BUFFER_SPACE; end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure ADD_ENTRY_TO_REASSEMBLY_TABLE "); when others => TEXT_IO.PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure ADD_ENTRY_TO_REASSEMBLY_TABLE "); end ADD_ENTRY_TO_REASSEMBLY_TABLE; procedure DELETE_ENTRY_FROM_REASSEMBLY_TABLE(DATAGRAM : in out REASSEMBLY_TABLE_POINTER) is procedure ADD_REASSEMBLY_ELEMENT_TO_FREE_LIST is begin REASSEMBLY_FREE_LIST_ELEMENT_COUNT := REASSEMBLY_FREE_LIST_ELEMENT_COUNT + 1; TOP_OF_REASSEMBLY_FREE_LIST.PRIOR_ENTRY_REASSEMBLY_TABLE := DATAGRAM; DATAGRAM.NEXT_ENTRY_REASSEMBLY_TABLE := TOP_OF_REASSEMBLY_FREE_LIST; TOP_OF_REASSEMBLY_FREE_LIST := DATAGRAM; TOP_OF_REASSEMBLY_FREE_LIST.PRIOR_ENTRY_REASSEMBLY_TABLE := null; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure ADD_REASSEMBLY_ELEMENT_TO_FREE_LIST "); when others => TEXT_IO.PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure ADD_REASSEMBLY_ELEMENT_TO_FREE_LIST "); end ADD_REASSEMBLY_ELEMENT_TO_FREE_LIST; begin COUNTER_REASSEMBLY_ENTRIES := COUNTER_REASSEMBLY_ENTRIES - 1; DATAGRAM.PRIOR_ENTRY_REASSEMBLY_TABLE.NEXT_ENTRY_REASSEMBLY_TABLE := DATAGRAM.NEXT_ENTRY_REASSEMBLY_TABLE; ADD_REASSEMBLY_ELEMENT_TO_FREE_LIST; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure DELETE_ENTRY_FROM_REASSEMBLY_TABLE "); when others => TEXT_IO.PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure DELETE_ENTRY_FROM_REASSEMBLY_TABLE "); end DELETE_ENTRY_FROM_REASSEMBLY_TABLE; procedure GET_REASSEMBLY_STRUCTURE( REASSEMBLY_STRUCTURE : in out REASSEMBLY_TABLE_POINTER; ERROR : out REASSEMBLY_ERROR_TYPE) is procedure DELETE_REASSEMBLY_STRUCTURE_FROM_FREE_LIST is begin if REASSEMBLY_FREE_LIST_ELEMENT_COUNT > 0 then ERROR := NO_ERROR; REASSEMBLY_FREE_LIST_ELEMENT_COUNT := REASSEMBLY_FREE_LIST_ELEMENT_COUNT -1; TOP_OF_REASSEMBLY_FREE_LIST := TOP_OF_REASSEMBLY_FREE_LIST.NEXT_ENTRY_REASSEMBLY_TABLE; TOP_OF_REASSEMBLY_FREE_LIST.PRIOR_ENTRY_REASSEMBLY_TABLE := null; else -- no more buffer space to perform reassembly -- send ICMP message ERROR := NO_MORE_FREE_BUFFER_SPACE; end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure DELETE_REASSEMBLY_STRUCTURE_FROM_FREE_LIST "); when others => TEXT_IO.PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure DELETE_REASSEMBLY_STRUCTURE_FROM_FREE_LIST "); end DELETE_REASSEMBLY_STRUCTURE_FROM_FREE_LIST; begin REASSEMBLY_STRUCTURE := TOP_OF_REASSEMBLY_FREE_LIST; DELETE_REASSEMBLY_STRUCTURE_FROM_FREE_LIST; REASSEMBLY_STRUCTURE.PRIOR_ENTRY_REASSEMBLY_TABLE := null; REASSEMBLY_STRUCTURE.NEXT_ENTRY_REASSEMBLY_TABLE := null; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure GET_REASSEMBLY_STRUCTURE "); when others => TEXT_IO.PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure GET_REASSEMBLY_STRUCTURE "); end GET_REASSEMBLY_STRUCTURE; function A_FRAG( PACKED_BUFFER : in BUFFER_DATA.PACKED_BUFFER_PTR; BUFPTR : in IP_GLOBALS.BUFFER_POINTER ) return YES_OR_NO is begin if (BUFPTR.FRAG_OFFSET = 0) and (BUFPTR.FLAGS = 2) then return NO; elsif (BUFPTR.FLAGS = 1) or (BUFPTR.FLAGS = 0) then return YES; else NEW_LINE; TEXT_IO.PUT("Flag error := "); INTEGER_IO.PUT(BUFPTR.FLAGS); NEW_LINE; TEXT_IO.PUT_LINE("function A_FRAG package REASSEMBLY_UTILITIES "); return NO; end if; end A_FRAG; function REASS_DONE ( REASSEMBLY_BUFFER : in REASSEMBLY_TABLE_POINTER; BUFPTR : IP_GLOBALS.BUFFER_POINTER ) return YES_OR_NO is begin if REASSEMBLY_BUFFER.TOTAL_DATA_LENGTH = 0 then -- check incoming datagram for "tail" if BUFPTR.FLAGS = 0 then REASSEMBLY_BUFFER.TOTAL_DATA_LENGTH := BUFPTR.FRAG_OFFSET + (BUFPTR.TOT_LEN - BUFPTR.IHL); for I in BUFPTR.FRAG_OFFSET..(BUFPTR.FRAG_OFFSET + (BUFPTR.TOT_LEN - BUFPTR.IHL)) loop REASSEMBLY_BUFFER.REASSEMBLY_MAP(I) := 1; end loop; for I in 1..REASSEMBLY_BUFFER.TOTAL_DATA_LENGTH loop if REASSEMBLY_BUFFER.REASSEMBLY_MAP(I) = 1 then null; else return NO; end if; end loop; return YES; else return NO; end if; else for I in 1..REASSEMBLY_BUFFER.TOTAL_DATA_LENGTH loop if REASSEMBLY_BUFFER.REASSEMBLY_MAP(I) = 1 then null; else return NO; end if; end loop; return YES; end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE(" CONSTRAINT_ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure REASS_DONE "); when others => TEXT_IO.PUT_LINE(" UNKNOWN ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure REASS_DONE "); end REASS_DONE; procedure REASSEMBLY_TIMEOUT ( REASSEMBLY_DATAGRAM_THAT_TIMED_OUT : in out REASSEMBLY_TABLE_POINTER; BUFPTR : in IP_GLOBALS.BUFFER_POINTER ) is type TELEGOOFUP is array(1..1) of SIXTEEN_BITS ; -- Currently necessary for -- implementation restriction type TWO_BYTE is array(1..2) of SYSTEM.BYTE; function CONVERT_TO_TWO_BYTES is new UNCHECKED_CONVERSION(TELEGOOFUP, TWO_BYTE); WORD_TO_CONVERT : TELEGOOFUP; TEMP : TWO_BYTE; ICMP_MESSAGE : BUFFER_DATA.PACKED_BUFFER_PTR; ICMP_BUFPTR : IP_GLOBALS.BUFFER_POINTER; ICMP_HEADER_POINTER : SIXTEEN_BITS range 20..60; IP_HEADER_POINTER : SIXTEEN_BITS := 0; IHL_IN_OCTETS : SIXTEEN_BITS range 20..60; BUFFER_TYPE : SIXTEEN_BITS := 0; begin BUFFER_DATA.BUFFGET(ICMP_MESSAGE,BUFFER_TYPE); if REASSEMBLY_DATAGRAM_THAT_TIMED_OUT.HAS_FRAGMENT_ZERO_ARRIVED = TRUE then ICMP_BUFPTR.VERSION := 4; ICMP_BUFPTR.IHL := 5; ICMP_BUFPTR.TOS := 0; ICMP_BUFPTR.ID := 0; -- Temporary; need to implement some type of ID gener --ation ICMP_BUFPTR.FLAGS := 2; -- MORE_FRAG_FLAG = FALSE AND DONT_FRAG_FLAG = FALSE ICMP_BUFPTR.FRAG_OFFSET := 0; ICMP_BUFPTR.TTL := 60; ICMP_BUFPTR.PROT := 1; ICMP_BUFPTR.SOURCE := BUFPTR.DEST; ICMP_BUFPTR.DEST := BUFPTR.SOURCE; -- IP_HEADER_POINTER := REASSEMBLY_DATAGRAM_THAT_TIMED_OUT.REASSEMBLY_DATAGRAM.IP_PTR; -- Convert IHL from 32-bit word size to 8-bit OCTETS IHL_IN_OCTETS := BUFPTR.IHL * 4; -- Calculate position of ICMP header ICMP_HEADER_POINTER := IP_HEADER_POINTER + IHL_IN_OCTETS; -- Load Time Exceeded Message Type ICMP_MESSAGE.BYTE(ICMP_HEADER_POINTER) := 11; -- Load code(fragment reassembly time exceeded) ICMP_MESSAGE.BYTE(ICMP_HEADER_POINTER + 1) := 1; -- Telesoft does not support packed aggregates for I in 0..5 loop ICMP_MESSAGE.BYTE(ICMP_HEADER_POINTER + 2 + SIXTEEN_BITS ( I ) ) := 0; end loop; -- load internet header and 64 bits of original datagram -- Telesoft does not support packed aggregates for I in 0..IHL_IN_OCTETS + 64 loop ICMP_MESSAGE.BYTE(ICMP_HEADER_POINTER + 8 + SIXTEEN_BITS ( I ) ) := REASSEMBLY_DATAGRAM_THAT_TIMED_OUT.REASSEMBLY_DATAGRAM.BYTE (ICMP_HEADER_POINTER + I); end loop; -- Calculate ICMP checksum WORD_TO_CONVERT(1) := UTILITIES_FOR_ICMP.ICMP_CHECKSUM (ICMP_HEADER_POINTER, (ICMP_HEADER_POINTER + ICMP_BUFPTR.TOT_LEN), ICMP_MESSAGE); TEMP := CONVERT_TO_TWO_BYTES(WORD_TO_CONVERT); ICMP_MESSAGE.BYTE(ICMP_HEADER_POINTER + 2) := TEMP(2); ICMP_MESSAGE.BYTE(ICMP_HEADER_POINTER + 3) := TEMP(1); IP_UNPACK_AND_PACK_UTILITIES.PACK_BUFFER_INTO_BIT_STREAM (ICMP_BUFPTR,ICMP_MESSAGE); -- Send ICMP message to subnet protocol UTILITIES_FOR_ICMP.SEND_ICMP_MESSAGE(ICMP_MESSAGE); -- release reassembly resoures DELETE_ENTRY_FROM_REASSEMBLY_TABLE(REASSEMBLY_DATAGRAM_THAT_TIMED_OUT); else -- no time exceeded message will be sent -- release reassembly resoures DELETE_ENTRY_FROM_REASSEMBLY_TABLE(REASSEMBLY_DATAGRAM_THAT_TIMED_OUT); end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE(" CONSTRAINT_ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure REASSEMBLY_TIMEOUT "); when others => TEXT_IO.PUT_LINE(" UNKNOWN ERROR in package REASSEMBLY_UTILITIES "); TEXT_IO.PUT_LINE("procedure REASSEMBLY_TIMEOUT "); end REASSEMBLY_TIMEOUT; procedure REASSEMBLY( PACKED_BUFFER : in out BUFFER_DATA.PACKED_BUFFER_PTR; REASSEMBLY_TABLE_ELEMENT : in out REASSEMBLY_TABLE_POINTER; BUFPTR : IP_GLOBALS.BUFFER_POINTER ) is INCOMING_DATAGRAM_BUFID : BUFID_TYPE; DATA_IN_FRAG : SIXTEEN_BITS := 0; ERROR : REASSEMBLY_ERROR_TYPE := NO_ERROR; BUFFER_TYPE : SIXTEEN_BITS := 0; procedure STUFF_DATA_FROM_FRAGMENT is begin for I in 0..DATA_IN_FRAG loop REASSEMBLY_TABLE_ELEMENT.DATA(BUFPTR.FRAG_OFFSET + I + 1) := PACKED_BUFFER.BYTE(PACKED_BUFFER.IP_PTR + (BUFPTR.IHL * 4) + I); end loop; exception when CONSTRAINT_ERROR => NEW_LINE; TEXT_IO.PUT( "CONSTRAINT ERROR procedure STUFF_DATA_FROM_FRAGMENT"); NEW_LINE; TEXT_IO.PUT("package REASSEMBLY UTILITIES"); end STUFF_DATA_FROM_FRAGMENT; procedure SET_BIT_MAP is begin for I in 0..DATA_IN_FRAG loop REASSEMBLY_TABLE_ELEMENT.REASSEMBLY_MAP(BUFPTR.FRAG_OFFSET + I + 1) := 1; end loop; exception when CONSTRAINT_ERROR => NEW_LINE; TEXT_IO.PUT("CONSTRAINT ERROR procedure SET_BIT_MAP "); NEW_LINE; TEXT_IO.PUT("package REASSEMBLY UTILITIES"); end SET_BIT_MAP; begin DATA_IN_FRAG := BUFPTR.TOT_LEN - BUFPTR.IHL * 4; INCOMING_DATAGRAM_BUFID := (BUFPTR.SOURCE,BUFPTR.DEST,BUFPTR.PROT,BUFPTR.ID); REASSEMBLY_TABLE_ELEMENT := TOP_OF_REASSEMBLY_TABLE_POINTER; --REMOVE NEW_LINE; TEXT_IO.PUT("WE ARE REASSEMBLY"); NEW_LINE; --REMOVE while not(REASSEMBLY_TABLE_ELEMENT = null) and then not(REASSEMBLY_TABLE_ELEMENT.BUFID = INCOMING_DATAGRAM_BUFID) loop REASSEMBLY_TABLE_ELEMENT := REASSEMBLY_TABLE_ELEMENT.NEXT_ENTRY_REASSEMBLY_TABLE; end loop; if (REASSEMBLY_TABLE_ELEMENT /= null) and (BUFPTR.TTL > 0) then -- store data STUFF_DATA_FROM_FRAGMENT; -- set bitmap SET_BIT_MAP; if not(REASSEMBLY_TABLE_ELEMENT.HAS_FRAGMENT_ZERO_ARRIVED) then -- here's the tail REASSEMBLY_TABLE_ELEMENT.TOTAL_DATA_LENGTH := BUFPTR.FRAG_OFFSET + (BUFPTR.TOT_LEN - BUFPTR.IHL); REASSEMBLY_TABLE_ELEMENT.HAS_FRAGMENT_ZERO_ARRIVED := TRUE; REASSEMBLY_TABLE_ELEMENT.HEADER := IP_UNPACK_AND_PACK_UTILITIES.UNPACK(PACKED_BUFFER); end if; -- reset reassembly timer if its current value is less -- than the time-to-live field of the recieved datagram if REASSEMBLY_TABLE_ELEMENT.TIMER < BUFPTR.TTL then REASSEMBLY_TABLE_ELEMENT.TIMER := 15; end if; elsif (REASSEMBLY_TABLE_ELEMENT = null) and (BUFPTR.TTL > 0) then -- fragment is a new fragmented datagram -- obtain fragment buffer GET_REASSEMBLY_STRUCTURE(REASSEMBLY_TABLE_ELEMENT,ERROR); if ERROR = NO_ERROR then REASSEMBLY_TABLE_ELEMENT.STATE_NAME := INACTIVE; REASSEMBLY_TABLE_ELEMENT.BUFID := INCOMING_DATAGRAM_BUFID; -- store data STUFF_DATA_FROM_FRAGMENT; -- set bitmap SET_BIT_MAP; elsif (ERROR = NO_MORE_FREE_BUFFER_SPACE) then -- send ICMP message null; else -- we should never get here!!! null; end if; elsif (REASSEMBLY_TABLE_ELEMENT /= null) and not(BUFPTR.TTL > 0) then REASSEMBLY_TIMEOUT(REASSEMBLY_TABLE_ELEMENT,BUFPTR); BUFFER_DATA.BUFFREE(PACKED_BUFFER,BUFFER_TYPE); DELETE_ENTRY_FROM_REASSEMBLY_TABLE(REASSEMBLY_TABLE_ELEMENT); else -- should never get here null; end if; end REASSEMBLY; procedure REASSEMBLED_DELIVERY ( PACKED_BUFFER : in BUFFER_DATA.PACKED_BUFFER_PTR ) is begin null; end REASSEMBLED_DELIVERY; procedure REMOTE_DELIVERY ( PACKED_BUFFER : in BUFFER_DATA.PACKED_BUFFER_PTR ) is begin null; end REMOTE_DELIVERY; end REASSEMBLY_UTILITIES; --:::::::::::::: --rtc.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01188-100(-) -- E-Systems, Inc. August 07, 1985 -- -- rtc.txt Author : Jim Baldo -- ----------------------------------------------------------------------- (*ada dummy*) (*asm68 body*) * ADA SPECIFICATION -- Dummy Ada Specifiction for assembly language body package T_REAL_TIME_CLOCK is procedure START; procedure STOP; procedure READ(TICKS : out LONG_INTEGER); end T_REAL_TIME_CLOCK; * ADA DUMMY BODY package body T_REAL_TIME_CLOCK is procedure START is begin null; end START; procedure STOP is begin null; end STOP; procedure READ(TICKS : out LONG_INTEGER) is begin null; end READ; end T_REAL_TIME_CLOCK; -- Real Time Clock * ASM68 BODY .asection REAL_TIME_CLOCK .run_relocate ;.INCLUDE MOD:A68/MACLIB ; STARTCOD ; SETSTKSPACE 24 ; MS1HIGH: .EQU 3 ; 1 MSEC VALUE (HIGH BYTE) MS1LOW: .EQU 32. ; 1MSEC VALUE (LOW BYTE); T1CNTLOW: .EQU 0F00048 ; TIMER1 COUNTER REG (LOW BYTE) T1CNTHIGH: .EQU 0F0004A ; TIMER1 COUNTER REG (HIGH BYTE) T1LATCHLOW: .EQU 0F0004C ; TIMER1 LATCH REG (LOW BYTE) T1LATCHHIGH: .EQU 000004e ; TIMER1 LATCH REG (HIGH BYTE) AUXREG: .EQU 0F00056 ; AUXILLIARY CONTROL REG INTENABLE: .EQU 0F0005C ; INTERRUPT ENABLE REG LEVEL1: .EQU 64 ; LEVEL 1 INTERRUPT VECTOR ADDR (TIMER)D ; ; procedure START; ; START: MOVEM.L D0/A6,-(SP) ; SAVE REGS BSR STOPCLK ; IF RUNNING THEN STOP IT LEA RUNNING,A6 ; MOVE.B #1,(A6) ; NOW SET RUNNING FLAG MOVE.B #40,INTENABLE.L ; DISABLE INTERRUPTS LEA VECTORSAVE,A6 ; POINT TO SAVE AREA MOVE.L LEVEL1,(A6) ; SAVE PREVIOIUS INTERRUPT VECTOR LEA ISS,A6 ; POINT A6 TO OUR ROUTINE MOVE.L A6,LEVEL1 ; REPLACE INTERRUPT VECTOR LEA COUNT,A6 ;START CLOCK WITH ZERO CLR.L (A6) ; SET THE INTERVAL - NOW USE 1MSEC MOVEQ #MS1LOW,D0 ; FETCH COUNT 'INTERVAL' MOVE.B D0,T1CNTLOW.L ; INIT LOW COUNTER & LATCH MOVE.B D0,T1LATCHLOW.L MOVEQ #MS1HIGH,D0 ; GET HIGH BYTE MOVE.B D0,T1CNTHIGH.L ; INIT HIGH BYTES MOVE.B D0,T1LATCHHIGH.L MOVE.B #40,AUXREG.L ; SET TIMER FOR CONTINUOUS MODE MOVE.B #0C0,INTENABLE.L; ENABLE INTERRUPTS MOVEM.L (SP)+,D0/A6 ; RESTORE REGS RTS ; ; procedure STOP ; STOPCLK: MOVE.L A6,-(SP) ; SAVE REGS LEA RUNNING,A6 ; SEE IF ALREADY RUNNING TST.B (A6) BEQ.B STOPCLK90 ; GO ON IF NOT CLR.B (A6) ; SHUT OFF RUNNING MOVE.B #40,INTENABLE.L ; DISABLE INTERRUPTS MOVE.L VECTORSAVE,LEVEL1; RESTORE VECTOR STOPCLK90: MOVEA.L (SP)+,A6 ; RESTORE VECTOR RTS ; ; procedure READ(TICKS : out LONG_INTEGER); -- CALL FROM ADA ; READ: MOVE.L A6,-(SP) ; SAVE REGS MOVEA.L 08(SP),A6 ; GET ADDRESS OF 'TICKS' MOVE.L COUNT,(A6) ; GET ROOL-OVER COUNT MOVEA.L (SP)+,A6 ; RESTORE REGS MOVE.L (SP)+,(SP) ; MOVE RETURN ADDRESS (TRASH PARAMETER) RTS ; ; CLOCK INTERRUPT SERVICE SUBROUTINE ; ISS: MOVE.L A6,-(SP) LEA COUNT,A6 ADDQ.L #1,(A6) ; UPDATE ROLL OVER COUNT TST.B T1CNTLOW.L ; CLEAR INTERRUPT MOVEA.L (SP)+,A6 ; AND EXIT RTE ; ; DATA AREA ; VECTORSAVE: .LONG 0 ; AREA TO SAVE LEVEL1 VECTOR COUNT: .LONG 0 ; ROLLOVER COUNTER RUNNING: .BYTE 0 ; RUNNING FLAG .ALIGN 2 CODINIT CODTERM BSR STOPCLK ; STOP EVERYTHING CODENDTERM PROCBRANCH READ PROCBRANCH STOPCLK PROCBRANCH START CODWRAPUP .END --:::::::::::::: --segarrive.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01189-100(-) -- E-Systems, Inc. August 07, 1985 -- -- segarrive.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with BUFFER_DATA; use BUFFER_DATA; --with T_TCP_GLOBALS_DATA_STRUCTURES; use T_TCP_GLOBALS_DATA_STRUCTURES; package TCP_SEGMENT_ARRIVES_PROCESSING is ------------------------------------------------------------- --This implementation is for use with the DEC/Ada -- --compiler . -- ------------------------------------------------------------- ------------------------------------------------------------------------------- -- THIS PACKAGE CONTAINS ALL THE PROCEDURES AND FUNCTIONS NECESSARY FOR -- -- PROCESSING ARRIVED SEGMENTS. IT ALSO CONTAINS THE HEADER FORMAT ROUTINE. -- ------------------------------------------------------------------------------- procedure TCP_SEG_ARRIVE( PACKED_BUFFER : in out PACKED_BUFFER_PTR; BYTE_COUNT : in SIXTEEN_BITS ; SOURCE_FROM_IP, DEST : in THIRTYTWO_BITS ; PROT, TOS_IP : in SIXTEEN_BITS ; SECURITY_OP : in SECURITY_OPTION_TYPE); --This procedure will take a segment and determine what LCN, if any it --belongs to. It will check if it is a valid segment in terms of --sequence number and if the checksum is valid. It will also determine --that the address is for us. If so it will cause the required --processing for the state to be done, by calling the proper routine. end TCP_SEGMENT_ARRIVES_PROCESSING; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; with WITH_ULP_COMMUNICATE; use WITH_ULP_COMMUNICATE; with T_TCP_GLOBALS_DATA_STRUCTURES; use T_TCP_GLOBALS_DATA_STRUCTURES; with QUEUES; use QUEUES; with TCP_GLOBALS; use TCP_GLOBALS; with IP_GLOBALS ; use IP_GLOBALS ; with TEXT_IO; use TEXT_IO, INTEGER_IO; with TCP_ARRIVES_PERIPHERALS; use TCP_ARRIVES_PERIPHERALS; with MODULO; use MODULO; with TCB_ALLOCATOR; use TCB_ALLOCATOR; WITH TCP_SEG_ARRIVE ; USE TCP_SEG_ARRIVE ; with T_TCP_ARRIVES_1; use T_TCP_ARRIVES_1; package body TCP_SEGMENT_ARRIVES_PROCESSING is PROCEDURE TCP_SEG_ARRIVE(PACKED_BUFFER : in out PACKED_BUFFER_PTR; BYTE_COUNT : in SIXTEEN_BITS ; SOURCE_FROM_IP, DEST : in THIRTYTWO_BITS ; PROT, TOS_IP : in SIXTEEN_BITS ; SECURITY_OP : in SECURITY_OPTION_TYPE) is --This procedure is called by the TCP controller when it gets an --arrived segment. Here the appropriate processor is called. LCN_LIST : TCB_PTR; TCP_LENGTH, BUFFTYPE : SIXTEEN_BITS ; NOT_VALID_ADDRESS : BOOLEAN := TRUE; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; PROCEDURE SEQUENCE_NUMBER_CHECKER( LCN : in TCB_PTR; BUFPTR : in T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; RESULT : in out RES; TCP_LENGTH : in out SIXTEEN_BITS ) is DATA_LENGTH : SIXTEEN_BITS ; begin DATA_LENGTH := TCP_LENGTH - BUFPTR.DATA_OFFSET * 4; if LCN.RCV_WINDOW > 0 then if BUFPTR.SEQ_NUM = LCN.RCV_NXT then if BUFPTR.SEQ_NUM + DATA_LENGTH <= LCN.RCV_NXT + LCN.RCV_WINDOW then RESULT := GOOD; else RESULT := GOOD; DATA_LENGTH := LCN.RCV_WINDOW; TCP_LENGTH := DATA_LENGTH + BUFPTR.DATA_OFFSET * 4; end if; elsif (BUFPTR.SEQ_NUM < LCN.RCV_NXT) and BUFPTR.SEQ_NUM + DATA_LENGTH > LCN.RCV_NXT then -- IT'S PARTLY IN THE WINDOW. THIS SHOULD NOT CURRENTLY HAPPEN! TCP_ERROR(6); RESULT := BAD; elsif BUFPTR.SEQ_NUM < LCN.RCV_NXT + LCN.RCV_WINDOW then -- SOME OF IT IS IN THE WINDOW IT JUST DOES NOT START IN THE WINDOW. -- WE CURRENTLY IGNORE THIS. RESULT := BAD; else RESULT := BAD; end if; elsif TCP_LENGTH = BUFPTR.DATA_OFFSET * 4 then -- A ZERO LENGTH SEGMENT PROBABLY AN ACK. RESULT := GOOD; else -- A SEGMENT WITH DATA ON AN EMPTY WINDOW. RESULT := BAD; end if; end SEQUENCE_NUMBER_CHECKER; procedure SEND_ACK_OF_UNACCEPTABLE_SEGMENT is RESULT : WITH_IP_COMMUNICATE.RESULT_TYPE; MESSAGE_FOR_IP : WITH_IP_COMMUNICATE.IP_MESSAGE ; begin -- WE WILL SEND OUT AN ACK IN THE SAME PACKED BUFFER IT ARRIVED IN. OPTIONS := CLEAR; TCP_HEADER_FORMAT(LCN, BUFPTR, ACK, OPTIONS); -- REUSE THE BUFFER. SO WE MUST RESET ITS POINTER. PACKED_BUFFER.TCP_PTR := 255; -- ZERO OUT THE DATA LENGTH OF THE BUFFER. BUFPTR.DATA_LEN := 0; PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFFER); OPTIONS := TCP_SECURITY_OPTIONS; SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFFER, BUFPTR.DATA_OFFSET * 4, IDENT, DONT_FRAGMENT, OPTIONS, RESULT); -- NO UPDATE OF THE SEQUENCE NUMBER TCP_ERROR(13);-- NOTE AN INVALID SEQUENCE NUMBER ARRIVED end SEND_ACK_OF_UNACCEPTABLE_SEGMENT; begin -- UNPACK THE BUFFER BUFPTR := TCP_ARRIVES_PERIPHERALS.UNPACK(PACKED_BUFFER, BYTE_COUNT); -- NEEDS THE DATA COUNT. -- DETERMINE WHETHER CHECKSUM IS VALID. IF BUFPTR.TCP_CSUM /= CHECKSUM(BYTE_COUNT, PACKED_BUFFER, DEST, SOURCE_FROM_IP, PROT) THEN -- RELEASE BUFFER PUT_LINE("BAD CHECKSUM IN SEGARIV");---DEBUG TEXT_IO.LONG_INTEGER_IO.PUT(SOURCE_FROM_IP); PUT_LINE(""); -- WHY 128 LOST ON ABORT. TEXT_IO.INTEGER_IO.PUT(BUFPTR.TCP_CSUM); TEXT_IO.INTEGER_IO.PUT( CHECKSUM(BYTE_COUNT, PACKED_BUFFER, DEST, SOURCE_FROM_IP, PROT));---DEBUG PUT_LINE("POINTER AND BYTE COUNT"); TEXT_IO.INTEGER_IO.PUT(PACKED_BUFFER.TCP_PTR); TEXT_IO.INTEGER_IO.PUT(BYTE_COUNT); TCP_ERROR(15); BUFFREE(PACKED_BUFFER, BUFFTYPE); ELSE -- SET UP THE GLOBAL PSEUDO HEADER FOR I IN 1..9 LOOP SECURITY(I) := SECURITY_OP ( SIXTEEN_BITS ( I ) ) ; END LOOP; IP_TOS := TOS_IP; SOURCE := SOURCE_FROM_IP; DESTINATION := DEST; -- MATCH UP SEGMENT WITH A LCN (HENCE A TCB) LCN_LIST := OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; while LCN_LIST /= null loop -- CHECK FOR A VALID SOCKET. if LCN_LIST.SOURCE_ADDRESS = DEST and (BUFPTR.DESTINATION_PORT = LCN_LIST.LOCAL_PORT) then LCN := LCN_LIST; -- SET GLOBAL LCN NOT_VALID_ADDRESS := FALSE; exit; else --obtain next LCN LCN_LIST := LCN_LIST.NEXT; end if; end loop; -- DETERMINE IF THE FOREIGN PORT AND SOURCE ARE THE ONE FOR THE OBSERVED LCN if LCN /= null then IF LCN.STATE /= T_TCP_GLOBALS_DATA_STRUCTURES.CLOSED AND (LCN.STATE /= T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN) THEN IF LCN.DESTINATION_ADDRESS /= SOURCE_FROM_IP OR (LCN.FOREIGN_PORT /= BUFPTR.SOURCE_PORT) THEN NOT_VALID_ADDRESS := TRUE; END IF; END IF; end if; if NOT_VALID_ADDRESS then -- NOT FOR US -- RELEASE BUFFER PUT_LINE("GOT A PACKET NOT FOR US IN SEGARIV"); --TCP_ERROR(16); PACKED_BUFFER.IN_USE := FALSE; PACKED_BUFFER.STATUS := NONE; BUFFREE(PACKED_BUFFER, BUFFTYPE); else -- RESTART THE CONNECTION TIMEOUT TIMER. START_TIMER(LCN, TIMEOUT_TIMER); -- SET UP GLOBAL BUFFER POINTER FOR DELETE PRIVLEDGE IN ALL ROUTINES TCP_ARRIVES_PERIPHERALS.GLOBAL_PACKED_BUFFER := PACKED_BUFFER; -- PUT DATA LENGTH IN THE BUFFER BUFPTR.DATA_LEN := BYTE_COUNT - BUFPTR.DATA_OFFSET * 4; TCP_LENGTH := BYTE_COUNT; -- THE LENGTH OF SEGMENT AND DATA case LCN.STATE is when CLOSED => SEG_ARRIVED_IN_CLOSED_STATE( BUFPTR, BYTE_COUNT, SOURCE_FROM_IP, DEST); when T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN => SEG_ARRIVED_IN_LISTEN_STATE( BUFPTR, BYTE_COUNT, SOURCE_FROM_IP); when SYN_SENT => SEG_ARRIVED_IN_SYN_SENT_STATE( BUFPTR, BYTE_COUNT); when SYN_RECEIVED => SEQUENCE_NUMBER_CHECKER( LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); if TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD then SEG_ARRIVED_IN_SYN_RECEIVED_STATE( BUFPTR, TCP_LENGTH); else SEND_ACK_OF_UNACCEPTABLE_SEGMENT; end if; when ESTABLISHED => SEQUENCE_NUMBER_CHECKER( LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); if TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD then SEG_ARRIVED_IN_ESTABLISHED_STATE( BUFPTR, TCP_LENGTH); else SEND_ACK_OF_UNACCEPTABLE_SEGMENT; end if; WHEN FIN_WAIT_1 => SEQUENCE_NUMBER_CHECKER( LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); IF TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD THEN SEG_ARRIVED_IN_FIN_WAIT_1_STATE(BUFPTR, TCP_LENGTH); ELSE SEND_ACK_OF_UNACCEPTABLE_SEGMENT; END IF; WHEN FIN_WAIT_2 => SEQUENCE_NUMBER_CHECKER (LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); IF TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD THEN SEG_ARRIVED_IN_FIN_WAIT_2_STATE(BUFPTR, TCP_LENGTH); ELSE SEND_ACK_OF_UNACCEPTABLE_SEGMENT; END IF; WHEN CLOSE_WAIT => SEQUENCE_NUMBER_CHECKER (LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); IF TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD THEN SEG_ARRIVED_IN_CLOSE_WAIT_STATE(BUFPTR, TCP_LENGTH); ELSE SEND_ACK_OF_UNACCEPTABLE_SEGMENT; END IF; when CLOSING => SEQUENCE_NUMBER_CHECKER( LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); if TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD then SEG_ARRIVED_IN_CLOSING_STATE( BUFPTR, TCP_LENGTH); else SEND_ACK_OF_UNACCEPTABLE_SEGMENT; end if; when LAST_ACK => SEQUENCE_NUMBER_CHECKER( LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); if TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD then SEG_ARRIVED_IN_LAST_ACK_STATE( BUFPTR, TCP_LENGTH); else SEND_ACK_OF_UNACCEPTABLE_SEGMENT; end if; when TIME_WAIT => SEQUENCE_NUMBER_CHECKER( LCN, BUFPTR, TCP_ARRIVES_PERIPHERALS.RESULTS, TCP_LENGTH); if TCP_ARRIVES_PERIPHERALS.RESULTS = T_TCP_ARRIVES_1.GOOD then SEG_ARRIVED_IN_TIME_WAIT_STATE( BUFPTR, TCP_LENGTH); else if BUFPTR.SEQ_NUM < LCN.RCV_NXT and BUFPTR.FIN = BIT_SET then -- RESTART THE TIMEOUT TIMER SINCE AN OLD FIN CAME -- IN START_TIMER(LCN, TIMEOUT_TIMER); end if; SEND_ACK_OF_UNACCEPTABLE_SEGMENT; end if; end case; end if; end if; EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR OCCURRED IN SEGARIV PACKAGE"); WHEN OTHERS => PUT_LINE("PROBLEM IN SEGARIV"); END TCP_SEG_ARRIVE; END TCP_SEGMENT_ARRIVES_PROCESSING; --:::::::::::::: --segarrive1.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01190-100(-) -- E-Systems, Inc. August 07, 1985 -- -- segarrive1.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with T_TCP_GLOBALS_DATA_STRUCTURES; use T_TCP_GLOBALS_DATA_STRUCTURES; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with BUFFER_DATA; use BUFFER_DATA; package TCP_SEG_ARRIVE is ------------------------------------------------------------- --This implementation is for use with the Telesoft/Ada -- --compiler . -- ------------------------------------------------------------- ------------------------------------------------------------------------------- -- THIS PACKAGE CONTAINS ALL THE PROCEDURES AND FUNCTIONS NECESSARY FOR -- -- PROCESSING ARRIVED SEGMENTS. IT ALSO CONTAINS THE HEADER FORMAT ROUTINE. -- ------------------------------------------------------------------------------- procedure SEG_ARRIVED_IN_CLOSED_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES. BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ; SOURCE, DESTINATION : in THIRTYTWO_BITS ); procedure SEG_ARRIVED_IN_LISTEN_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES. BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ; SOURCE : in THIRTYTWO_BITS ) ; procedure SEG_ARRIVED_IN_SYN_SENT_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; procedure SEG_ARRIVED_IN_SYN_RECEIVED_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; PROCEDURE SEG_ARRIVED_IN_ESTABLISHED_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; PROCEDURE SEG_ARRIVED_IN_FIN_WAIT_1_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; procedure SEG_ARRIVED_IN_FIN_WAIT_2_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; procedure SEG_ARRIVED_IN_CLOSE_WAIT_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; procedure SEG_ARRIVED_IN_CLOSING_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; PROCEDURE SEG_ARRIVED_IN_LAST_ACK_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; PROCEDURE SEG_ARRIVED_IN_TIME_WAIT_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) ; end TCP_SEG_ARRIVE; with T_TCP_ARRIVES_1; with TEXT_IO; use TEXT_IO; with QUEUES; use QUEUES; with TCP_GLOBALS; use TCP_GLOBALS; with IP_GLOBALS; use IP_GLOBALS; with WITH_ULP_COMMUNICATE; use WITH_ULP_COMMUNICATE; with TCB_ALLOCATOR; use TCB_ALLOCATOR; with TCP_ARRIVES_PERIPHERALS; use TCP_ARRIVES_PERIPHERALS; with MODULO; use MODULO; package body TCP_SEG_ARRIVE is procedure SEG_ARRIVED_IN_CLOSED_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES. BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ; SOURCE, DESTINATION : in THIRTYTWO_BITS ) is -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVED CONTROLLER WHEN A SEGMENT -- ARRIVES WITH NO CONNECTION AT ATTEMPT BY THE USER (I.E. THE CLOSED STATE). -- PROCESSING : -- -- THIS PROCEDURE WILL IGNORE A RESET FROM THE REMOTE HOST. IF THE SEGMENT -- IS NOT A RESET THEN A RESET WILL BE FORMED AND SENT TO THE REMOTE HOST. -- BUFFTYPE : SIXTEEN_BITS ; BEGIN IF BUFPTR.RST = BIT_SET THEN -- THE SEGMENT IS A RESET, IGNORE IT. -- RELEASE BUFFER GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); ELSE -- SEND A RESET -- USE THE SAME BUFFER -- SET UP THE RESERVE TCB (NUMBER 5) RESERVE.RCV_NXT := BUFPTR.ACK_NUM; RESERVE.SND_NXT := BUFPTR.SEQ_NUM; RESERVE.SOURCE_ADDRESS := DESTINATION; RESERVE.DESTINATION_ADDRESS := SOURCE; RESERVE.LOCAL_PORT := BUFPTR.DESTINATION_PORT; RESERVE.FOREIGN_PORT := BUFPTR.SOURCE_PORT; IF BUFPTR.ACK = BIT_SET THEN -- ACK BIT IS ON. -- SEND A RESET OF THE FORM <SEQ=SEG.ACK> <CTL=RST> RESERVE.SND_NXT := BUFPTR.ACK_NUM; SEND_A_RESET(RESERVE); ELSE -- SEND A RESET OF THE FORM <SEQ=0> <ACK=SEG.SEQ+SEG.LEN> <CTL=RST,ACK> RESERVE.SND_NXT := MODULAR_CONVERT(SIXTEEN_BITS(0)); RESERVE.RCV_NXT := BUFPTR.SEQ_NUM + BYTE_COUNT - (BUFPTR.DATA_OFFSET * 4); -- BYTE_COUNT IS OF DATA AND HEADER SEND_A_RESET_AND_ACK(RESERVE); END IF; END IF; END SEG_ARRIVED_IN_CLOSED_STATE; procedure SEG_ARRIVED_IN_LISTEN_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES. BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ; SOURCE : in THIRTYTWO_BITS ) is -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVE CONTROLLER WHEN A SEGMENT -- HAS ARRIVED WITH THE TCB IN THE LISTEN STATE. IT PERFORMS THE NECESSARY -- PROCESSING. BUFFTYPE : SIXTEEN_BITS ; Q_ITEM : STD_Q_ITEM; BEGIN IF BUFPTR.RST = 0 THEN -- RESET BIT NOT SET SO GO ON. IF BUFPTR.ACK = BIT_SET THEN -- SEND A RESET RESERVE := LCN; RESERVE.SND_NXT := BUFPTR.ACK_NUM; SEND_A_RESET(RESERVE); ELSIF BUFPTR.SYN = BIT_SET THEN IF LCN.SECURITY /= SECURITY OR LCN.PRECEDENCE /= IP_TOS/2**5 THEN -- SET UP THE TCB RESERVE := LCN; RESERVE.SND_NXT := BUFPTR.ACK_NUM; SEND_A_RESET(RESERVE); ELSE IF FOREIGN_SOCKET_UNSPECIFIED(LCN) THEN -- FILL IN REMOTE HOST PARAMETERS LCN.FOREIGN_PORT := BUFPTR.SOURCE_PORT; LCN.DESTINATION_ADDRESS := SOURCE; -- DECODE THE NET AND HOST ADDRESSES AND PUT THEM IN THE TCB ADDRESS_DECODER(SOURCE); END IF; IF LCN.DESTINATION_ADDRESS = SOURCE THEN -- IT MATCHES OUR -- UNSPECIFIED OR -- SPECIFIED LISTEN. -- START THE CONNECTION TIMEOUT TIMER START_TIMER(LCN, TIMEOUT_TIMER); LCN.RCV_NXT := BUFPTR.SEQ_NUM + MODULAR_CONVERT(SIXTEEN_BITS(1)); LCN.INIT_RCV_SEQ_NUM := BUFPTR.SEQ_NUM; LCN.SND_WND := BUFPTR.WINDOW; LCN.SND_WL1 := BUFPTR.SEQ_NUM; -- ACK NUMBER HERE IS MEANINGLESS. WE MIGHT ISS - 1 IN THERE. -- PUT ANY OTHER TEXT OR CONTROLS ON THE RECEIVE QUEUE FOR -- PROCESSING IN THE ESTABLISHED STATE. IF BYTE_COUNT > BUFPTR.DATA_OFFSET * 4 -- THEN DATA EXISTS. OR (BUFPTR.RST = BIT_SET) OR (BUFPTR.FIN = BIT_SET) THEN -- RESET FIELDS. BUFPTR.ACK := 0; BUFPTR.SYN := 0; Q_ITEM := (NULL_BUFFER, BUFPTR, BYTE_COUNT); QUEUE_ADD(TCP_RECEIVED_SEGMENT_QUEUE, LCN, Q_ITEM); -- QUEUE IT END IF; -- GET INITIAL SEND SEQUENCE NUMBER (ISS) LCN.ISS := MODULAR_CONVERT(ISS); LCN.SND_NXT := LCN.ISS; -- SET UP ACK SECTION OF WINDOWS. LCN.SND_WL2 := LCN.ISS; LCN.SND_UNA := LCN.SND_NXT; SEND_A_SYN_AND_ACK(LCN); --TEXT_IO.PUT_LINE("JUST SENT SEND_A_SYN_AND_ACK"); LCN.STATE := SYN_RECEIVED; ELSE -- THE SEGMENT IS NOT THE ONE WE WANT SO IGNOR IT?? TEXT_IO.PUT_LINE("TCP_ERROR 12 SEGARRIVE IN LISTEN STATE"); TCP_ERROR(12); END IF; END IF; END IF; END IF; -- RELEASE BUFFER GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); EXCEPTION WHEN OTHERS => PUT_LINE(" AN ERROR HAS OCCURRED IN THE LISTEN STATE"); end SEG_ARRIVED_IN_LISTEN_STATE; procedure SEG_ARRIVED_IN_SYN_SENT_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is --THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVED CONTROLLER WHEN A --SEGMENT ARRIVES IN THE SYN_SENT STATE. IT PROCESSES ACCORDING TO --THE SPEC. -- -- PROCESSING : -- --THIS PROCEDURE IS RESPONSIBLE FOR THE PROCESSING OF A SEGMENT IN --THE SYN_SENT STATE ACCORDING TO THE TCP SPECIFICATION. BUFFTYPE : SIXTEEN_BITS ; UMESSAGE : USER_MESSAGE; NULL_Q_ITEM : STD_Q_ITEM := (NULL, NULL_UNPACKED_BUFFER, 0); Q_ITEM : STD_Q_ITEM; SOCKET_PARAMS : TCB_PTR; begin if BUFPTR.ACK = BIT_SET and then ((BUFPTR.ACK_NUM <= LCN.ISS) OR (BUFPTR.ACK_NUM > LCN.SND_NXT)) then LCN.SND_NXT := BUFPTR.ACK_NUM; -- new_line;--for debug(JB 2/17/85) -- put_line("SEND_A_RESET"); -- new_line; SEND_A_RESET(LCN); elsif BUFPTR.RST = BIT_SET then -- new_line;--for debug(JB 2/17/85) -- put_line("BUFPTR.RST = BIT_SET"); -- new_line; if BUFPTR.ACK = BIT_SET then -- TELL USER -- ERROR: CONNECTION RESET SOCKET_PARAMS := LCN; UMESSAGE := ( 6, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); -- MAY HAVE TO ZERO TCB LCN.STATE := CLOSED; TCB_CLEAR(LCN); end if; elsif LCN.SECURITY /= SECURITY then -- SEND A RESET if BUFPTR.ACK = BIT_SET then -- USE RESERVE TCB FOR VALUES OF RESET TO BE SENT RESERVE := LCN; RESERVE.SND_NXT := BUFPTR.ACK_NUM; SEND_A_RESET(RESERVE); else -- USE RESERVE TCB FOR VALUES OF RESET TO BE SENT RESERVE := LCN; RESERVE.SND_NXT := MODULAR_CONVERT(SIXTEEN_BITS(0)); RESERVE.RCV_NXT := BUFPTR.SEQ_NUM + BYTE_COUNT - (BUFPTR.DATA_OFFSET * 4); SEND_A_RESET_AND_ACK(RESERVE); end if; elsif LCN.PRECEDENCE /= IP_TOS/2**5 then -- new_line;--for debug(JB 2/17/85) -- put_line("PRECEDENCE"); -- new_line; if BUFPTR.ACK = BIT_SET then -- USE RESERVE TCB FOR VALUES OF RESET TO BE SENT RESERVE := LCN; RESERVE.SND_NXT := BUFPTR.ACK_NUM; SEND_A_RESET(RESERVE); elsif IP_TOS/2**5 > LCN.PRECEDENCE then -- HERE WE COULD RAISE THE TCB PRECEDENCE BUT WE WILL NOT CURRENTLY -- USE RESERVE TCB FOR VALUES OF RESET TO BE SENT RESERVE := LCN; RESERVE.SND_NXT := MODULAR_CONVERT(SIXTEEN_BITS(0)); RESERVE.RCV_NXT := BUFPTR.SEQ_NUM + BYTE_COUNT - (BUFPTR.DATA_OFFSET * 4); SEND_A_RESET_AND_ACK(RESERVE); end if; elsif BUFPTR.SYN = BIT_SET then -- new_line;--for debug(JB 2/17/85) -- put_line("SYN = BIT_SET"); -- new_line; LCN.RCV_NXT := BUFPTR.SEQ_NUM + MODULAR_CONVERT(SIXTEEN_BITS(1)); LCN.INIT_RCV_SEQ_NUM := BUFPTR.SEQ_NUM; -- SET UP OUR SEND WINDOW MECHANISM IN THE TCB. LCN.SND_WND := BUFPTR.WINDOW; LCN.SND_WL1 := BUFPTR.SEQ_NUM; LCN.SND_WL2 := LCN.ISS; if BUFPTR.ACK = BIT_SET then new_line; put_line("delete from retrans queue"); new_line; LCN.SND_UNA := BUFPTR.ACK_NUM; -- REMOVE ALL ACKED SEGMENTS FROM THE RETRANSMISSION QUEUE DELETE_FROM_RETRANS_QUEUE(LCN, LCN.SND_UNA); -- CHANGE THE ACK NUMBER OF LAST SEG USED TO UPDATE THE WINDOW. LCN.SND_WL2 := BUFPTR.ACK_NUM; end if; if LCN.SND_UNA > LCN.ISS then SEND_A_PIGGYBACKED_ACK(LCN); LCN.STATE := ESTABLISHED; -- TELL THE USER. SOCKET_PARAMS := LCN; UMESSAGE := ( 23, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); -- HERE WE PROCESS ANY OTHER TEXT AND CONTROLS ENTER_ESTABLISHED_STATE_PROCESSING(LCN, BUFPTR); ELSE -- QUEUE ANY OTHER TEXT OR CONTROLS FOR LATER PROCESSING new_line;--for debug(JB 2/17/85) put_line("queue any other text or controls"); new_line; IF BYTE_COUNT > BUFPTR.DATA_OFFSET * 4 -- THEN TEXT EXISTS OR (BUFPTR.FIN = BIT_SET) THEN -- CLEAR PREVIOUSLY PROCESSED FLAGS BUFPTR.ACK := 0; BUFPTR.SYN := 0; Q_ITEM := (NULL_BUFFER, BUFPTR, BYTE_COUNT); QUEUE_ADD(TCP_RECEIVED_SEGMENT_QUEUE, LCN, Q_ITEM); END IF; -- SEND A SYN, ACK -- THE SEQUENCE NUMBER MUST BE ISS. LCN.SND_NXT := LCN.ISS; LCN.STATE := SYN_RECEIVED; SEND_A_SYN_AND_ACK(LCN); END IF; end if; -- RELEASE BUFFER GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); EXCEPTION WHEN CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN SYN SENT STATE"); WHEN OTHERS => PUT_LINE("ERROR IN SYN SENT STATE"); end SEG_ARRIVED_IN_SYN_SENT_STATE; procedure SEG_ARRIVED_IN_SYN_RECEIVED_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVE PROCESSOR WHEN A SEGMENT -- ARRIVES IN THE SYN RECEIVED STATE. -- PROCESSING : -- -- THIS PROCEDURE DOES ALL THE NECESSARY PROCESSING FOR AN ARRIVED SEGMENT -- IN THE SYN RECEIVED STATE ACCORDING TO THE TCP SPECIFICATION. -- UMESSAGE : USER_MESSAGE; NULL_Q_ITEM : STD_Q_ITEM := (NULL, NULL_UNPACKED_BUFFER, 0); SOCKET_PARAMS : TCB_PTR; BEGIN -- THE CHECKSUM AND THE SEQUENCE NUMBER HAVE ALREADY BEEN CHECKED. IF BUFPTR.RST = BIT_SET THEN IF LCN.ACTIVE_PASSIVE = T_TCP_GLOBALS_DATA_STRUCTURES.PASSIVE THEN -- RETURN TO THE LISTEN STATE LCN.STATE := T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN; ELSE -- TELL USER -- CONNECTION REFUSED SOCKET_PARAMS := T_TCP_GLOBALS_DATA_STRUCTURES.LCN; UMESSAGE := ( 17, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.STATE := CLOSED; QUEUE_CLEAR(RECEIVE_QUEUE, LCN); -- THERE IS NO SEND Q ON THIS LEVEL. CLEAR_SEND_QUEUE(LCN); END IF; QUEUE_CLEAR(TCP_RECEIVED_SEGMENT_QUEUE, LCN); QUEUE_CLEAR(TCP_RETRANSMIT_QUEUE, LCN); ELSIF LCN.SECURITY /= SECURITY OR LCN.PRECEDENCE /= IP_TOS/2**5 THEN -- SEND A RESET SEND_A_RESET(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN IF (LCN.SND_UNA > BUFPTR.ACK_NUM) OR (BUFPTR.ACK_NUM > LCN.SND_NXT) THEN -- SEND A RESET RESERVE.SND_NXT := BUFPTR.ACK_NUM; SEND_A_RESET(RESERVE); ELSE LCN.STATE := ESTABLISHED; -- TELL THE USER CONNECTION OPEN. SOCKET_PARAMS := LCN; UMESSAGE := ( 23, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.SND_UNA := BUFPTR.ACK_NUM; -- UPDATE UNACKNOWLEDGED NUMBER -- REMOVE ACKNOWLEDGED DATA FROM RETRANS QUEUE. DELETE_FROM_RETRANS_QUEUE(LCN, LCN.SND_UNA); -- DO NECESSARY ESTABLISHED STATE PROCESSING ENTER_ESTABLISHED_STATE_PROCESSING(LCN, BUFPTR); END IF; END IF; -- RELEASE BUFFER GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); END SEG_ARRIVED_IN_SYN_RECEIVED_STATE; PROCEDURE SEG_ARRIVED_IN_ESTABLISHED_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is -- INITIAL DESCRIPTION : -- -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVE PROCESSOR WHEN A SEGMENT -- ARRIVES IN THE ESTABLISHED STATE. IT WILL DO ALL THE NECESSARY PROCESSING -- AS SPECIFIED IN THE SPEC. -- PROCESSING : -- -- THIS PROCEDURE DOES ALL THE NECESSARY PROCESSING FOR THE ESTABLISHED STATE -- AS SPECIFIED IN THE TCP SPEC. IT THEN RELEASES THE BUFFER THE SEGMENT IS -- IN. IT WILL QUEUE ANY DATA FOR THE USER TO BE ACCEPTED AT THE USERS -- CONVENIENCE. BUFFTYPE : SIXTEEN_BITS ; RESULT : T_TCP_ARRIVES_1.RES; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; begin IF BUFPTR.RST = BIT_SET THEN PROCESS_RESET_IN_DATA_ACCEPTING_STATES(LCN); ELSIF LCN.SECURITY /= SECURITY OR LCN.PRECEDENCE /= IP_TOS/2**5 THEN -- CLEAR THE QUEUES QUEUE_CLEAR(RECEIVE_QUEUE, LCN); -- THERE IS NO SEND QUEUE ON THIS LEVEL. CLEAR_SEND_QUEUE(LCN); QUEUE_CLEAR(TCP_RETRANSMIT_QUEUE, LCN); QUEUE_CLEAR(TCP_RECEIVED_SEGMENT_QUEUE, LCN); QUEUE_CLEAR(TRANSMIT_QUEUE, LCN); QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); -- TELL USER -- CONNECTION RESET SOCKET_PARAMS := LCN; UMESSAGE := ( 16, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.STATE := CLOSED; -- MAY HAVE TO CLEAR THE TCB HERE TCB_CLEAR(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN PROCESS_COMMON_ACK(LCN, BUFPTR, RESULT); IF RESULT = T_TCP_ARRIVES_1.GOOD THEN PROCESS_URGENT_FLAG(LCN, BUFPTR); PROCESS_SEGMENT_TEXT(LCN, BUFPTR); FIN_CHECK_FOR_ESTAB_OR_SYN_RECEIVED_STATES(LCN, BUFPTR); END IF; ELSE TCP_ERROR(14); -- NO ACK BIT SET END IF; -- RELEASE BUFFER GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); EXCEPTION WHEN OTHERS => PUT_LINE("ERROR IN ESTABLISHED STATE ARRIVE PROCESSING!"); RAISE; END SEG_ARRIVED_IN_ESTABLISHED_STATE; PROCEDURE SEG_ARRIVED_IN_FIN_WAIT_1_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is -- INITIAL DESCRIPTION : -- -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVED PROCESSOR TO DO ALL -- NECESSARY PROCESSING FOR A CONNECTION IN THE FIN-WAIT-1 STATE WHEN -- A SEGMENT ARRIVES. -- PROCESSING : -- -- THIS PROCEDURE WILL DO ALL NECESSARY PROCESSING FOR A SEGMENT WHICH -- ARRIVES IN THE FIN-WAIT-1 STATE (ACCORDING TO THE SPEC). IT WILL ALSO -- CONTINUE THE PROCESSING IN THE FIN-WAIT-2 STATE WHEN AN ACK FOR THE -- FIN ARRIVES. RESULT : T_TCP_ARRIVES_1.RES; BEGIN IF BUFPTR.RST = BIT_SET THEN PROCESS_RESET_IN_DATA_ACCEPTING_STATES(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN PROCESS_COMMON_ACK(LCN, BUFPTR, RESULT); IF RESULT = T_TCP_ARRIVES_1.GOOD THEN IF QUEUE_EMPTY(TCP_RETRANSMIT_QUEUE, LCN) THEN -- THE FIN IS ACKNOWLEDGED LCN.STATE := FIN_WAIT_2; -- *NOW DO THE SAME PROCESSING AS THE FIN-WAIT-2 STATE.* PROCESS_URGENT_FLAG(LCN, BUFPTR); PROCESS_SEGMENT_TEXT(LCN, BUFPTR); IF BUFPTR.FIN = BIT_SET THEN PROCESS_A_FIN(LCN, BUFPTR); LCN.STATE := TIME_WAIT; QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); -- DELETE UNEATEN DATA --START THE TIME-WAIT TIMER AND TURN OFF OTHER TIMERS START_TIMER(LCN, TIME_WAIT_TIMER); --TEXT_IO.NEW_LINE; --TEXT_IO.PUT_LINE("JUST SET TIMER FOR CONNECTION CLOSE"); END IF; ELSE -- FIN NOT ACKED SO CONTINUE ON OUR WAY. PROCESS_URGENT_FLAG(LCN, BUFPTR); PROCESS_SEGMENT_TEXT(LCN, BUFPTR); IF BUFPTR.FIN = BIT_SET THEN PROCESS_A_FIN(LCN, BUFPTR); LCN.STATE := CLOSING; QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); -- GET RID OF UNEATEN DATA END IF; END IF; END IF; END IF; -- RELEASE BUFFER GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); end SEG_ARRIVED_IN_FIN_WAIT_1_STATE; procedure SEG_ARRIVED_IN_FIN_WAIT_2_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is -- INITIAL DESCRIPTION : -- -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVE CONTROLLER TO PROCESS A -- SEGMENT WHEN THE CONNECTION IS IN THE FIN_WAIT_2 STATE. -- PROCESSING : -- -- THIS PROCEDURE DOES ALL THE PROCESSING ACCORDING TO THE SPEC FOR ARRIVED -- SEGMENTS IN THE FIN-WAIT-2 STATE. UMESSAGE : USER_MESSAGE; RESULT : T_TCP_ARRIVES_1.RES; begin IF BUFPTR.RST = BIT_SET THEN PROCESS_RESET_IN_DATA_ACCEPTING_STATES(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN PROCESS_COMMON_ACK(LCN, BUFPTR, RESULT); IF RESULT = T_TCP_ARRIVES_1.GOOD THEN PROCESS_URGENT_FLAG(LCN, BUFPTR); PROCESS_SEGMENT_TEXT(LCN, BUFPTR); IF BUFPTR.FIN = BIT_SET THEN PROCESS_A_FIN(LCN, BUFPTR); -- NOTE FIN IMPLIES PUSH LCN.STATE := TIME_WAIT; QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); -- DELETE UNEATEN DATA --START TIME_WAIT TIMER AND TURN OFF THE OTHER TIMERS START_TIMER(LCN, TIME_WAIT_TIMER); END IF; END IF; END IF; -- RELEASE BUFFER GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); end SEG_ARRIVED_IN_FIN_WAIT_2_STATE; procedure SEG_ARRIVED_IN_CLOSE_WAIT_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is -- INITIAL DESCRIPTION : -- -- THIS PROCEDURE IS CALLED BY THE SEGARIV PROCESSOR TO DO THE REQUIRED -- PROCESSING FOR AN ARRIVED SEGMENT IN THIS STATE. -- PROCESSING : -- -- THIS PROCEDURE PERFORMS ALL NECESSARY PROCESSING FOR THE CLOSE_WAIT STATE -- UPON SEGMENT ARRIVAL (ACCORDING TO THE TCP SPEC). RESULT : T_TCP_ARRIVES_1.RES; begin IF BUFPTR.RST = BIT_SET THEN PROCESS_RESET_IN_DATA_ACCEPTING_STATES(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN PROCESS_COMMON_ACK(LCN, BUFPTR, RESULT); -- WE WILL IGNORE ANY URGENT BITS SET -- WE WILL (AS PER THE SPEC) IGNORE ANY TEXT -- WE WILL ALSO NOT WORRY IF THIS IS A REDUNDANT FIN. END IF; -- RELEASE BUFFER BUFFREE(GLOBAL_PACKED_BUFFER, BUFFTYPE); end SEG_ARRIVED_IN_CLOSE_WAIT_STATE; procedure SEG_ARRIVED_IN_CLOSING_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is -- INITIAL DESCRIPTION : -- -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVE PROCESSOR TO PROCESS AN -- ARRIVED SEGMENT IN THE CLOSING STATE. -- PROCESSING : -- -- THIS PROCEDURE WILL DO ALL THE PROCESSING FOR AN ARRIVED SEGMENT, -- ACCORDING TO THE SPEC, WHEN THE CONNECTION IS IN THE CLOSING STATE. RESULT : T_TCP_ARRIVES_1.RES; begin IF BUFPTR.RST = BIT_SET THEN LCN.STATE := CLOSED; -- HERE WE MAY HAVE TO CLEAR THE TCB. TCB_CLEAR(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN PROCESS_COMMON_ACK(LCN, BUFPTR, RESULT); IF (RESULT = T_TCP_ARRIVES_1.GOOD) AND QUEUE_EMPTY(TCP_RETRANSMIT_QUEUE, LCN) THEN -- OUR FIN HAS BEEN ACKNOWLEDGED LCN.STATE := TIME_WAIT; QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); -- DELETE UNEATEN DATA -- STOP OTHER TIMERS AND START TIME_WAIT TIMER START_TIMER(LCN, TIME_WAIT_TIMER); END IF; -- ALL OTHER CONTROL BITS CAN BE IGNORED. -- TEXT ALSO. END IF; GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, 0); END SEG_ARRIVED_IN_CLOSING_STATE; PROCEDURE SEG_ARRIVED_IN_LAST_ACK_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) is -- INITIAL DESCRIPTION : -- -- THIS PROCEDURE IS CALLED WHEN A SEGMENT ARRIVES WITH THE CONNECTION IN THE -- LAST-ACK STATE. -- PROCESSING : -- -- THIS PROCEDURE DOES ALL THE PROCESSING FOR A SEGMENT THAT ARRIVES WITH A -- CONNECTION IN THE LAST-ACK STATE. IF THE FIN IS ACKED THE CONNECTION IS -- CLOSED. UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; BEGIN IF BUFPTR.RST = BIT_SET THEN LCN.STATE := CLOSED; -- THE TCB MAY HAVE TO BE CLEARED HERE. TCB_CLEAR(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN -- DOES THIS ACK OUR FIN? IF BUFPTR.ACK_NUM >= LCN.SND_NXT - 1 THEN -- TAKE SEGMENT(S) OFF THE RETRANSMISSION QUEUE. DELETE_FROM_RETRANS_QUEUE(LCN, BUFPTR.ACK_NUM); LCN.STATE := CLOSED; -- HERE WE MAY HAVE TO CLEAR THE TCB SOCKET_PARAMS := LCN; UMESSAGE := ( 18, SOCKET_PARAMS ); MESSAGE_FOR_USER( UMESSAGE ); TCB_CLEAR(LCN); TCB_FREE(LCN); ELSE -- THIS IS REALLY AN ERROR. TCP_ERROR(5); END IF; END IF; -- WE WILL IGNORE AS PER THE SPEC. ANYTHING ELSE. GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, 0); END SEG_ARRIVED_IN_LAST_ACK_STATE; PROCEDURE SEG_ARRIVED_IN_TIME_WAIT_STATE( BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BYTE_COUNT : in SIXTEEN_BITS ) IS -- INITIAL DESCRIPTION : -- -- THIS PROCEDURE IS CALLED BY THE SEGMENT ARRIVE PROCESSOR TO PROCESS A -- SEGMENT IN THE TIME-WAIT STATE. -- PROCESSING : -- -- THIS PROCEDURE WILL ACCEPT A RESENT FIN, ACK IT AGAIN AND RESTART THE -- TIME-WAIT TIMER. BEGIN IF BUFPTR.RST = BIT_SET THEN LCN.STATE := CLOSED; -- THE TCB MAY HAVE TO BE CLEARED HERE. TCB_CLEAR(LCN); ELSIF BUFPTR.SYN = BIT_SET THEN BAD_SYN_HANDLER(LCN, BUFPTR); ELSIF BUFPTR.ACK = BIT_SET THEN -- THIS SHOULD BE THE ACK WITH THE RETRANSMITTED FIN IF BUFPTR.FIN = BIT_SET THEN -- ACK THE FIN LCN.RCV_NXT := LCN.RCV_NXT + MODULAR_CONVERT(SIXTEEN_BITS(1)); --COVER THE FIN. SEND_A_PIGGYBACKED_ACK(LCN); -- RESTART THE 2 MSL (MAX SEG. LIFETIME TIMER) START_TIMER(LCN, TIME_WAIT_TIMER); END IF; END IF; -- WE WILL IGNORE AS PER THE SPEC. ANYTHING ELSE. GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; BUFFREE(GLOBAL_PACKED_BUFFER, 0); end SEG_ARRIVED_IN_TIME_WAIT_STATE; end TCP_SEG_ARRIVE; --:::::::::::::: --subcontr1.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01191-100(-) -- E-Systems, Inc. August 07, 1985 -- -- subcontr1.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with TEXT_IO; use TEXT_IO; with SUBNET_CALLS; use SUBNET_CALLS; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; with BUFFER_DATA; use BUFFER_DATA; package SUBNET_CONTROLLER_TASK is procedure SUBNET_CONTROLLER; end SUBNET_CONTROLLER_TASK; package body SUBNET_CONTROLLER_TASK is procedure SUBNET_CONTROLLER is DATAGRAM : PACKED_BUFFER_PTR := null; begin SNP.SUBNET_GET; --Check Ethernet Receive SNP.DELIVER( DATAGRAM ); if DATAGRAM /= null then --text_io.put_line("datagram /= null"); SUBNET_TO_IP( DATAGRAM ); BUFFREE( DATAGRAM, 0 ); end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT_ERROR IN SUBNET_CONTROLLER"); when others => PUT_LINE("UNKNOWN ERROR IN SUBNET_CONTROLLER"); end SUBNET_CONTROLLER; end SUBNET_CONTROLLER_TASK; --:::::::::::::: --subnet.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01192-100(-) -- E-Systems, Inc. August 07, 1985 -- -- subnet.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA ; use BUFFER_DATA ; with IP_GLOBALS ; use IP_GLOBALS ; package SUBNET_CALLS is -------------------------------------------------- --This implementation version is for use with -- --Telesoft Ada for WICAT Machine -- -------------------------------------------------- ------------------------------------------------------------------------------ --This package contains procedure calls and data structures necessary for -- --the Internet Protocol Group and the Subnet Protocol Group to communicate. -- ------------------------------------------------------------------------------ PACKAGE SNP is procedure SUBNET_GET ; procedure SEND (DATAGRAM : in out PACKED_BUFFER_PTR ; LOCAL_DESTINATION : in LOCAL_ADDRESS_TYPE ; PRECEDENCE : in PRECEDENCE_TYPE ; RELIABILITY : in RELIABILITY_TYPE ; DELAY_IP : in DELAY_TYPE ; THROUGHPUT : in THROUGHPUT_TYPE ; LENGTH : in DATAGRAM_LENGTH ) ; --This entry sends a datagram to the subnet for transmit. --Fully compatible with MIL-STD 1777. procedure DELIVER (DATAGRAM : out PACKED_BUFFER_PTR) ; --This entry requests for a datagram from the subnet. If --the pointer is null, the subnet queue is empty. Fully compatible --with MIL-STD 1777. procedure SEND_TO_IP (DATAGRAM : in out PACKED_BUFFER_PTR) ; end SNP ; end SUBNET_CALLS ; with system ; use system; with unchecked_conversion ; with Text_io ; use Text_io, integer_io, long_integer_io ; with system ; use system ; with unchecked_conversion ; with mover; use mover ; package body SUBNET_CALLS is ------------------------------------------------- --This implementation version is for use with -- -- WICAT -- ------------------------------------------------- -- -- 13-JUN-*% : (VCB) Port to WICAT under ROS with TCP/IP --************************************************************************ -------------------------------------------------------------------------- -------------------------------------------------------------------------- -- Ethernet Packet Format : -- -- Field Number of Bytes -- -- PREAMBLE 8 -- DESTINATION ADDRESS 6 -- SOURCE ADDRESS 6 -- PROTOCOL TYPE 2 -- DATA 46 TO 1500 -- FRAME CHECK SEQUENCE 4 -- Note : -- The first two bytes of the data field are -- used to store the data LENGTH parameter. -- -- Note : Inter-frame spacing is 9.6 microseconds, minimum -- -------------------------------------------------------------------------- -- -- subnet driver routines -- -------------------------------------------------------------------------- type net_address is array (0..5) of system.byte ; type packet_type is array (0..2047) of system.byte ; type big_packet is array (0..4095) of system.byte ; buffer_busy : exception ; Net_Error : exception ; function addr is new unchecked_conversion (thirtytwo_bits, system.address) ; function long is new unchecked_conversion (system.address, thirtytwo_bits) ; function bol is new unchecked_conversion (sixteen_bits, boolean) ; function int is new unchecked_conversion (boolean, sixteen_bits) ; -- -- 3Com board address... -- base : constant thirtytwo_bits := 16#E60000# ; -- base address of 3-Com csr : sixteen_bits ; for csr use at addr (base+ 16#0000#) ; back : sixteen_bits ; for back use at addr (base+ 16#0002#) ; SA_rom : net_address ; for SA_rom use at addr (base+ 16#0400#) ; SA_ram : net_address ; for SA_ram use at addr (base+ 16#0600#) ; TX_buf : packet_type ; for TX_buf use at addr (base+ 16#0800#) ; RX_bufs : big_packet ; for RX_bufs use at addr (base+ 16#1000#) ; A_offset: constant sixteen_bits := 16#0000# ; B_offset: constant sixteen_bits := 16#0800# ; PA : constant sixteen_bits := 16#0008# ; Jinten : constant sixteen_bits := 16#0010# ; TINTEN : constant sixteen_bits := 16#0020# ; AINTEN : constant sixteen_bits := 16#0040# ; BINTEN : constant sixteen_bits := 16#0080# ; RESET : constant sixteen_bits := 16#0100# ; SPARE : constant sixteen_bits := 16#0200# ; RBBA : constant sixteen_bits := 16#0400# ; AMSW : constant sixteen_bits := 16#0800# ; JAM : constant sixteen_bits := 16#1000# ; TBSW : constant sixteen_bits := 16#2000# ; ABSW : constant sixteen_bits := 16#4000# ; BBSW : constant sixteen_bits := sixteen_bits (16#8000#) ; CODE : constant sixteen_bits := PA+AMSW+ABSW+BBSW ; package body SNP is procedure SUBNET_GET is begin null; end SUBNET_GET ; procedure SEND (DATAGRAM : in out PACKED_BUFFER_PTR ; LOCAL_DESTINATION : in LOCAL_ADDRESS_TYPE ; PRECEDENCE : in PRECEDENCE_TYPE ; RELIABILITY : in RELIABILITY_TYPE ; DELAY_IP : in DELAY_TYPE ; THROUGHPUT : in THROUGHPUT_TYPE ; LENGTH : in DATAGRAM_LENGTH ) is begin null ; end SEND ; procedure DELIVER (DATAGRAM : out PACKED_BUFFER_PTR) is begin null; end DELIVER ; procedure SEND_TO_IP (DATAGRAM : in out PACKED_BUFFER_PTR) is begin null; end SEND_TO_IP ; end SNP; end SUBNET_CALLS ; --:::::::::::::: --subnetcal.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01193-100(-) -- E-Systems, Inc. August 07, 1985 -- -- subnetcal.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with buffer_data; use buffer_data; with IP_GLOBALS; use IP_GLOBALS; package subnet_calls is ------------------------------------------------ --This implementation version is for use with -- --Telesoft Ada for Wicat Machine -- ------------------------------------------------- ------------------------------------------------------------------------------- --This package contains procedure calls and data structures necessary for -- --the Internet Protocol Group and the Subnet Protocol Group to communicate.-- ------------------------------------------------------------------------------- PACKAGE SNP is procedure subnet_get ; procedure send( datagram : in out packed_buffer_ptr; local_destination : in Local_address_type; precedence : in Precedence_type; reliability : in reliability_type; delay_ip : in delay_type; throughput : in throughput_type; length : in datagram_length); --This entry sends a datagram to the subnet for transmit. --Fully compatible with MIL-STD 1777. procedure Deliver( datagram : out packed_buffer_ptr); --This entry requests for a datagram from the subnet. If the pointer --is null, the subnet queue is empty. Fully compatible with MIL-STD 1777. procedure send_to_ip ( datagram: in out packed_buffer_ptr); end SNP; end subnet_calls; with system; use system; with unchecked_conversion; with TEXT_IO; use TEXT_IO, INTEGER_IO, LONG_INTEGER_IO; with system; use system; with unchecked_conversion; with mover; use mover; package body subnet_calls is ------------------------------------------------------ --This implementation version is for use with -- --WICAT ------------------------------------------------------ -- 10-JUL-85 : (VCB) Port to WICAT under ROS with TCP/IP --------------------------------------------------------------- --------------------------------------------------------------- -- Ethernet Packet Format: -- -- Field Number Bytes -- -- preamble 8 -- destination address 6 -- source address 6 -- protocol type 2 -- data 46 to 1500 -- frame check sequence 4 -- note: -- The first two bytes of the dat field are -- used to stroe the data LENGTH parameter. -- Note: inter-frame is 9.6 microseconds, minimum -- -------------------------------------------------------------------------------- -- -- subnet driver routines -- -------------------------------------------------------------------------------- -- type net_address is array(0..5) of system.byte; type packet_type is array(0..2047) of system.byte; type big_packet is array (0..4095) of system.byte; buffer_busy : exception; net_error : exception; function addr is new unchecked_conversion (thirtytwo_bits,system.address); function long is new unchecked_conversion (system.address,thirtytwo_bits); function bol is new unchecked_conversion (sixteen_bits,boolean); function int is new unchecked_conversion (boolean, sixteen_bits); -- -- 3Com board addresses.... -- base : constant thirtytwo_bits := 16#E60000#; --base address of 3-Com csr : sixteen_bits; for csr use at addr(base+ 16#0000#); back : sixteen_bits; for back use at addr(base+ 16#0002#); SA_rom : net_address; for SA_rom use at addr(base+ 16#0400#); SA_ram : net_address; for SA_ram use at addr(base+ 16#0600#); TX_buf : packet_type; for TX_buf use at addr(base+ 16#0800#); RX_bufs : big_packet; for RX_bufs use at addr(base+ 16#1000#); A_offset: constant sixteen_bits := 16#0000#; -- Offset to A buffer B_offset: constant sixteen_bits := 16#0800#; -- offset to b buffer PA : constant sixteen_bits := 16#0008#; -- receive mine & brcast jinten : constant sixteen_bits := 16#0010#; -- jam interrupt enable bit tinten : constant sixteen_bits := 16#0020#; -- TX interrupt enable bit ainten : constant sixteen_bits := 16#0040#; -- A_rec interrupt enable bit binten : constant sixteen_bits := 16#0080#; -- B_rec interrupt enable bit reset : constant sixteen_bits := 16#0100#; -- master reset spare : constant sixteen_bits := 16#0200#; -- not used rbba : constant sixteen_bits := 16#0400#; -- state of a when b arrives amsw : constant sixteen_bits := 16#0800#; -- net address control jam : constant sixteen_bits := 16#1000#; -- jam bit tbsw : constant sixteen_bits := 16#2000#; -- transmit buffer control absw : constant sixteen_bits := 16#4000#; -- receive buffer a control bbsw : constant sixteen_bits := sixteen_bits (16#8000#); -- receive buffer B Code : constant sixteen_bits := pa+amsw+absw+bbsw; protocol_type_1 : constant system.byte := 16#06#; --MSB of protocol type protocol_type_2 : constant system.byte := 16#60#; --lsb of protocol type buffer_addr : system.address; -- Temp for 'move' routine type ethernet_address is array (0..5) of integer ; type host_ethernet_pair is record host_number : local_address_type; local_addr : ethernet_address; end record; address_table : array (1..max_hosts) of host_ethernet_pair; buffer_size : constant integer :=16; type dg_array is array (0..buffer_size) of packed_buffer_ptr; type buffer_type is record put : integer range 0..buffer_size := 0; get : integer range 0..buffer_size := 0; val : dg_array; end record; buffer : buffer_type; package body snp is ----------------------------------------------------------------------------- -- -- -- Procedure Subnet_put -- -- -- ----------------------------------------------------------------------------- procedure subnet_put (buf: in out packed_buffer_ptr; adr: in Local_address_type; length_of_packet: in datagram_length) is minimum_bytes : constant datagram_length := 46; --minimum bytes to xmit ptr : sixteen_bits; --Offset from 3-com attempt_count : sixteen_bits; --Number of tries net_address : ethernet_address; --Ethernet destination address datagram : system.address; --IP datagram location host_valid : boolean := false; --Denotes valid host ID len : datagram_length; --Local length begin len := length_of_packet; --Make sure we have a valid host address ID for i in 1..max_hosts loop if address_table(i).host_number = adr then net_address := address_table(i).local_addr; host_valid := true; exit; end if; end loop; if host_valid then --Make sure we have transmit buffer if bol(csr) and bol(TBSW) then raise buffer_busy; end if; new_line; --Make sure packet contains at least minimum_bytes of data if len < minimum_bytes then for i in len .. minimum_bytes loop buf.byte(i+1) := 0; --nulls padded in end loop; len := minimum_bytes; end if; --copy packet to 3-Com TX Buffer ptr := 2048-len; --offset inTX buffer of 1st byte for i IN 0..(len-1) loop TX_buf(ptr + (LEN - 1) - I) := buf.byte(255 -i); end loop; --Now put ethernet header on packet (dest,src,type) --First destination address ptr := ptr - 16; -- 16 bytes before 1st byte in data field for i in 0..5 loop TX_buf(ptr+i) := system.byte(net_address(i)); --insert dest end loop; --Now Source address for i in 0..5 loop TX_buf (ptr+6+i) := SA_ram(i); --insert source address end loop; --Protocol type (*** ensures invisibility to DECnet--not used by us) TX_buf(ptr+12) := protocol_type_1; --1st byte of type TX_buf(ptr+13) := protocol_type_2; --2nd byte of type --Add packet length designation following protocol type field TX_buf(ptr+15) := len/256; TX_buf(ptr+14) := len MOD 256; --Now set transmit buffer header TX_buf(0) := ptr/256; --ptr still indexes packet start TX_buf(1) := ptr mod 256; --Now issue TRANSMIT COMMAND and wait for it to be sent csr:=TBSW+Code; --issue command attempt_count := 1; loop if attempt_count > 15 then raise Net_Error; end if; exit when (int(bol(csr) and bol (TBSW)) = 0); -- when buffer is returned if int(bol(csr) and bol (JAM))/= 0 then -- We got collision TEXT_IO.put_line ("Collision"); attempt_count := attempt_count + 1; back := -20; --stupid delay csr := JAM+CODE; -- clear jam and retry end if; end loop; --text_io.new_line; --TEXT_IO.put("Sent Ethernet packet of "); --TEXT_IO.INTEGER_IO.put(len); --TEXT_IO.put_line ("octets"); else TEXT_io.put_line("invalide ethernet id"); --for debug only end if; -- NOTE: Subnet must set buf.in_use to FALSE before freeing up the buffer buf.in_use := false; buffree (buf,0); -- free the datagram buffer exception when buffer_busy => Text_IO.put_line("Exception in subnet_put: 3-Com board busy."); when Net_Error => Text_io.put_line("exception in subnet_put: Maximum collision count."); when constraint_error => text_io.put_line("constraint error in subnet_put"); when others => text_io.put_line("Exception in subnet_put: Undefined."); end subnet_put; -------------------------------------------------------------------------------- -- -- subnet_get -- -------------------------------------------------------------------------------- procedure subnet_get is buffer_select : sixteen_bits := -1; temp : sixteen_bits; temp2 : sixteen_bits; ptr : sixteen_bits; len : sixteen_bits; datagram : system.address; buf : packed_buffer_ptr; begin -- Check if packet has arrived, and determine which buffer it is in if (int(bol(csr) and bol(ABSW)) = 0) then if (int(bol(csr) and bol(BBSW)) = 0) then --if both ready if (int(bol(csr) and bol(RBBA)) = 0) then --see which cam first buffer_select := A_offset; else buffer_select := B_offset; end if; else buffer_select := A_offset; end if; else if (int(bol(csr) and bol(BBSW)) = 0) then buffer_select := B_offset; end if; end if; if buffer_select >= 0 then -- true if packet available --Get a free buffer for IP to use buffget (buf,1); if buf /= null then BUF.STATUS := OWNER_IP; BUF.IN_USE := TRUE; datagram := buf.byte'address; ptr := buffer_select; temp := RX_bufs (ptr); --compute length of packet temp := temp mod 8 ; temp2 := RX_bufs(ptr+1); len := temp*256 + temp2 - 22; --reduce count by HDR & FCS --text_io.new_line; --Text_io.put("Received a packet of "); --Text_IO.Integer_IO.put (len); --Text_IO.put_line("octets"); ptr := ptr + 18; -- skip over Ethernet header -- text_io.put("byte 1="); -- integer_io.put(rx_bufs(ptr-2)); -- text_io.put("byte 2=") ; -- integer_io.put(rx_bufs(ptr-1)); -- new_line; -- text_io.put(" type 1= "); -- integer_io.put(rx_bufs(ptr-4)); -- text_io.put(" type 2= "); -- integer_io.put(rx_bufs(ptr-3)); -- new_line; --Correct the length based on ether packet and move data to user buffer len := rx_bufs(ptr-1)*256+rx_bufs(ptr-2); buf.size := len ; for i IN 1..(len) loop buf.byte(i) := RX_bufs(i+ptr - 1); end loop; send_to_ip(buf); --send to IP else Text_io.put_line("LOST ETHERNET PACKET. OUT OF BUFFERS"); end if; end if; csr := CODE; --give rec. buf back to ether exception when constraint_error => text_io.put_line("Constraint error in subnet_get"); when others => text_io.put_line("other exception in subnet_get"); end subnet_get; procedure deliver( datagram : In out packed_buffer_ptr) is begin if (buffer.put /= buffer.get) then datagram := buffer.val(buffer.get); buffer.get := (buffer.get + 1) mod buffer_size; else DATAGRAM := null; end if; exception when constraint_error=> text_io.put_line("Constraint error in deliver"); when others => text_io.put_line("Other exception in deliver"); end deliver; procedure send( datagram : in out packed_buffer_ptr; local_destination : in Local_address_type; precedence : in precedence_type; reliability : in reliability_type; delay_ip : in delay_type; throughput : in throughput_type; length : in datagram_length) is begin --TEXT_IO.NEW_LINE; --TEXT_IO.PUT("LENGTH(SUBNET) := "); --TEXT_IO.INTEGER_IO.PUT(LENGTH); --TEXT_IO.NEW_LINE; subnet_put(datagram, local_destination, length); end send; procedure send_to_ip(datagram : in out packed_buffer_ptr) is begin if buffer.get /= (buffer.put + 1) mod buffer_size then datagram.ip_ptr := 1; buffer.val(buffer.put) := datagram ; buffer.put := (buffer.put + 1) mod buffer_size; else Text_io.put_line("LOST AN ETHERNET PACKET -- NO QUEUE SPACE "); -- Must set datagram.in_use to FALSE before freeing this buffer datagram.in_use := FALSE; buffree(datagram,0); end if; exception when constraint_error => text_io.put_line("constraint error in send_to_ip"); when others => text_io.put_line("other exception in send_to_ip"); end send_to_ip; end SNP; -- subnet_interface - subnet protocol for Ethernet -- -- -------------------------------------------------------------------------- -- --Start_Subnet_Driver (Initialization for 3-Com Board -- -------------------------------------------------------------------------- procedure start_subnet_driver is begin csr := RESET; --do a board reset for i in 0..5 loop --copy rom addres to ram SA_ram(i) := SA_rom(i); --for recognition end loop; csr := code ; -- give address & rec bufs to ether end start_subnet_driver; ------------------------------------------------------------------------------ -- -- MAIN - Initialize the Ethernet Driver -- ----------------------------------------------------------------------------- begin address_table := ( (1, (16#AA#,16#00#,16#04#,16#00#, 16#01#,16#04#)), --vax saturn (2, (16#AA#,16#00#,16#04#,16#00#, 16#02#,16#04#)), --vax mars (3, (16#02#,16#60#,16#8C#,16#00#, 16#79#,16#42#)), --sylvester (128, (16#00#,16#00#,16#00#,16#00#, 16#00#,16#00#))); --unused text_io.put_line("3Com Board started "); start_subnet_driver ; --intialize 3 Com Board end subnet_calls; --:::::::::::::: --sub_int.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01194-100(-) -- E-Systems, Inc. August 07, 1985 -- -- sub_int.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with buffer_data; use buffer_data; with subnet_calls; use subnet_calls; -- PACKAGE subnet_interface - Subnet Protocol for Ethernet -- -- -- This package provides the init,send, & receive functions for -- Ethernet. It assumes a 3Com board is plugged in and addressable -- at E60000. -- -- 04-JUN-85 : (VCB) Port to WICAT under ROS with TCP/IP --******************************************************************** ---------------------------------------------------------------------- ---------------------------------------------------------------------- package subnet_interface is -- -- subtype LOCAL_ADDRESS_TYPE is INTEGER ; subtype DATAGRAM_LENGTH is INTEGER ; procedure subnet_put (buf: in out packed_buffer_ptr; -- adr: in local_address_type; -- len: in datagram_length); -- procedure subnet_get; -- -- end subnet_interface; -- -- ---------------------------------------------------------------------- ---------------------------------------------------------------------- --******************************************************************** -- -- -- Ethernet Packet Format: -- -- Field Number of Bytes -- -- PREAMBLE 8 -- DESTINATION ADDRESS 6 -- SOURCE ADDRESS 6 -- PROTOCOL TYPE 2 -- DATA 46 to 1500 -- FRAME CHECK SEQUENCE 4 -- -- Note: Inter-frame spacing is 9.6 microseconds, minimum -- with Text_io; use text_io,integer_io, long_integer_io; with system; use system; with unchecked_conversion; with mover; package body subnet_interface is type net_address is array(0..5) of system_byte; type packet_type is array(0..2047) of system_byte; buffer_busy : exception; Net_Error : exception; function addr is new unchecked_conversion (thirtytwo_bits,system.address); function long is new unchecked_conversion (system.address,thirtytwo_bits); function bol is new unchecked_conversion (sixteen_bits,boolean); -- -- 3Com board addresses... -- base : constant thirtytwo_bits := 16#E60000#; -- base address of 3com csr : sixteen_bits; for csr use at addr(base+ 16#0000#); back : sixteen_bits; for back use at addr(base+ 16#0002#); SA_rom : net_address; for SA_rom use at addr(base+ 16#0400#); SA_ram : net_address; for SA_ram use at addr(base+ 16#0600#); TX_buf : packet_type; for TX_buf use at addr(base+ 16#0800#); RX_bufs : array(0..4095) of system_byte;for RX_bufs use at addr(base+ 16#1000#); A_offset: constant sixteen_bits := 16#0000#; -- offset to A buffer B_offset: constant sixteen_bits := 16#0800#; -- offset to B buffer PA : constant sixteen_bits := 16#0008#; -- receive only mine & brcast JINTEN : constant sixteen_bits := 16#0010#; -- jam interrupt enable bit TINTEN : constant sixteen_bits := 16#0020#; -- TX interrupt enable bit AINTEN : constant sixteen_bits := 16#0040#; -- A_Rec interrupt enable bit BINTEN : constant sixteen_bits := 16#0080#; -- B_Rec interrupt enable bit RESET : constant sixteen_bits := 16#0100#; -- Master Reset SPARE : constant sixteen_bits := 16#0200#; -- not used RBBA : constant sixteen_bits := 16#0400#; -- state of A when B arrives AMSW : constant sixteen_bits := 16#0800#; -- net address control JAM : constant sixteen_bits := 16#1000#; -- jam bit TBSW : constant sixteen_bits := 16#2000#; -- transmit buffer control ABSW : constant sixteen_bits := 16#4000#; -- receive buffer A control BBSW : constant sixteen_bits := sixteen_bits(16#8000#); -- receive buffer B control CODE : constant sixteen_bits := PA+AMSW+ABSW+BBSW; protocol_type_1 : constant system_byte := 16#60#; -- MSB of protocol type protocol_type_2 : constant system_byte := 16#06#; -- LSB of protocol type buffer_addr : system.address; -- Temp for 'move' routine type ethernet_address is array (0..7) of system_byte; type host_ethernet_pair is record host_number : local_address_type; local_addr : ethernet_address; end record; address_table : array (1..max_hosts) of host_ethernet_pair := ( (1, (16#AA#,16#00#,16#04#,16#00#, -- vax saturn 16#01#,16#04#,16#00#,16#00#)), (2, (16#AA#,16#00#,16#04#,16#00#, -- vax mars 16#02#,16#04#,16#00#,16#00#)), (3, (16#02#,16#60#,16#8C#,16#00#, -- sylvester 16#79#,16#42#,16#00#,16#00#)), (128, (16#00#,16#00#,16#00#,16#00#, -- unused 16#00#,16#00#,16#00#,16#00#))); -- --------------------------------------------------------------------- -- -- -- START_SUBNET_DRIVER (Initialization for 3-Com board -- -- -- ------------------------------------------------------------------------ procedure start_subnet_driver is begin csr := RESET; -- do a board reset for i in 0..5 loop -- copy rom address to ram SA_ram(i) := SA_rom(i); -- for recognition end loop; csr := CODE; -- give address & rec. bufs to ether end init; ------------------------------------------------------------------------- -- -- -- SUBNET_PUT (Put datagram from IP to Ethernet) -- -- -- ------------------------------------------------------------------------- procedure subnet_put (buf: in out packed_buffer_ptr; adr: in local_address_type; len: in datagram_length) is ptr : sixteen_bits; -- Offsets from 3-Com base addr attempt_count : sixteen_bits; -- Number of tries net_address : ethernet_address; -- Ethernet destination address datagram : system.address; -- IP datagram location host_valid : boolean := false; -- Denotes valid host ID begin -- make sure we have a valid host address ID for i in 1..max_hosts loop if address_table(i).host_number = adr then net_address := address_table(i).local_addr; host_valid := true; exit; end if; end loop; if host_valid then -- make sure we have transmit buffer if bol(csr) and bol(TBSW) then raise buffer_busy; end if; -- copy packet to 3-Com TX Buffer ptr := 2048-len; -- offset in TX buffer of 1st byte datagram := buf.byte(buf.subnet_ptr)'address; -- IP datagram buffer_addr := addr(long(TX_buf'address)+thirtytwo_bits(ptr)); mover.move (datagram, buffer_addr, len); -- do move in ASM -- now put ethernet header on packet (dest,src,type) -- first destination address ptr := ptr - 14; -- 14 bytes before 1st byte in data field for i in 0..5 loop TX_buf(ptr+i) := net_address(i); -- insert dest address end loop; -- now source address for i in 0..5 loop TX_buf(ptr+6+i) := SA_ram(i); -- insert source address end loop; -- protocol type (*** ensures invisibility to DECnet-- not used by us) TX_buf(ptr+12) := protocol_type_1; -- 1st byte of type TX_buf(ptr+13) := protocol_type_2; -- 2nd byte of type -- now set transmit buffer header TX_buf(0) := ptr/256; -- ptr still indexes packet start TX_buf(1) := ptr mod 256; -- now issue TRANSMIT COMMAND and wait for it to be sent csr := TBSW+CODE; -- issue command attempt_count := 1; loop if attempt_count > 15 then raise Net_Error; end if; exit when not (bol(csr) and bol(TBSW)); -- when buffer is returned if not (bol(csr) and bol(JAM)) then -- we got a collision put_line("Collision"); attempt_count := attempt_count + 1; back := -20; -- stupid delay csr := JAM+CODE; -- clear jam & retry end if; end loop; put("Sent Ethernet packet of "); put(len);put_line(" octets"); else put_line("INVALID ETHERNET ID"); -- for debug only end if; buffree(buf,0); -- free the datagram buffer exception when buffer_busy => put_line("EXCEPTION in Subnet_put: 3-Com board busy."); when Net_Error => put_line("EXCEPTION in Subnet_put: Maximum collision count."); when others => put_line("EXCEPTION in Subnet_put: Undefined."); end subnet_put; --------------------------------------------------------------------- -- -- -- SUBNET_GET (Get Ethernet Packet and send to IP) -- -- -- --------------------------------------------------------------------- procedure subnet_get; buffer_select : sixteen_bits := -1; temp : sixteen_bits; temp2 : sixteen_bits; ptr : sixteen_bits; len : sixteen_bits; datagram : system.address buf : packed_buffer_pointer; begin -- Check if packet has arrived, and determine which buffer it is in if not (bol(csr) and bol(ABSW)) then if not(bol(csr) and bol(BBSW)) then -- if both ready if not(bol(csr) and bol(RBBA)) then -- see which came first buffer_select := A_offset; else buffer_select := B_offset; end if; else buffer_select := A_offset; end if; else if not (bol(csr) and bol(BBSW)) then buffer_select := B_offset; end if; end if; if buffer_select >= 0 then -- true if packet available -- get a free buffer for IP to use buffget(buf,1); if buf /= null then datagram := buf.byte(buf.subnet_ptr)'address; ptr := buffer_select; temp := RX_bufs(ptr) mod 8; -- compute length of packet temp2 := RX_bufs(ptr+1); len := temp*256 + temp2 - 18; -- reduce count by HDR & FCS ptr := ptr + 14; -- skip over Ethernet header -- move packet to user buffer buffer_addr := addr(long(RX_bufs'address)+thirtytwo_bits(ptr)); mover.move(buffer_addr, datagram, len); -- do move in ASM send_to_ip(buf); -- send to IP put("Received a packet of "); put(len);put_line(" octets"); else put_line("LOST ETHERNET PACKET. OUT OF BUFFERS"); end if; end if; csr := CODE; -- give rec. buf back to ether end subnet_get; -- INITIALIZE SUBNET DRIVERS begin start_subnet_driver; end subnet_interface; --:::::::::::::: --tcpcont2.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01195-100(-) -- E-Systems, Inc. August 07, 1985 -- -- tcpcont2.txt Author : Jim Baldo -- ----------------------------------------------------------------------- package TCP_CONTROLLER_TASK is -------------------------------------------------------------- --This implementation is for the Telesoft/Ada compiler . -- -------------------------------------------------------------- ------------------------------------------------------------------------------ -- This package contains the necessary procedures and functions to control -- -- the transmission control protocol(TCP) activities in general and -- -- specifically all activities associated with ULP commands to TCP. -- ------------------------------------------------------------------------------ procedure TCP_CONTROLLER; -- The TCP_CONTROLLER task is responsible for the control and operation of -- the TCP layer. It determines the necessary actions after it gets --a message from the communications queue. It then calls the procedure -- that will cause that task to be performed. A task message is -- gotten via an entry into the communication task. This message is -- used to call a procedure to process the request for action made to the TCP. -- --The following procedures are contained within the package body and --are used by TCP_CONTROLLER to perform the specific processing for each --event. It should be noted that the event processing defined below --is specifed by MIL-STD-1778. -- -- TCP_SEND - This procedure will process a send request from the user. -- -- TCP_ABORT - This procedure will cause a connection to be aborted. the -- user requests this action. -- -- TCP_RECEIVE - This procedure will cause any data from a remote site to -- the user to be returned to the user. -- -- TCP_CLOSE - This procedure will cause a connection to be closed. -- -- TCP_OPEN - This procedure will attempt to open an active or passive -- connection to a remote host as required by the user. -- -- TCP_STATUS - This procedure will return the status of a connection to -- the user. -- -- TCP_ERROR - This procedure will handle any errors that may come to the -- attention of the TCP. They may be TCP errors or error -- notifications from other layers of protocol. -- -- RETRANS_TCP - This procedure will retransmit the first packet in the -- retransmit queue. -- -- TCP_SEG_ARRIVE - This procedure determines the action to be taken upon -- reception of segment. It will then call a routine to -- perform the action. The action is based on the state of -- the connection. -- -- MESSAGE_FOR_USER - Give a message to the user layer. end TCP_CONTROLLER_TASK ; with TEXT_IO; use TEXT_IO, INTEGER_IO; with TCP_GLOBALS ; use TCP_GLOBALS ; with TCP_SEGMENT_ARRIVES_PROCESSING ; use TCP_SEGMENT_ARRIVES_PROCESSING ; with TCP_ARRIVES_PERIPHERALS ; use TCP_ARRIVES_PERIPHERALS ; with BUFFER_DATA ; use BUFFER_DATA ; with T_TCP_CONTROLLER_UTILITIES ; use T_TCP_CONTROLLER_UTILITIES ; with QUEUES ; use QUEUES ; with REAL_TIME_CLOCK_AND_DATE ; use REAL_TIME_CLOCK_AND_DATE ; with TCB_ALLOCATOR ; use TCB_ALLOCATOR ; with T_TCP_GLOBALS_DATA_STRUCTURES ; use T_TCP_GLOBALS_DATA_STRUCTURES ; with WITH_ULP_COMMUNICATE; use WITH_ULP_COMMUNICATE; with WITH_TCP_COMMUNICATE ; use WITH_TCP_COMMUNICATE ; package body TCP_CONTROLLER_TASK is -------------------------------------------------------------- --This implementation is for the DEC/Ada compiler . -- -------------------------------------------------------------- procedure TCP_CONTROLLER is MESSAGE_FROM_IP : MESSAGE ; UMESSAGE : USER_MESSAGE; TASK_MESSAGE : MESSAGE; FLAG : BOOLEAN := TRUE; -- for message RETRANSMIT : BOOLEAN := TRUE; MAX_TEMP : SIXTEEN_BITS ; SOCKET_PARAMS : TCB_PTR; DELETE_A_LCN : BOOLEAN := FALSE; TEMP_HOLDER_LCN : TCB_PTR := null ; function DETERMINE_VALID_LCN( LCN : TCB_PTR ) return BOOLEAN is VALID_LCN : TCB_PTR := null ; RESULT : BOOLEAN := FALSE ; begin VALID_LCN := OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; while VALID_LCN /= null loop if VALID_LCN = LCN then RESULT := TRUE ; RETURN RESULT; end if; VALID_LCN := VALID_LCN.NEXT ; end loop; RETURN RESULT; end DETERMINE_VALID_LCN; begin -- TCP_CONTROLLER --determine if any timeouts have occurred LCN := OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; --text_io.put_line("before LCN /= null "); while LCN /= null loop --TEXT_IO.put("system time = "); --text_io.long_integer_io.put(thirtytwo_bits(system_time)); --TEXT_IO.new_line; --Note that we will have a problem when the local_time_now cycles --every 6 hours. We simply make the types modular. if LCN.STATE /= T_TCP_GLOBALS_DATA_STRUCTURES.CLOSED and (LCN.STATE /= T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN) then --Check appropriate times and call necessary routine for any timeouts. if THIRTYTWO_BITS(SYSTEM_TIME) >= LCN.NEXT_CONNECTION_TIMEOUT and (LCN.NEXT_CONNECTION_TIMEOUT > 0) then --trash the connection and notify the user SOCKET_PARAMS := LCN; UMESSAGE := ( 24, SOCKET_PARAMS); MESSAGE_FOR_USER( UMESSAGE); QUEUE_CLEAR(TCP_RETRANSMIT_QUEUE, LCN); QUEUE_CLEAR(TRANSMIT_QUEUE); QUEUE_CLEAR(TCP_RECEIVED_SEGMENT_QUEUE); QUEUE_CLEAR(RECEIVE_QUEUE); QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE); DELETE_A_LCN := TRUE; FLAG := FALSE; elsif THIRTYTWO_BITS(SYSTEM_TIME) >= LCN.NEXT_TIME_WAIT_TIMEOUT and (LCN.NEXT_TIME_WAIT_TIMEOUT > 0) then --Close it up. User will now be informed it is closed. SOCKET_PARAMS := LCN; UMESSAGE := ( 18, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); QUEUE_CLEAR(RECEIVE_QUEUE, LCN); DELETE_A_LCN := TRUE; FLAG := FALSE; elsif QUEUE_SIZE(TCP_RETRANSMIT_QUEUE) > 0 then --a more sophisticated retransmission scheme is needed!! while RETRANSMIT loop if THIRTYTWO_BITS(SYSTEM_TIME) >= QUEUE_RETRANS_TIME(LCN) + 15 --THIRTYTWO_BITS (LCN.RETRANS_INTERVAL) * --THIRTYTWO_BITS (100) --for VAX then --retransmit a segment RETRANS_TCP(LCN); new_line;--for debug(JB 3/6/85) put_line("just sent a retrans message"); new_line; FLAG := FALSE; else RETRANSMIT := FALSE; end if; end loop; --reset the retransmit flag for the next lcn RETRANSMIT := TRUE; --do it the first time end if; end if; --main if if LCN.STATE = T_TCP_GLOBALS_DATA_STRUCTURES.ESTABLISHED and then (not QUEUE_EMPTY(TRANSMIT_QUEUE, LCN)) then SEND_FROM_TRANSMIT_QUEUE(LCN); end if; TEMP_HOLDER_LCN := LCN; LCN := LCN.NEXT;--obtain next connection if DELETE_A_LCN then TCB_CLEAR( TEMP_HOLDER_LCN ) ; TCB_FREE( TEMP_HOLDER_LCN ) ; DELETE_A_LCN := FALSE ; end if; end loop; WAIT( TASK_MESSAGE ) ; -- NOTE THE TASK MESSAGE IS A VARIANT RECORD WHICH WILL BE DELETED FROM -- QUEUE BY QUEING ROUTINE. case TASK_MESSAGE.EVENT is when SEND => -- SET LOCAL FIELDS FROM QUEUE RECORD if DETERMINE_VALID_LCN( TASK_MESSAGE.SEND_PARAMETERS.LCN ) then TCP_SEND( TASK_MESSAGE.SEND_PARAMETERS.LCN, TASK_MESSAGE.SEND_PARAMETERS.BUFPTR, TASK_MESSAGE.SEND_PARAMETERS.BYTE_COUNT, TASK_MESSAGE.SEND_PARAMETERS.PUSH_FLAG, TASK_MESSAGE.SEND_PARAMETERS.URG_FLAG, TASK_MESSAGE.SEND_PARAMETERS.TIMEOUT ); else PUT_LINE("BOGUS SEND LCN"); end if; when RECEIVE => --SET LOCAL FIELDS FROM QUEUE MESSAGE RECORD if DETERMINE_VALID_LCN( TASK_MESSAGE.RECEIVE_PARAMETERS.LCN ) then TCP_RECEIVE( TASK_MESSAGE.RECEIVE_PARAMETERS.LCN, TASK_MESSAGE.RECEIVE_PARAMETERS.BUFPTR, TASK_MESSAGE.RECEIVE_PARAMETERS.BYTE_COUNT ) ; else PUT_LINE("BOGUS RECEIVE LCN"); end if; when ABOR_T => if DETERMINE_VALID_LCN( TASK_MESSAGE.ABORT_CLOSE_PARAMETERS.LCN) then TCP_ABORT( TASK_MESSAGE.ABORT_CLOSE_PARAMETERS.LCN ) ; -- ABORT THE CONNECTION else PUT_LINE("BOGUS ABORT LCN"); end if; when WITH_TCP_COMMUNICATE.CLOSE => if DETERMINE_VALID_LCN( TASK_MESSAGE.ABORT_CLOSE_PARAMETERS.LCN ) then TCP_CLOSE( TASK_MESSAGE.ABORT_CLOSE_PARAMETERS.LCN ) ; else PUT_LINE("BOGUS CLOSE LCN"); end if; when WITH_TCP_COMMUNICATE.OPEN => -- WE WILL SET THE LOCAL CONNECTION NAME HERE. IT WILL -- BE THE LOCAL PORT NUMBER TEMPORARILY. TCP_OPEN( TASK_MESSAGE.OPEN_PARAMETERS.LOCAL_PORT, TASK_MESSAGE.OPEN_PARAMETERS.FOREIGN_PORT, TASK_MESSAGE.OPEN_PARAMETERS.FOREIGN_NET_HOST, TASK_MESSAGE.OPEN_PARAMETERS.ACTIVE_PASSIVE, TASK_MESSAGE.OPEN_PARAMETERS.BUFFER_SIZE, TASK_MESSAGE.OPEN_PARAMETERS.TIMEOUT, TASK_MESSAGE.OPEN_PARAMETERS.LCN, TASK_MESSAGE.OPEN_PARAMETERS.SECURITY, TASK_MESSAGE.OPEN_PARAMETERS.PRECEDENCE, TASK_MESSAGE.OPEN_PARAMETERS.OPTIONS ) ; when STATUS => if DETERMINE_VALID_LCN( TASK_MESSAGE.STATUS_PARAMETERS.LCN ) then TCP_STATUS( TASK_MESSAGE.STATUS_PARAMETERS.LCN ) ; -- THIS CONDITION MODELS THE TIME-OUT IN THE TIME-WAIT STATE WHICH USES -- A TIMER TO ENSURE THE CONNECTION IS CLOSED. else PUT_LINE("BOGUS STATUS LCN"); end if; when TIMEOUT_IN_TIME_WAIT => -- checked by tcp controller null; when ERROR_MESSAGE => TCP_ERROR( TASK_MESSAGE.ERROR_PARAMETERS.ERROR_INDICATOR ) ; when TIMEOUT_IN_RETRANS_QUEUE => -- checked by tcp controller null; when DATA_FROM_IP => TCP_SEG_ARRIVE( TASK_MESSAGE.DATA_FROM_IP_PARAMETERS.BUFPTR, TASK_MESSAGE.DATA_FROM_IP_PARAMETERS.BYTE_COUNT, TASK_MESSAGE.DATA_FROM_IP_PARAMETERS.SOURCE_ADDRESS, TASK_MESSAGE.DATA_FROM_IP_PARAMETERS.DESTINATION_ADDRESS, TASK_MESSAGE.DATA_FROM_IP_PARAMETERS.PROTOCOL, TASK_MESSAGE.DATA_FROM_IP_PARAMETERS.TOS, TASK_MESSAGE.DATA_FROM_IP_PARAMETERS.SECURITY); when TIMER_TIMEOUT => null; when NO_TCP_ACTION => --TEXT_IO.put_line("NO_TCP_ACTION");--for debug (JB 1/31/85) null; end case; exception when CONSTRAINT_ERROR => PUT_LINE("A CONSTRAINT ERROR WAS UNHANDLED IN TCP"); when others => PUT_LINE("UNKNOWN ERROR IN UNKNOWN ROUTINE OF TCP"); end TCP_CONTROLLER; end TCP_CONTROLLER_TASK ; --:::::::::::::: --tcpglbda1.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01196-100(-) -- E-Systems, Inc. August 07, 1985 -- -- tcpglbda1.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_GLOBALS; use IP_GLOBALS; with BUFFER_DATA; use BUFFER_DATA; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; with MODULO; use MODULO; package T_TCP_GLOBALS_DATA_STRUCTURES is ----------------------------------------------------------- --This implementation is for use with the Telesoft Ada -- --compiler version 1.5 . -- ----------------------------------------------------------- --***************************************************************************** --*Implementation Restrictions * --*--------------------------- * --* Some of these types could have their bit size set when the compiler * --* is able to do it. * --***************************************************************************** TABLE_RANGE : constant SIXTEEN_BITS := 32; subtype ERROR_TYPE is SIXTEEN_BITS; type STATUS_TYPE is (CONNECTION_OPEN, CONNECTION_CLOSED, OPENING, CLOSING); type ACKPASS is (PASSIVE, ACTIVE); type TIMER_TYPE is (TIME_WAIT_TIMER, RETRANS_TIMER, TIMEOUT_TIMER); type HEADER_TYPE is (ACK, SYN, SYN_ACK, SEGMENT, SEG_ACK, FIN, RST, RST_ACK); type STATES is (CLOSED,SYN_SENT,SYN_RECEIVED,ESTABLISHED,LISTEN, FIN_WAIT_1,CLOSE_WAIT,FIN_WAIT_2,CLOSING,TIME_WAIT,LAST_ACK); type SECURE is array(1..9) of SIXTEEN_BITS; -- EACH ELEMENT OF THIS ARRAY IS ONE -- OCTET OF SECURITY OPTION INFO. AFTER -- THE TYPE AN LENGTH FIELD. type TABLE_TYPE is array(1..TABLE_RANGE) of SIXTEEN_BITS; type TIME_ACTION is (NONE, RETRANSMIT_TIMEOUT, CONNECTION_TIMEOUT, TIME_WAIT_TIMEOUT); subtype WND_PORT is SIXTEEN_BITS; -- THE ACTUAL RANGE IS + OR - 2**16 - 1 subtype SEVEN_BITS is SIXTEEN_BITS; subtype TEN_BITS is SIXTEEN_BITS; subtype THREE_BITS is SIXTEEN_BITS; subtype TWO_BITS is SIXTEEN_BITS; subtype FOUR_OCTETS is THIRTYTWO_BITS; subtype TWO_OCTETS is SIXTEEN_BITS; subtype ONE_OCTET is SIXTEEN_BITS; subtype HALF_OCTET is SIXTEEN_BITS; subtype SIX_BITS is SIXTEEN_BITS; subtype ONE_BIT is SIXTEEN_BITS; type BUFFER_POINTER is record BTYPE : SIXTEEN_BITS; DATA_LEN : SIXTEEN_BITS := 0; SOURCE_PORT : TWO_OCTETS; DESTINATION_PORT : TWO_OCTETS; SEQ_NUM : MODULAR; ACK_NUM : MODULAR; DATA_OFFSET : HALF_OCTET; RESERVED : SIX_BITS; URG_FLAG : ONE_BIT; ACK : ONE_BIT; PUSH_FLAG : ONE_BIT; RST : ONE_BIT; SYN : ONE_BIT; FIN : ONE_BIT; WINDOW : TWO_OCTETS; TCP_CSUM : TWO_OCTETS; URG_PTR : TWO_OCTETS; --OPTIONS FOR TCP TCP_OPTIONS : OPTION_TYPE := (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0); DATA : BUFFER_AREA; -- ARRAY OF SYSTEM.BYTES. FROM USER LEVEL. end record; ERROR_TABLE_CLEAR : constant TABLE_TYPE := (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); --*********************QUEUE TYPES****************************** type QNAME is (TRANSMIT_QUEUE, TCP_RETRANSMIT_QUEUE, TCP_RECEIVED_SEGMENT_QUEUE, RECEIVE_QUEUE, PROCESSED_SEGMENTS_FOR_USER_QUEUE); type STD_Q_ITEM is record BUFFER : PACKED_BUFFER_PTR; UNPACKED_BUFFER : BUFFER_POINTER; LENGTH : SIXTEEN_BITS; end record; type STD_QUEUE_ELEMENT; type STD_QUEUE_ELEMENT_POINTER is access STD_QUEUE_ELEMENT; type STD_QUEUE_ELEMENT is record ELEMENT : STD_Q_ITEM; TIME : THIRTYTWO_BITS; -- FOR THE RETRANSMISSION TIME. IP_ID : SIXTEEN_BITS; -- THE IP ID FOR RETRANSMISSION NEXT : STD_QUEUE_ELEMENT_POINTER; end record; type STD_HEAD_PTR is record ELEMENT_COUNT : SIXTEEN_BITS; FIRST_ELEMENT : STD_QUEUE_ELEMENT_POINTER; LAST_ELEMENT : STD_QUEUE_ELEMENT_POINTER; end record; type STD_QUEUE_HEAD_POINTERS is array(QNAME) of STD_HEAD_PTR; --*********************QUEUE TYPES****************************** NUMBER_OF_QUEUES : constant SIXTEEN_BITS := 5; MAX_QUEUE_SIZE : constant SIXTEEN_BITS := 32; INITIAL_QUEUE_HEADER : STD_HEAD_PTR := (0, NULL, NULL); INITIAL_QUEUE_HEADER_POINTERS : STD_QUEUE_HEAD_POINTERS := (INITIAL_QUEUE_HEADER, INITIAL_QUEUE_HEADER, INITIAL_QUEUE_HEADER, INITIAL_QUEUE_HEADER, INITIAL_QUEUE_HEADER); type TRANSMISSION_CONTROL_BLOCK; type TCB_PTR is access TRANSMISSION_CONTROL_BLOCK; type TRANSMISSION_CONTROL_BLOCK is record STATE : STATES; CONNECTION_STATUS : STATUS_TYPE; LOCAL_PORT : SIXTEEN_BITS := -1; LOCAL_NET : SIXTEEN_BITS := 0;--TEMPORARY** LOCAL_HOST : SIXTEEN_BITS := 1;-- TEMPORARY** SOURCE_ADDRESS : THIRTYTWO_BITS := 1;-- TEMPORARY** DESTINATION_ADDRESS : THIRTYTWO_BITS; FOREIGN_PORT : SIXTEEN_BITS := -1; FOREIGN_HOST : THIRTYTWO_BITS := -1; FOREIGN_NET : THIRTYTWO_BITS := -1; SND_UNA : MODULAR; SND_UP : MODULAR; SND_NXT : MODULAR; SND_WND : SIXTEEN_BITS := 190; RCV_NXT : MODULAR; PRECEDENCE : SIXTEEN_BITS := 0; USER_NOTIFICATION : BOOLEAN := FALSE; SECURITY : SECURE := (0, 0, 0, 0, 0, 0, 0, 0, 0); -- SOURCE_PORT : SIXTEEN_BITS; -- LIMITED BITS AND RANGE IS YET TO BE DET -- ERMINED BUFFSIZE : SIXTEEN_BITS; RCV_BUFFER_SIZE : WND_PORT; RCV_URGENT_POINTER : SIXTEEN_BITS; SND_WL1 : MODULAR; -- SEQ NUM OF THE LAST SEGMENT --USED TO UPDATE SND.WND SND_WL2 : MODULAR;-- RECORDS THE ACK NUM OF THE --LAST SEGMENT USED TO -- UPDATE SND.WND. THIS VARIABLE AND THE ABOVE ONE -- PREVENT AN OLD SEGMENT FROM BEING USED TO UPDATE -- THE WINDOW. RCV_WINDOW : WND_PORT := 190; INIT_RCV_SEQ_NUM : MODULAR; ISS : MODULAR;-- THE INITIAL SEND SEQUENCE NUMBER (ISS) RETRANS_INTERVAL : SIXTEEN_BITS := 30; -- LAST ARE PROBABLY TEMPORARY MAX_RETRY_OF_PACKET : SIXTEEN_BITS RANGE 0..8; PROTOCOL : SIXTEEN_BITS := 0; --(PTCL) UNKNOWN VALUE FOR TCP*** ACTIVE_PASSIVE : ACKPASS; CLOSE_PENDING : BOOLEAN := FALSE; -- FOR A CLOSE WITH DATA TO SEND. ERROR_TABLE : TABLE_TYPE := ERROR_TABLE_CLEAR; QHEADS : STD_QUEUE_HEAD_POINTERS := INITIAL_QUEUE_HEADER_POINTERS; IDENT : SIXTEEN_BITS := -1; -- THE IDENTIFICATION NUMBER FOR AN IP DATAGRAM RETRANS_IDENT : SIXTEEN_BITS; -- SUPPLIED BY THE QUEUE RETRANS ROUTINE FOR IP. NEXT_CONNECTION_TIMEOUT : THIRTYTWO_BITS; NEXT_TIME_WAIT_TIMEOUT : THIRTYTWO_BITS; CONNECTION_TIMEOUT : SIXTEEN_BITS := 180; -- DEFAULT IS 180 SECONDS OR 3 MINUTES CLOSE_OK_NOTIFICATION : BOOLEAN := FALSE; NEXT : TCB_PTR; end record; -- THE PSEUDO HEADER SOURCE, DESTINATION : THIRTYTWO_BITS; PROTOCOL, IP_TOS : SIXTEEN_BITS; -- THE SECURITY OPTION FROM IP SECURITY : SECURE; SECURE_CLEAR : SECURE := (0, 0, 0, 0, 0, 0, 0, 0, 0); LEN, IDENT : SIXTEEN_BITS; LCN_TCB_STATE : STATES; TYPE_FLAG : HEADER_TYPE; RESERVE : TCB_PTR; BIT_SET : constant SIXTEEN_BITS := 1; LCN : TCB_PTR; -- THE GLOBAL LOCAL CONNECTION NAME OPTIONS : OPTION_TYPE; -- THESE DECLARATIONS ARE CONSTANT IP PARAMETERS. ONE_MINUTE : constant SIXTEEN_BITS := 60; -- 00111100 TOS : constant SIXTEEN_BITS := 0; -- THE VALUE FROM TCP SPEC FOR THE IP AS THE LOWER -- LEVEL PROTOCOL. TTL : constant SIXTEEN_BITS := ONE_MINUTE; DONT_FRAGMENT : constant SIXTEEN_BITS := 1; -- WE ARE NOT A GATEWAY. CLEAR : OPTION_TYPE := (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); TCP_SECURITY_OPTIONS : OPTION_TYPE := (130,11,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0); end T_TCP_GLOBALS_DATA_STRUCTURES; --:::::::::::::: --tcpglobals.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01197-100(-) -- E-Systems, Inc. August 07, 1985 -- -- tcpglobals.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_GLOBALS ; use IP_GLOBALS ; with T_TCP_GLOBALS_DATA_STRUCTURES; use T_TCP_GLOBALS_DATA_STRUCTURES; with BUFFER_DATA; use BUFFER_DATA; package TCP_GLOBALS is ---------------------------------------------------- --This implementation is for use with the DEC/Ada -- --compiler . -- ---------------------------------------------------- ------------------------------------------------------------------------------- --This package contains all necessary global variables for any tcp routine. -- --This includes the TCB and any operations necessary to operate on the global-- -- data. -- ------------------------------------------------------------------------------- procedure PACK_BUFFER_INTO_BIT_STREAM( BUFPTR : in T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; PACKED_BUFFER : in PACKED_BUFFER_PTR); --This subprogram will break up a record of integers, long_integers, --and modular types into system bytes. It uses the function --unchecked_conversion to move integers, etc. into the array of system --bytes. procedure TCP_HEADER_FORMAT( LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; TYPE_FLAG : in HEADER_TYPE; OPTIONS : in OPTION_TYPE); --This subprogram is responsible for formatting a TCP header for any --type of segment. The segment type is denoted by the type_flag. A --checksum will be performed over the formatted header and conceptual --pseudo header. All header fields are reset and/or filled in. function CHECKSUM( TCP_HEADER_LENGTH : in SIXTEEN_BITS ; PACKED_BUFFER : in PACKED_BUFFER_PTR; DESTINATION, SOURCE : in THIRTYTWO_BITS ; PROTOCOL : in SIXTEEN_BITS ) return SIXTEEN_BITS ; --This function performs the 16 bit one's complement checksum over the --entire TCP header and data as well as the 96 bit pseudo header which --is the source and destination address, the protocol, and the TCP --length. procedure TCP_ERROR( ERROR_INDICATION : in ERROR_TYPE); --This subprogram is called upon an error occurrence. Currently it --simply increments a counter in the appropriate TCB'S table. function FOREIGN_SOCKET_UNSPECIFIED( LCN : in TCB_PTR) return boolean; --This subprogram attempts to determine if the foreign socket is --unspecified by checking for illegal values and the net and host --addresses the same (as they were initialized). function ISS return THIRTYTWO_BITS ; --This function gets the local time in milliseconds and multiplies it --by 250 to determine the ISS. This means it will cycle approximately --every 4.55 hours. procedure ADDRESS_DECODER( CONCATENATION : in THIRTYTWO_BITS ); --This subprogram will determine the form of the net and host addresses --from the first three bits of the concatenated form. It will then --separate and decode the bits into the proper TCB varibles by using --unchecked conversions between types. The format of the concatenated --version can be found in the IP spec. procedure INSERT_TEXT_IN_BUFFER( LENGTH : in SIXTEEN_BITS ; RECEIVED_PACKED_BUFFER : in PACKED_BUFFER_PTR; DATA_LENGTH : in SIXTEEN_BITS ; PACKED_BUFFER : in PACKED_BUFFER_PTR); --This subprogram will put a slice of data from one array of sytem --bytes to another of system bytes. It begins at the points in the --respective arrays as indicated by their first element. procedure TIMEOUT_CHECK( LCN : in TCB_PTR; ACTION : out TIME_ACTION); --This subprogram determines if the connection has timeout, waiting --for a timeout, or retransmit timeout has occured. An action result --parameter indicating which of previously described events has --occurred is returned. The LCN parameter is passed to the subprogram. procedure START_TIMER(LCN : in TCB_PTR; TIMER : in TIMER_TYPE); --This procedure will reset the connection timeout timer in a TCB --or the time wait timer as specified by an LCN. There will be a --problem when the clock cycles after 6 hours, but this can be taken --care of with the modular type. end TCP_GLOBALS; with QUEUES; use QUEUES; with SYSTEM; with MODULO; use MODULO; with TEXT_IO; use TEXT_IO, INTEGER_IO; with UNCHECKED_CONVERSION; with REAL_TIME_CLOCK_AND_DATE; use REAL_TIME_CLOCK_AND_DATE; package BODY TCP_GLOBALS is DUMMY : CHARACTER;--DEBUG procedure PACK_BUFFER_INTO_BIT_STREAM ( BUFPTR : in T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; PACKED_BUFFER : in PACKED_BUFFER_PTR) is HEADER_LENGTH : SIXTEEN_BITS := BUFPTR.DATA_OFFSET * 4; INDEX : SIXTEEN_BITS := PACKED_BUFFER.TCP_PTR; LENGTH : SIXTEEN_BITS := BUFPTR.DATA_LEN + HEADER_LENGTH; -- CURRENTLY THE HEADER -- LENGTH IS ALWAYS 20 -- SINCE NO OPTIONS ARE -- IMPLEMENTED. procedure PUT_AN_INTEGER_IN_THE_BUFFER(VALUE : SIXTEEN_BITS ) is type STUPID is array(1..1) of SIXTEEN_BITS ; type TWO_BYTES is array(1..2) of SYSTEM.BYTE; function CONVERT_INTEGER_TO_BYTES is new UNCHECKED_CONVERSION(STUPID,TWO_BYTES); TEMP_INT : STUPID; BYTES_FROM_INTEGER : TWO_BYTES; begin TEMP_INT(1) := VALUE; BYTES_FROM_INTEGER := CONVERT_INTEGER_TO_BYTES(TEMP_INT); PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS ( 2 ) - 1 ) := BYTES_FROM_INTEGER(1); PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS ( 1 ) - 1 ) := BYTES_FROM_INTEGER(2); INDEX := INDEX + 2; exception when others => TEXT_IO.PUT_LINE("ERROR IN PUT INTEGER INTO BUFFER"); INTEGER_IO.PUT(INDEX); end PUT_AN_INTEGER_IN_THE_BUFFER; procedure PUT_A_LONG_INTEGER_IN_THE_BUFFER (DOUBLE_WORD : THIRTYTWO_BITS ) is type STUPID_LONG is array(1..1) of THIRTYTWO_BITS ; type FOUR_BYTES is array(1..4) of SYSTEM.BYTE ; function CONVERT_LONG_INT_TO_BYTES is new UNCHECKED_CONVERSION(STUPID_LONG,FOUR_BYTES); TEMP_LONG_INT : STUPID_LONG; BYTES_FROM_LONG_INT : FOUR_BYTES; begin TEMP_LONG_INT(1) := DOUBLE_WORD; BYTES_FROM_LONG_INT := CONVERT_LONG_INT_TO_BYTES(TEMP_LONG_INT); for I in 1..4 loop -- PUT THEM IN PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS(5 - I) - 1 ) := BYTES_FROM_LONG_INT(I); end loop; INDEX := INDEX + 4; exception when others => TEXT_IO.PUT_LINE("ERROR IN PUT LONG INTEGER INTO BUFFER"); INTEGER_IO.PUT(INDEX); end PUT_A_LONG_INTEGER_IN_THE_BUFFER; begin -- SET UP THE INITIAL INDEX INDEX := (INDEX - HEADER_LENGTH) + 1;-- THEIR DIFFERENCE PLUS 1 -- SO PROPER # PLACES USED -- DATA IS ALREADY IN BUFFER. PACKED_BUFFER.TCP_PTR := INDEX; PUT_AN_INTEGER_IN_THE_BUFFER(BUFPTR.SOURCE_PORT); PUT_AN_INTEGER_IN_THE_BUFFER(BUFPTR.DESTINATION_PORT); PUT_A_LONG_INTEGER_IN_THE_BUFFER( LONG(BUFPTR.SEQ_NUM)); PUT_A_LONG_INTEGER_IN_THE_BUFFER( LONG(BUFPTR.ACK_NUM)); -- PUT IN SOME SMALL FIELDS AND BIT FIELDS PACKED_BUFFER.BYTE(INDEX) := SYSTEM.BYTE ( BUFPTR.DATA_OFFSET * 16 ) ; PACKED_BUFFER.BYTE(INDEX+1) := SYSTEM.BYTE ( BUFPTR.URG_FLAG * 32 + BUFPTR.ACK * 16 + BUFPTR.PUSH_FLAG * 8 + BUFPTR.RST * 4 + BUFPTR.SYN * 2 + BUFPTR.FIN ) ; INDEX := INDEX + 2; PUT_AN_INTEGER_IN_THE_BUFFER(BUFPTR.WINDOW); -- CLEAR THE CHECKSUM FIELD PACKED_BUFFER.BYTE(INDEX) := 0; PACKED_BUFFER.BYTE(INDEX+1) := 0; INDEX := INDEX + 2; PUT_AN_INTEGER_IN_THE_BUFFER(BUFPTR.URG_PTR); -- NOW WE PUT THE OPTIONS IN THE BUFFER. HOWEVER THEY ARE -- CURRENTLY NOT IMPLEMENTED -- HERE WE COULD PUT THE DATA IN THE BUFFER. --FOR I IN 1..LENGTH - HEADER_LENGTH LOOP -- PACKED_BUFFER.BYTE(INDEX + I - 1) := BUFPTR.DATA(I); --END LOOP; -- PERFORM THE HEADER CHECKSUM INDEX := INDEX - 4; -- TO POINT TO THE CHECKSUM FIELD. PUT_AN_INTEGER_IN_THE_BUFFER(CHECKSUM(LENGTH, PACKED_BUFFER, LCN.DESTINATION_ADDRESS, LCN.SOURCE_ADDRESS, 5) ); -- SET THE POINTER FOR THE NEXT LAYER PACKED_BUFFER.IP_PTR := PACKED_BUFFER.TCP_PTR - 1; exception when others => TEXT_IO.PUT_LINE("ERROR IN PACK BUFFER MAIN"); INTEGER_IO.PUT(INDEX); TEXT_IO.PUT_LINE(""); INTEGER_IO.PUT(LENGTH); end PACK_BUFFER_INTO_BIT_STREAM; procedure TCP_HEADER_FORMAT ( LCN : in TCB_PTR; BUFPTR : in out T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; TYPE_FLAG : in HEADER_TYPE; OPTIONS : in OPTION_TYPE) is pragma SUPPRESS(OVERFLOW_CHECK);-- ENABLES MOD 2**16 IDENT FOR THE IP. begin LCN.IDENT := LCN.IDENT + 1; -- INCREMENT IP ID NUMBER. IDENT := LCN.IDENT; -- SET UP THE PARAMETER FOR CALL TO IP -- HERE WE INITIALIZE THE COMMONNLY UNUSED PORTIONS OF THE HEADER. BUFPTR.URG_PTR := 0; BUFPTR.ACK := 0; BUFPTR.URG_FLAG := 0; -- WE CURRENTLY DO NOT IMPLEMENT THE URGENT OPTION ON SENDS. BUFPTR.PUSH_FLAG := 0; -- WE CURRENTLY DO NOT IMPLEMENT THE PUSH OPTION ON SENDS. BUFPTR.RST := 0; BUFPTR.SYN := 0; BUFPTR.FIN := 0; case TYPE_FLAG is when ACK => BUFPTR.ACK := BIT_SET; when RST => BUFPTR.RST := BIT_SET; when SYN => BUFPTR.SYN := BIT_SET; when SYN_ACK => BUFPTR.ACK := BIT_SET; BUFPTR.SYN := BIT_SET; when SEGMENT => BUFPTR.ACK := BIT_SET; -- HERE WE WOULD CHECK IF WE NEED TO SET OUR URGENT POINTER. when SEG_ACK => BUFPTR.ACK := BIT_SET; -- HERE WE WOULD CHECK IF WE NEED TO SET OUR URGENT POINTER. when FIN => BUFPTR.FIN := BIT_SET; BUFPTR.ACK := BIT_SET; -- THE ACK BIT MUST ALWAYS BE SET. when RST_ACK => BUFPTR.RST := BIT_SET; BUFPTR.ACK := BIT_SET; end case; -- FILL IN THE RESET OF THE HEADER. -- NOTE WE DO NOT CURRENTLY IMPLEMENT OPTIONS. -- THIS MEANS THE DATA OFFSET IS CONSTANT. BUFPTR.DATA_OFFSET := 5; BUFPTR.SOURCE_PORT := LCN.LOCAL_PORT; BUFPTR.DESTINATION_PORT := LCN.FOREIGN_PORT; BUFPTR.SEQ_NUM := LCN.SND_NXT; BUFPTR.ACK_NUM := LCN.RCV_NXT; BUFPTR.WINDOW := LCN.SND_WND; -- WE COULD PERFORM CHECKSUM AND PLACE IT IN THE -- HEADER HERE BUT IT WILL BE -- DONE BY THE PACK ROUTINE. end TCP_HEADER_FORMAT; function CHECKSUM ( TCP_HEADER_LENGTH : in SIXTEEN_BITS ; PACKED_BUFFER : in PACKED_BUFFER_PTR; DESTINATION, SOURCE : in THIRTYTWO_BITS ; PROTOCOL : in SIXTEEN_BITS ) return SIXTEEN_BITS is --pragma SUPPRESS(OVERFLOW_CHECK); type TWO_WORDS is array(1..2) of SIXTEEN_BITS ; type TELEHOSE is array(1..1) of THIRTYTWO_BITS ; function CONVERSION is neW UNCHECKED_CONVERSION(TELEHOSE, TWO_WORDS); START_PTR : SIXTEEN_BITS := PACKED_BUFFER.TCP_PTR; END_PTR : SIXTEEN_BITS := START_PTR + TCP_HEADER_LENGTH - 1; CHECKSUM_TOTAL, TWO_INTEGERS : TWO_WORDS; TCSUM : THIRTYTWO_BITS := 0; TEMP1,TEMP2 : THIRTYTWO_BITS := 0; WORD_SHIFT : constant THIRTYTWO_BITS := 65536; HIGH_BYTE : BOOLEAN := FALSE; --TRUE; FOR 68000. WORDS ARE BYTE SWAPPED ON VAX. CHECKSM, LONG_HOLDER : TELEHOSE; begin -- THIS CHECKSUM IS PERFORMED ON THE TCP HEADER AS WELL AS A 96 BIT -- PSEUDO HEADER WHICH IS THE SOURCE AND DESTINATION ADDRESS, -- THE PROTOCOL, AND THE TCP LENGTH. -- PERFORM THE CHECKSUM OVER THE PSEUDO HEADER. LONG_HOLDER(1) := SOURCE; TWO_INTEGERS := CONVERSION(LONG_HOLDER); TCSUM := THIRTYTWO_BITS (TWO_INTEGERS(1)) + THIRTYTWO_BITS (TWO_INTEGERS(2)); LONG_HOLDER(1) := DESTINATION; TWO_INTEGERS := CONVERSION(LONG_HOLDER); TCSUM := TCSUM + THIRTYTWO_BITS (TWO_INTEGERS(1)) + THIRTYTWO_BITS (TWO_INTEGERS(2)); TCSUM := TCSUM + THIRTYTWO_BITS (PROTOCOL) + THIRTYTWO_BITS ( TCP_HEADER_LENGTH ); -- NOW DO THE ACTUAL HEADER for I in 0..END_PTR-START_PTR loop if (I /= 16) and I /= 17 then -- DON'T ADD IN THE CHECKSUM if I = 12 then HIGH_BYTE := TRUE;-- NECESSARY FOR VAX BYTE SWAPPING end if; if I = 14 then HIGH_BYTE := FALSE;-- NECESSARY FOR VAX BYTE SWAPPING end if; if I = 20 then HIGH_BYTE := TRUE;-- DATA IS STORED UNSWAPPED. end if; if HIGH_BYTE then TCSUM := TCSUM + THIRTYTWO_BITS (PACKED_BUFFER.BYTE(START_PTR + I)) * THIRTYTWO_BITS ( 2**8 ); HIGH_BYTE := FALSE; else HIGH_BYTE := TRUE; TCSUM := TCSUM + THIRTYTWO_BITS (PACKED_BUFFER.BYTE(START_PTR + I)); end if; end if; end loop; -- GET ONE'S COMPLEMENT TCSUM := (-TCSUM) - 1; CHECKSM(1) := TCSUM; CHECKSUM_TOTAL := CONVERSION(CHECKSM); -- GET BOTH WORDS AND RETURN LOW WORD. return CHECKSUM_TOTAL(2); exception when others => TEXT_IO.PUT_LINE("ERROR IN CHECKSUM"); INTEGER_IO.PUT(START_PTR); TEXT_IO.PUT_LINE("END POINTER"); INTEGER_IO.PUT(END_PTR); end CHECKSUM; procedure TCP_ERROR( ERROR_INDICATION : in ERROR_TYPE ) is begin -- INCREMENT THE ERROR COUNTER. LCN.ERROR_TABLE(ERROR_INDICATION) := LCN.ERROR_TABLE(ERROR_INDICATION) + 1; end TCP_ERROR; function FOREIGN_SOCKET_UNSPECIFIED(LCN : in TCB_PTR) return boolean is RESULT : BOOLEAN := FALSE; begin -- THIS COULD BE A TROUBLE SPOT IF -1 IS A LEGAL ADDRESS.*** if (LCN.FOREIGN_NET = LCN.FOREIGN_HOST) and LCN.FOREIGN_PORT = -1 then RESULT := TRUE; end if; return RESULT; end FOREIGN_SOCKET_UNSPECIFIED; function ISS return THIRTYTWO_BITS is X : THIRTYTWO_BITS := 0; begin -- THE TIME IS IN MILLISECONDS. MULTIPLYING BY 250 -- MAKES THE TIME APPEAR TO BELONG TO A CLOCK -- INCREMENTED EVERY FOUR MICROSECONDS. return X;-- TEMPORARY FOR TEST(LOCAL_TIME_NOW * 250); end ISS; procedure ADDRESS_DECODER ( CONCATENATION : in THIRTYTWO_BITS ) is type DUMB is array(1..1) of THIRTYTWO_BITS ; type TEMP is array(1..4) of SYSTEM.BYTE; function CONVERT is new UNCHECKED_CONVERSION(DUMB, TEMP); function CONVERT_LONG is new UNCHECKED_CONVERSION(TEMP, DUMB); X : DUMB := (1 => CONCATENATION); Y,W : TEMP; Z : DUMB; begin -- THE ADDRESSES ARE CONCATENATED INTO A 32 BIT LONG WORD. THE CODE FOR -- THE TYPES CAN BE FOUND IN THE INTERNET SPECIFICATION. W(1) := 0; W(2) := 0; W(3) := 0; W(4) := 0; Y := CONVERT(X); -- 7 BITS INTERNET ADDRESS AND 24 BITS HOST ADDRESS. if X(1) > 0 then LCN.FOREIGN_NET := THIRTYTWO_BITS (Y(4)); Y(4) := 0; Z := CONVERT_LONG(Y); LCN.FOREIGN_HOST := Z(1); -- 14 BITS INTERNET ADDRESS AND 16 HOST ADDRESS. elsif SIXTEEN_BITS ( Y(4) ) / 2**6 = 2 then Y(4) := Y(4) - 192 ; W(2) := Y(4); W(1) := Y(3); Z := CONVERT_LONG(W); LCN.FOREIGN_NET := Z(1); W(2) := Y(2); W(1) := Y(1); Z := CONVERT_LONG(W); LCN.FOREIGN_HOST := Z(1); elsif SIXTEEN_BITS(Y(4))/2**5 = 6 then -- 21 BITS INTERNET ADDRESS AND 8 HOST ADDRESS. Y(4) := Y(4) - 192 ; W(3) := Y(4); W(2) := Y(3); W(1) := Y(2); Z := CONVERT_LONG(W); LCN.FOREIGN_NET := Z(1); LCN.FOREIGN_HOST := THIRTYTWO_BITS (Y(1)); elsif SIXTEEN_BITS(Y(4))/2**5 = 7 then -- CURRENTLY NO EXTENDED ADDRESSING TCP_ERROR(2); null; else TCP_ERROR(3); end if; exception when others => TEXT_IO.PUT_LINE("ADDRESS DECODER FAILED"); for I in 1..4 loop INTEGER_IO.PUT( SIXTEEN_BITS(Y(I)) ); end loop; -- INTEGER_IO.PUT(LCN); end ADDRESS_DECODER; procedure INSERT_TEXT_IN_BUFFER( LENGTH : in SIXTEEN_BITS ; RECEIVED_PACKED_BUFFER : in PACKED_BUFFER_PTR; DATA_LENGTH : in SIXTEEN_BITS ; PACKED_BUFFER : in PACKED_BUFFER_PTR) is -- THE FIRST PARAMETERS ARE THE LENGTH OF THE DATA -- FIELD IN THE RECEIVE BUFFER AND THE BUFFER. -- THE SECOND SET OF PARAMETERS ARE THE LENGTH OF THE DATA -- BUFFER AND THE DATA BUFFER. INDEX, INDEX1 : SIXTEEN_BITS ; begin INDEX := RECEIVED_PACKED_BUFFER.TCP_PTR; INDEX1 := PACKED_BUFFER.TCP_PTR; if DATA_LENGTH = LENGTH then RECEIVED_PACKED_BUFFER.BYTE(INDEX..INDEX+LENGTH) := PACKED_BUFFER.BYTE(INDEX1..INDEX1+LENGTH); RECEIVED_PACKED_BUFFER.TELNET_PTR := RECEIVED_PACKED_BUFFER.TCP_PTR + LENGTH - 1; elsif DATA_LENGTH < LENGTH then RECEIVED_PACKED_BUFFER.BYTE(INDEX..INDEX + DATA_LENGTH) := PACKED_BUFFER.BYTE(INDEX1..INDEX1 + DATA_LENGTH); -- Set the TELNET Pointer RECEIVED_PACKED_BUFFER.TELNET_PTR := RECEIVED_PACKED_BUFFER.TCP_PTR + DATA_LENGTH - 1; else -- WE CURRENTLY CAN'T HANDLE THIS CASE. TCP_ERROR(8); end if; exception when others => TEXT_IO.PUT_LINE("ERROR IN INSERT TEXT INTO BUFFER."); INTEGER_IO.PUT(INDEX); INTEGER_IO.PUT(INDEX1); INTEGER_IO.PUT(LENGTH); end INSERT_TEXT_IN_BUFFER; procedure TIMEOUT_CHECK(LCN : in TCB_PTR; ACTION : out TIME_ACTION) is TIME : THIRTYTWO_BITS := THIRTYTWO_BITS(SYSTEM_TIME); RETRANS_TIME : THIRTYTWO_BITS := QUEUES.QUEUE_RETRANS_TIME(LCN); begin if TIME >= LCN.NEXT_CONNECTION_TIMEOUT then ACTION := CONNECTION_TIMEOUT; elsif TIME >= LCN.NEXT_TIME_WAIT_TIMEOUT then ACTION := TIME_WAIT_TIMEOUT; -- WE MUST CHECK THE RETRANS TIMES elsif TIME >= RETRANS_TIME then ACTION := RETRANSMIT_TIMEOUT; end if; end TIMEOUT_CHECK; procedure START_TIMER(LCN : in TCB_PTR; TIMER : in TIMER_TYPE) is -- pragma SUPPRESS(OVERFLOW_CHECK); --Note there will be a problem when local time now cycles. --this is every six hours. begin --the MSL is one minute if TIMER = TIMEOUT_TIMER then LCN.NEXT_CONNECTION_TIMEOUT := THIRTYTWO_BITS(SYSTEM_TIME) + THIRTYTWO_BITS (10) * THIRTYTWO_BITS (LCN.CONNECTION_TIMEOUT); --APPROX 2 * MSL elsif TIMER = TIME_WAIT_TIMER then LCN.NEXT_TIME_WAIT_TIMEOUT := (THIRTYTWO_BITS(SYSTEM_TIME) + THIRTYTWO_BITS (14)); --14 sec. Two more then retrans time. else --calling the retrans timer which start automatically when queued. TCP_ERROR(17); end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT_ERROR in START_TIMER"); TEXT_IO.NEW_LINE; when others => TEXT_IO.PUT_LINE("unknown error in START_TIMER"); TEXT_IO.NEW_LINE; end START_TIMER; END TCP_GLOBALS; --:::::::::::::: --tcpqueue.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01198-100(-) -- E-Systems, Inc. August 07, 1985 -- -- tcpqueue.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; with MODULO; use MODULO; with T_TCP_GLOBALS_DATA_STRUCTURES; USE T_TCP_GLOBALS_DATA_STRUCTURES; -- ************** GLOBAL ROUTINES *************** ------------------------- GLOBAL Q PACKAGE -------------------------------- package QUEUES is ---------------------------------------------------- --This implementation is for use with the DEC/Ada -- --compiler . -- ---------------------------------------------------- ------------------------------------------------------------------------------- -- This package will contain all data and routines necessary to manipulate -- -- the queues. -- ------------------------------------------------------------------------------- procedure INITIALIZE_QUEUES; --This subprogram allocates and links together in a list (pointed to by --queue_free_list) of queue elements to be used by all of the queue --routines. It allocates them via new. They are never deallocated. --They are simply put back in the free queue element list. --The max queue size times the number of queues is the number of queue --elements that are allocated. function QUEUE_EMPTY(QUEUE : in QNAME; LCN : in TCB_PTR) return BOOLEAN; --This function returns a boolean indication of whether a queue for a --specific TCB as defined by the LCN is empty. procedure QUEUE_GET( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in out STD_Q_ITEM); --This subprogram obtains a queue element from a specified queue which --passed as parameter QUEUE. If the a queue element is availible --it is loaded into ITEM. ITEM returns null in ITEM.BUFFER and zero --in ITEM.LENGTH if queue elements are empty. procedure QUEUE_DELETE( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM); --This subprogram will delete a messaged from a specified queue and --associated LCN. procedure DELETE_FROM_RETRANS_QUEUE( LCN : in TCB_PTR; SEQ_NUM : in MODULAR); --This subprogram removes a message specified by the LCN and SEQ_QUN --parameters. function QUEUE_SIZE( QUEUE : in QNAME) return SIXTEEN_BITS ; --The element count of the queue header is returned as the size of --the queue. procedure QUEUE_CLEAR( QUEUE : in QNAME; LCN : in TCB_PTR); --This subprogram clears a specified queue of all messages belonging --to the LCN parameter passed as an argument. procedure QUEUE_CLEAR(QUEUE : in QNAME); --This procedure is called to clear a queue of all its entries. --It will return all the queue structures or queue elements to the --free list. The element count is set to zero. It will also return --any buffers in the queue to the buffer free list. procedure QUEUE_ADD( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM); --This subprogram adds a message to a queue specified in the parameter --list associated with a LCN. procedure QUEUE_ADD( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM; RESULT : out BOOLEAN); --This subprogram adds a message to a queue specified in the parameter --list associated with a LCN. Parameter RESULT indicates if the --queue add was successful. procedure QUEUE_ADD_TO_FRONT( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM); --This subprogram pushes a message on a queue specified in the parameter --list with its associated LCN. function QUEUE_RETRANS_TIME(LCN : in TCB_PTR) return THIRTYTWO_BITS ; --This subprogram returns the retransmission time of the first queue --element of the TCP retransmission queue. NULL_BUFFER : PACKED_BUFFER_PTR := NULL; NULL_FLAG : BOOLEAN := TRUE; NULL_UNPACKED_BUFFER : BUFFER_POINTER; QUEUE_FREE_LIST : STD_QUEUE_ELEMENT_POINTER; -- HEAD OF QUEUE FREE LIST end QUEUES ; -----------------------------GLOBAL Q PACKAGE ---------------------------- with REAL_TIME_CLOCK_AND_DATE; use REAL_TIME_CLOCK_AND_DATE; with UNCHECKED_CONVERSION; with SYSTEM; with TEXT_IO; use TEXT_IO, INTEGER_IO; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with IP_GLOBALS ; use IP_GLOBALS ; package BODY QUEUES is procedure TCP_ERROR( ERROR_INDICATION : in ERROR_TYPE) is begin -- INCREMENT THE ERROR COUNTER. LCN.ERROR_TABLE(ERROR_INDICATION) := LCN.ERROR_TABLE(ERROR_INDICATION) + 1; end TCP_ERROR; procedure INITIALIZE_QUEUES is NEXT_STRUCTURE : STD_QUEUE_ELEMENT_POINTER; begin QUEUE_FREE_LIST := new STD_QUEUE_ELEMENT; NEXT_STRUCTURE := new STD_QUEUE_ELEMENT; QUEUE_FREE_LIST.NEXT := NEXT_STRUCTURE; for I in 2..MAX_QUEUE_SIZE*NUMBER_OF_QUEUES loop -- SET UP A FREE LIST OF QUEUE STRUCTURES. NEXT_STRUCTURE.NEXT := new STD_QUEUE_ELEMENT; NEXT_STRUCTURE := NEXT_STRUCTURE.NEXT; end loop; end INITIALIZE_QUEUES; function QUEUE_EMPTY(QUEUE : in QNAME; LCN : in TCB_PTR) return BOOLEAN is RESULT : BOOLEAN := FALSE; begin if LCN.QHEADS(QUEUE).ELEMENT_COUNT = 0 then RESULT := TRUE; end if; return RESULT; end QUEUE_EMPTY; procedure FREE_Q_STRUCTURE(Q_STRUCTURE : in out STD_QUEUE_ELEMENT_POINTER) is begin Q_STRUCTURE.NEXT := QUEUE_FREE_LIST; QUEUE_FREE_LIST := Q_STRUCTURE; --Adds to front of list Q_STRUCTURE := null; --make the pointer null now exception when constraint_error => TEXT_IO.PUT_LINE("Constraint error in FREE_Q_STRUCTURE "); TEXT_IO.PUT(ASCII.BEL); when others => TEXT_IO.PUT_LINE("unknown error raised in FREE_Q_STRUCTURE "); TEXT_IO.PUT(ASCII.BEL); end FREE_Q_STRUCTURE; procedure QUEUE_GET( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in out STD_Q_ITEM) is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); Q_ELEMENT_TO_BE_FREED : STD_QUEUE_ELEMENT_POINTER; begin if QHEAD.ELEMENT_COUNT > 0 then QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; Q_ELEMENT_TO_BE_FREED := QHEAD.FIRST_ELEMENT; -- SET UP IP ID FOR RETRANSMISSION. LCN.RETRANS_IDENT := QHEAD.FIRST_ELEMENT.IP_ID; ITEM := QHEAD.FIRST_ELEMENT.ELEMENT; QHEAD.FIRST_ELEMENT := QHEAD.FIRST_ELEMENT.NEXT; if QHEAD.ELEMENT_COUNT = 0 then -- AN EMPTY LIST QHEAD.LAST_ELEMENT := null; end if; FREE_Q_STRUCTURE(Q_ELEMENT_TO_BE_FREED); -- FREE UP THE FORMER FIRST ELEMENT else ITEM.BUFFER := null; -- AN EMPTY QUEUE ITEM.LENGTH := 0; -- AN INDICATION FOR A STANDARD BUFFER NO ENTRY EXISTS end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QGET"); when others => PUT_LINE("UNKNOWN ERROR IN QUEUE_GET"); end QUEUE_GET; procedure QUEUE_DELETE( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM) is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); BEFORE_PTR : STD_QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; CURRENT_ELEMENT_POINTER : STD_QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; FOUND : BOOLEAN := FALSE; BUFFTYPE : SIXTEEN_BITS ; begin while CURRENT_ELEMENT_POINTER /= null and (not FOUND) loop if CURRENT_ELEMENT_POINTER.ELEMENT = ITEM then -- FREE IT AND THE BUFFER UP if CURRENT_ELEMENT_POINTER.ELEMENT.BUFFER /= null then -- RETURN BUFFER TO POOL CURRENT_ELEMENT_POINTER.ELEMENT.BUFFER.STATUS := NONE; BUFFREE(CURRENT_ELEMENT_POINTER.ELEMENT.BUFFER, BUFFTYPE); end if; BEFORE_PTR.NEXT := CURRENT_ELEMENT_POINTER.NEXT; -- TAKE CARE OF DELETING FROM THE END --OR BEGINNING OF A LIST. if QHEAD.FIRST_ELEMENT = CURRENT_ELEMENT_POINTER then QHEAD.FIRST_ELEMENT := CURRENT_ELEMENT_POINTER.NEXT; end if; if QHEAD.LAST_ELEMENT = CURRENT_ELEMENT_POINTER then -- WE ARE DELETING LAST ELEMENT. if QHEAD.FIRST_ELEMENT /= null then QHEAD.LAST_ELEMENT := BEFORE_PTR; else -- AN EMPTY LIST NOW QHEAD.LAST_ELEMENT := null; end if; end if; -- FREE THE ELEMENT AND DECREMENT THE ELEMENT COUNT FREE_Q_STRUCTURE(CURRENT_ELEMENT_POINTER); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; FOUND := TRUE; else BEFORE_PTR := CURRENT_ELEMENT_POINTER; CURRENT_ELEMENT_POINTER := CURRENT_ELEMENT_POINTER.NEXT; end if; end loop; if not FOUND then --ERROR TCP_ERROR(11); end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QUEUE DELETE"); when others => PUT_LINE(" ERROR IN QUEUE DELETE"); end QUEUE_DELETE; procedure DELETE_FROM_RETRANS_QUEUE( LCN : in TCB_PTR; SEQ_NUM : in MODULAR) is type FOUR_BYTES is array(1..4) of SYSTEM.BYTE ; type ONELONG is array(1..1) of THIRTYTWO_BITS ; function CONVERT is new UNCHECKED_CONVERSION(FOUR_BYTES, ONELONG); SEARCH_NUM : MODULAR := SEQ_NUM - 1; -- WE GOT IN SND_UNA AND WILL TAKE OFF -- EVERTHING THAT IS SND_UNA - 1 OR LESS. SEQUENCE_NUM : MODULAR; PACKED_BUFFER : PACKED_BUFFER_PTR; TEMP : FOUR_BYTES; RESULT : ONELONG; DATA_LENGTH, DATA_OFFSET, INDEX : SIXTEEN_BITS ; QHEAD : STD_HEAD_PTR renames LCN.QHEADS(TCP_RETRANSMIT_QUEUE); TEMP_PTR : STD_QUEUE_ELEMENT_POINTER; BEFORE_PTR : STD_QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; CURRENT_ELEMENT_POINTER : STD_QUEUE_ELEMENT_POINTER := QHEAD.FIRST_ELEMENT; begin while CURRENT_ELEMENT_POINTER /= null loop -- TAKE ANYTHING WE CAN OFF OF THE QUEUE. PACKED_BUFFER := CURRENT_ELEMENT_POINTER.ELEMENT.BUFFER; -- GET THE DATA OFFSET. INDEX := PACKED_BUFFER.TCP_PTR + 12; DATA_OFFSET := SIXTEEN_BITS ( PACKED_BUFFER.BYTE ( INDEX ) ) / 2**4 ; -- GET THE SEQUENCE NUMBER INDEX := PACKED_BUFFER.TCP_PTR - 1; for I in 1..4 loop TEMP(I) := PACKED_BUFFER.BYTE ( INDEX + SIXTEEN_BITS ( 5 - I ) + 4) ; -- GET THE SEQ NUMBER end loop; -- INITIALIZE RESULT RESULT(1) := 0; RESULT := CONVERT(TEMP); -- CONVERT IT TO A LONG INTEGER SEQUENCE_NUM := MODULAR_CONVERT(RESULT(1)); -- MAKE IT MODULAR -- GET THE DATA LENGTH DATA_LENGTH := CURRENT_ELEMENT_POINTER.ELEMENT.LENGTH - DATA_OFFSET * 4; if DATA_LENGTH > 0 then -- SINCE WE NEVER SEND DATA WITH A SYN --OR A FIN( WHICH ARE CONSIDERED DATA -- OCTETS, THE DATA LENGTH IN ADDITION TO THE --SEQ NUM IS ONE LESS THAN THE -- ACTUAL NUMBER OF DATA OCTETS. DATA_LENGTH := DATA_LENGTH - 1; end if; --PUT_LINE("IN RETRANS DELETE");--- DEBUG --LONG_INTEGER_IO.PUT(LONG(SEARCH_NUM)); -- INTEGER_IO.PUT(LCN); -- PUT_LINE("THE PACKED BUFFER POINTER AND DATA OFFSET ARE"); -- INTEGER_IO.PUT(PACKED_BUFFER.TCP_PTR); -- INTEGER_IO.PUT(DATA_OFFSET); --PUT_LINE("THE SEQUENCE NUMBER AND DATA LENGTH ARE "); --LONG_INTEGER_IO.PUT(RESULT(1)); --INTEGER_IO.PUT(DATA_LENGTH); if SEQUENCE_NUM + DATA_LENGTH <= SEARCH_NUM then -- DELETE THIS QUEUE ELEMENT. --TEXT_IO.PUT_LINE("DELETEING FROM RETRANS QUEUE"); BEFORE_PTR.NEXT := CURRENT_ELEMENT_POINTER.NEXT; -- TAKE CARE OF DELETING FROM THE END OR BEGINNING OF A LIST. if QHEAD.FIRST_ELEMENT = CURRENT_ELEMENT_POINTER then QHEAD.FIRST_ELEMENT := CURRENT_ELEMENT_POINTER.NEXT; end if; if QHEAD.LAST_ELEMENT = CURRENT_ELEMENT_POINTER then -- WE ARE DELETING LAST ELEMENT. if QHEAD.FIRST_ELEMENT /= null then QHEAD.LAST_ELEMENT := BEFORE_PTR; else -- AN EMPTY LIST NOW QHEAD.LAST_ELEMENT := null; end if; end if; TEMP_PTR := BEFORE_PTR.NEXT; -- THE NEXT ELEMENT TO BE CHECKED -- FREE UP THE ELEMENT AND DECREMENT THE QUEUE COUNT. FREE_Q_STRUCTURE(CURRENT_ELEMENT_POINTER); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; -- FREE UP THE BUFFER PACKED_BUFFER.STATUS := NONE; BUFFREE(PACKED_BUFFER, 1); -- UPDATE CURRENT_ELEMENT_POINTER TO POINT AT THE --NEXT ELEMENT TO BE CHECKED. CURRENT_ELEMENT_POINTER := TEMP_PTR; else -- ADVANCE THE POINTERS. --TEXT_IO.PUT_LINE("DID NOT DELETE FROM RETRANS QUEUE"); BEFORE_PTR := CURRENT_ELEMENT_POINTER; CURRENT_ELEMENT_POINTER := CURRENT_ELEMENT_POINTER.NEXT; end if; end loop; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN DELETE FROM RETRANS QUEUE"); -- PUT("THE LCN IS "); -- INTEGER_IO.PUT(LCN); TEXT_IO.PUT_LINE(""); TEXT_IO.PUT("INDEX VALUE IS "); INTEGER_IO.PUT(INDEX); INTEGER_IO.PUT(PACKED_BUFFER.TCP_PTR); if CURRENT_ELEMENT_POINTER = null then TEXT_IO.PUT_LINE("A NULL CURRENT ELEMENT POINTER."); end if; if BEFORE_PTR.NEXT = null then TEXT_IO.PUT_LINE("A NULL BEFORE POINTER NEXT FIELD"); end if; if PACKED_BUFFER = null then TEXT_IO.PUT_LINE("A NULL PACKED BUFFER ON THE RETRANS QUEUE"); end if; when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR IN DELETE FROM RETRANS QUEUE"); end DELETE_FROM_RETRANS_QUEUE; function QUEUE_SIZE( QUEUE : in QNAME) return SIXTEEN_BITS is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); begin return QHEAD.ELEMENT_COUNT; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR in QUEUE_SIZE"); when others => TEXT_IO.PUT_LINE("unknown error in QUEUE_SIZE"); end QUEUE_SIZE; procedure QUEUE_CLEAR( QUEUE : in QNAME) is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); X : STD_QUEUE_ELEMENT_POINTER; BUFFTYPE : SIXTEEN_BITS ; begin while QHEAD.ELEMENT_COUNT > 0 loop X := QHEAD.FIRST_ELEMENT; if X.ELEMENT.BUFFER /= null then if X.ELEMENT.BUFFER.STATUS =OWNER_TCP then -- if it is ours, -- it is no longer. X.ELEMENT.BUFFER.STATUS := BUFFER_DATA.NONE; end if; BUFFREE(X.ELEMENT.BUFFER, BUFFTYPE); end if; QHEAD.FIRST_ELEMENT := X.NEXT; FREE_Q_STRUCTURE(X); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; end loop; -- reset the head and tail pointers QHEAD.FIRST_ELEMENT := null; QHEAD.LAST_ELEMENT := null; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE(" CONSTRAINT ERROR IN QUEUE CLEAR"); when others => TEXT_IO.PUT_LINE(" UNKNOWN ERROR TYPE IN QUEUE CLEAR"); end QUEUE_CLEAR; procedure QUEUE_CLEAR( QUEUE : in QNAME; LCN : in TCB_PTR) is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); X : STD_QUEUE_ELEMENT_POINTER; BUFFTYPE : SIXTEEN_BITS ; begin while QHEAD.ELEMENT_COUNT > 0 loop X := QHEAD.FIRST_ELEMENT; if X.ELEMENT.BUFFER /= null then X.ELEMENT.BUFFER.STATUS := NONE; BUFFREE(X.ELEMENT.BUFFER, BUFFTYPE); end if; QHEAD.FIRST_ELEMENT := X.NEXT; FREE_Q_STRUCTURE(X); QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT - 1; end loop; -- RESET THE HEAD AND TAIL POINTERS. QHEAD.FIRST_ELEMENT := null; QHEAD.LAST_ELEMENT := null; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN QUEUE CLEAR"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR TYPE IN QUEUE CLEAR"); end QUEUE_CLEAR; function GET_Q_STRUCTURE return STD_QUEUE_ELEMENT_POINTER is X : STD_QUEUE_ELEMENT_POINTER; begin X := QUEUE_FREE_LIST; QUEUE_FREE_LIST := QUEUE_FREE_LIST.NEXT; return X; exception when constraint_error => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN GET_Q_STRUCTURE"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR RAISED IN GET_Q_STRUCTURE"); end GET_Q_STRUCTURE; procedure QUEUE_ADD( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM) is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); NEW_ITEM : STD_QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; begin NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if QUEUE = TCP_RETRANSMIT_QUEUE then -- PUT ON A TIME FOR THE RETRANS QUEUE --TEXT_IO.PUT("THE POINTER ON QUEUE ADD AND LCN IS "); -- TESTING -- INTEGER_IO.PUT(ITEM.BUFFER.TCP_PTR); -- INTEGER_IO.PUT(LCN); -- PUT_LINE(""); NEW_ITEM.TIME := THIRTYTWO_BITS ( SYSTEM_TIME ) ; NEW_ITEM.IP_ID := LCN.IDENT; -- SAVE THE ID FOR IP. end if; if QHEAD.ELEMENT_COUNT < MAX_QUEUE_SIZE then if QHEAD.ELEMENT_COUNT /= 0 then -- ITS NOT AN EMPTY QUEUE. SO LINK FORMER -- LAST ITEM TO NEW ONE. QHEAD.LAST_ELEMENT.NEXT := NEW_ITEM; else -- FIRST ADD TO THE QUEUE QHEAD.FIRST_ELEMENT := NEW_ITEM; end if; QHEAD.LAST_ELEMENT := NEW_ITEM; QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT + 1; else -- NO ROOM TOO BAD TCP_ERROR(18); FREE_Q_STRUCTURE(NEW_ITEM); end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN QUEUE ADD"); when others => TEXT_IO.PUT_LINE("ERROR IN QADD"); -- INTEGER_IO.PUT(LCN); INTEGER_IO.PUT(QHEAD.ELEMENT_COUNT); end QUEUE_ADD; procedure QUEUE_ADD( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM; RESULT : out BOOLEAN) is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); NEW_ITEM : STD_QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; begin NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if QUEUE = TCP_RETRANSMIT_QUEUE then -- PUT ON A TIME FOR THE RETRANS QUEUE -- PUT("THE POINTER ON QUEUE ADD AND LCN IS "); -- TESTING -- INTEGER_IO.PUT(ITEM.BUFFER.TCP_PTR); -- INTEGER_IO.PUT(LCN); -- PUT_LINE(""); NEW_ITEM.TIME := THIRTYTWO_BITS ( SYSTEM_TIME ) ; NEW_ITEM.IP_ID := LCN.IDENT; -- SAVE THE ID FOR IP. end if; if QHEAD.ELEMENT_COUNT < MAX_QUEUE_SIZE then if QHEAD.ELEMENT_COUNT /= 0 then -- ITS NOT AN EMPTY QUEUE. SO LINK FORMER -- LAST ITEM TO NEW ONE. QHEAD.LAST_ELEMENT.NEXT := NEW_ITEM; else --FIRST ELEMENT IN QUEUE QHEAD.FIRST_ELEMENT := NEW_ITEM; end if; QHEAD.LAST_ELEMENT := NEW_ITEM; QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT + 1; RESULT := FALSE; else -- NO ROOM TOO BAD. -- PUT QUEUE STRUCTURE BACK ON THE FREE LIST. TCP_ERROR(18); FREE_Q_STRUCTURE(NEW_ITEM); RESULT := TRUE; end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN "); TEXT_IO.PUT_LINE("QUEUE ADD, WITH RESULT INDICATION."); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR TYPE IN "); TEXT_IO.PUT_LINE("QUEUE ADD, WITH RESULT INDICATION."); end QUEUE_ADD; procedure QUEUE_ADD_TO_FRONT( QUEUE : in QNAME; LCN : in TCB_PTR; ITEM : in STD_Q_ITEM) is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(QUEUE); NEW_ITEM : STD_QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; -- GET A QUEUE STRUCTURE FROM FREE LIST. begin NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if QHEAD.ELEMENT_COUNT < MAX_QUEUE_SIZE then NEW_ITEM.NEXT := QHEAD.FIRST_ELEMENT; QHEAD.FIRST_ELEMENT := NEW_ITEM; if QHEAD.ELEMENT_COUNT = 0 then -- ADDING TO AN EMPTY LIST QHEAD.LAST_ELEMENT := NEW_ITEM; end if; QHEAD.ELEMENT_COUNT := QHEAD.ELEMENT_COUNT + 1; else -- A MAJOR PROBLEM SHOULDN'T HAPPEN TCP_ERROR(18); FREE_Q_STRUCTURE(NEW_ITEM); -- FREE QUEUE STRUCTURE ANYWAY. TEXT_IO.PUT_LINE("NO ROOM FOR QUEUE ADD TO FRONT IN TCP"); end if; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN QUEUE ADD TO FRONT"); when others => TEXT_IO.PUT_LINE("UNKNOWN ERROR TYPE IN QUEUE ADD TO FRONT"); end QUEUE_ADD_TO_FRONT; function QUEUE_RETRANS_TIME( LCN : in TCB_PTR) return THIRTYTWO_BITS is QHEAD : STD_HEAD_PTR renames LCN.QHEADS(TCP_RETRANSMIT_QUEUE); begin RETURN QHEAD.FIRST_ELEMENT.TIME; end QUEUE_RETRANS_TIME; begin INITIALIZE_QUEUES ; end QUEUES; --:::::::::::::: --tcputil.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01199-100(-) -- E-Systems, Inc. August 07, 1985 -- -- tcputil.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE ; use WITH_TCP_COMMUNICATE ; with MODULO; use MODULO; with BUFFER_DATA; use BUFFER_DATA; -- COMMUNICATE AND QUEUE CONTAINS THE NECESSARY FACILITIES FOR MESSAGES TO BE -- QUEUED BETWEEN TASKS. with T_TCP_GLOBALS_DATA_STRUCTURES; USE T_TCP_GLOBALS_DATA_STRUCTURES; package T_TCP_CONTROLLER_UTILITIES is -------------------------------------------------------------------- --This implementation is for use with the DEC/Ada compiler -- --version . -- -------------------------------------------------------------------- function USER_ACCESS_CHECK( LCN : in TCB_PTR) return BOOLEAN; procedure SEND_A_SYN( LCN : in TCB_PTR); procedure TCP_SEND( LCN : in TCB_PTR; PACKED_BUFF : in out PACKED_BUFFER_PTR; BUFFLEN, PUSH_FLAG, URG_FLAG, TIMEOUT : in SIXTEEN_BITS ); procedure TCP_RECEIVE( LCN : in TCB_PTR; PACKED_BUFF : in out PACKED_BUFFER_PTR; BYTE_COUNT : in SIXTEEN_BITS ); procedure TCP_ABORT( LCN : in TCB_PTR); procedure TCP_CLOSE( LCN : in TCB_PTR); procedure TCP_OPEN(LOCAL_PORT, FOREIGN_PORT :in SIXTEEN_BITS ; FOREIGN_NET_HOST : in THIRTYTWO_BITS ; ACTIVE_PASSIVE : in WITH_TCP_COMMUNICATE.ACKPASS; BUFFER_SIZE, TIMEOUT : in SIXTEEN_BITS ; LOCAL_CONN_NAME : in out TCB_PTR ; SECURITY, PRECEDENCE : in SIXTEEN_BITS ; OPTIONS : in TCP_OPTION_TYPE); procedure TCP_STATUS(LCN : in TCB_PTR); procedure RETRANS_TCP(LCN : in TCB_PTR); end T_TCP_CONTROLLER_UTILITIES; with SYSTEM; with TEXT_IO; use TEXT_IO; with UNCHECKED_CONVERSION; -- COMMUNICATE AND QUEUE CONTAINS THE NECESSARY FACILITIES FOR MESSAGES TO BE -- QUEUED BETWEEN TASKS. with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with TCP_GLOBALS; use TCP_GLOBALS; with QUEUES; use QUEUES; with TCP_SEGMENT_ARRIVES_PROCESSING; use TCP_SEGMENT_ARRIVES_PROCESSING; with IP_GLOBALS; use IP_GLOBALS; with TCB_ALLOCATOR; use TCB_ALLOCATOR; with WITH_ULP_COMMUNICATE; use WITH_ULP_COMMUNICATE; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; with T_tcp_utilities_1 ; package body T_TCP_CONTROLLER_UTILITIES is function USER_ACCESS_CHECK( LCN : in TCB_PTR) return BOOLEAN is RESULT : BOOLEAN := TRUE; I : TCB_PTR := OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; -- THE BEGINNING INDEX INTO THE LCN LIST! begin while I /= null and RESULT loop if I = LCN then RESULT := FALSE; end if; I := I.NEXT; end loop; return RESULT; exception when OTHERS => PUT("PROBLEM IN USER ACCESS CHECK"); end USER_ACCESS_CHECK; procedure SEND_A_SYN( LCN : in TCB_PTR) is --This subprogram is called by the TCP_OPEN and the TCP_SEND in the --listen state to send out a SYN. The LCN is passed to the subprogram --to calculate the appropiate address. This subprogram will format --and send a SYN segment to the IP for transmission to the remote host. HEADER_LENGTH : SIXTEEN_BITS := 20; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; DEST : THIRTYTWO_BITS ; SOURCE : THIRTYTWO_BITS ; PACKED_BUFF : PACKED_BUFFER_PTR; BUFFLEN : SIXTEEN_BITS ; -- TEMPORARY Q_ITEM : STD_Q_ITEM; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin BUFFGET(PACKED_BUFF, BUFFLEN); if PACKED_BUFF = null then -- TELL USER -- ERROR: INSUFFICIENT RESOURCES SOCKET_PARAMS := LCN; UMESSAGE := ( 1, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFF.IN_USE := TRUE; PACKED_BUFF.STATUS := OWNER_TCP; LCN.ISS := MODULAR_CONVERT(ISS);--GET AN INTIAL SEND SEQUENCE NUMBER --(ISS) LCN.SND_NXT := LCN.ISS;-- SET UP THE INITIAL SEND NEXT. TYPE_FLAG := SYN; OPTIONS := CLEAR;--CLEAR THE OPTIONS ARRAY --ADD ANY OPTIONS TO HEADER LENGTH HERE TCP_HEADER_FORMAT( LCN, BUFPTR, TYPE_FLAG, OPTIONS); DEST := LCN.DESTINATION_ADDRESS; -- HERE WE MUST PUT IN THE NECESSARY SECURITY OPTIONS FOR IP. OPTIONS := TCP_SECURITY_OPTIONS; PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFF);-- PACK THE BUFFER SOURCE := IP_GLOBALS.WHOIAM; SEND_IP( SOURCE, DEST, TOS, TTL, PACKED_BUFF, HEADER_LENGTH, IDENT, DONT_FRAGMENT, OPTIONS, RESULT); -- UPDATE SEND UNACKNOWLEDGED AND SND_NXT. LCN.SND_UNA := LCN.ISS; LCN.SND_NXT := LCN.ISS + MODULAR_CONVERT(SIXTEEN_BITS(1)); -- SAME AS SEND NEXT + 1 -- PUT BUFFER ON RETRANSMIT QUEUE WITH THE LENGTH IN OCTETS. Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, HEADER_LENGTH); -- IT IS QUEUED UP WITH A TIME. QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); end if; end SEND_A_SYN; procedure TCP_SEND(LCN : in TCB_PTR; PACKED_BUFF : in out PACKED_BUFFER_PTR; BUFFLEN, PUSH_FLAG,URG_FLAG,TIMEOUT : in SIXTEEN_BITS ) is --This subprogram is called by the TCP controller to process a users send --request. This subprogram will format the header and pass the buffer on to --the IP for transmission. --The following parameters are passed to the subprogram: -- LCN -- Buffer length -- PUSH_FLAG : An indication of whether all data should be pushed through. -- URG_FLAG : An indication of the urgency of the data. -- (1 URGENT, 0 NORMAL). -- TIMEOUT : The timeout interval for a connection. timeout occurs if -- there is no response for that amount of time. -- PACKED_BUFF : A packed buffer with user data. -- NULL_FLAG, NO_ROOM_ON_QUEUE : BOOLEAN; BUFFSIZE : SIXTEEN_BITS ; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; Q_ITEM : STD_Q_ITEM; SEGMENT_LENGTH : SIXTEEN_BITS := 255 - PACKED_BUFF.TCP_PTR; -- CORRECT UNTIL SIZE CHANGES UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin T_TCP_GLOBALS_DATA_STRUCTURES.LCN := LCN; -- FOR TEST*** if TIMEOUT /= 0 then -- PUT IN THE NEW CONNECTION TIMEOUT. LCN.CONNECTION_TIMEOUT := TIMEOUT; end if; case LCN.STATE is when CLOSED => if USER_ACCESS_CHECK(LCN) then -- TELL USER -- ERROR: CONNECTION ILLEGAL FOR THIS PROCESS SOCKET_PARAMS := LCN; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER -- ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS := LCN; UMESSAGE := ( 3, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; when T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN => if FOREIGN_SOCKET_UNSPECIFIED(LCN) then -- TELL USER -- ERROR: FOREIGN SOCKET UNSPECIFIED SOCKET_PARAMS := LCN; UMESSAGE := ( 4, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TCB STATE BECOMES ACTIVE LCN.ACTIVE_PASSIVE := ACTIVE; -- PUT ANY TEXT ON THE TEXT TRANSMIT QUEUE FOR LATER TRANSMISSION if BUFFLEN > 0 then -- THERE IS DATA. Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, BUFFLEN); QUEUE_ADD(TRANSMIT_QUEUE, LCN, Q_ITEM, NO_ROOM_ON_QUEUE); if NO_ROOM_ON_QUEUE then -- TELL USER OR ERROR ROUTINE -- ERROR: INSUFFICIENT RESOURCES PUT_LINE("STATE IS LISTEN");--DEBUG PUT_LINE("NO Q RM IN SEND");-- DEBUG SOCKET_PARAMS := LCN; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; end if; -- SEND OUT A SYN SEND_A_SYN(LCN); -- PUT TCB INTO SYN_SENT STATE. LCN.STATE := SYN_SENT; end if; when SYN_SENT | SYN_RECEIVED => -- PUT THE TEXT ON THE TRANSMIT QUEUE FOR LATER TRANSMISSION if BUFFLEN > 0 then -- THERE IS DATA. Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, BUFFLEN); QUEUE_ADD(TRANSMIT_QUEUE, LCN, Q_ITEM, NO_ROOM_ON_QUEUE); if NO_ROOM_ON_QUEUE then -- TELL USER -- ERROR: INSUFFICIENT RESOURCES PUT_LINE("NO Q RM IN SEND");-- DEBUG PUT_LINE("STATE IS SYN SENT OR SYN RECEIVED");--DEBUG SOCKET_PARAMS := LCN; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; end if; when ESTABLISHED | CLOSE_WAIT => -- HERE WE WOULD SEGMENTIZE A BUFFER FOR TRANSMISSON, WHICH WE -- ARE CURRENTLY NOT DOING. if LCN.SND_WND + LCN.SND_UNA >= (LCN.SND_NXT + SEGMENT_LENGTH) then -- USE THE SAME BUFFER ALL THE WAY TYPE_FLAG := SEGMENT; -- PUT THE DATA IN THE BUFFER for I in 1..SEGMENT_LENGTH loop BUFPTR.DATA(I) := PACKED_BUFF.BYTE(PACKED_BUFF.TCP_PTR+I); end loop; BUFPTR.DATA_LEN := SEGMENT_LENGTH; -- CLEAR OPTIONS ARRAY OPTIONS := CLEAR; TCP_HEADER_FORMAT(LCN, BUFPTR, TYPE_FLAG, OPTIONS); -- HERE WE MUST PUT IN THE NECESSARY SECURITY OPTIONS FOR IP. OPTIONS := TCP_SECURITY_OPTIONS; -- PACK THE BUFFER -- WE ASSUME THAT THE POINTER IS CORRECTLY SET. PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFF); -- THE STANDARD HEADER LENGTH + DATA LENGTH LEN := BUFPTR.DATA_OFFSET * 4 + SEGMENT_LENGTH; PACKED_BUFF.STATUS := OWNER_TCP; SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFF, LEN, IDENT, DONT_FRAGMENT, OPTIONS, RESULT); -- PUT BUFFER IN RETRANSMISSION QUEUE AND SET THE TIMER -- LEN IS THE TOTAL NUM OF BYTES IN THE SEGMENT. Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, LEN); -- TESTING QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); -- WECOULD MESS WITH OUR RECEIVE WINDOW HERE IF WE WISHED. LCN.SND_NXT := LCN.SND_NXT + SEGMENT_LENGTH; if URG_FLAG = BIT_SET then LCN.SND_UP := LCN.SND_NXT - 1; end if; else -- PUT THE TEXT ON THE TRANSMIT QUEUE FOR PROCESSING WHEN AN ACK COMES -- IN AND WE CAN SEND IT. Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, SEGMENT_LENGTH); QUEUE_ADD(TRANSMIT_QUEUE, LCN, Q_ITEM, NO_ROOM_ON_QUEUE); if NO_ROOM_ON_QUEUE then --TELL USER ERROR: INSUFFICIENT RESOURCES PUT_LINE("NO Q RM IN SEND");-- DEBUG PUT_LINE("STATE IS ESTAB");--DEBUG --INT_IO_16.PUT(SEGMENT_LENGTH); SOCKET_PARAMS:= LCN; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; end if; when others => -- TELL USER ERROR: CONNECTION CLOSING SOCKET_PARAMS := LCN; UMESSAGE :=( 6, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end case; end TCP_SEND; procedure TCP_RECEIVE( LCN : in TCB_PTR; PACKED_BUFF : in out PACKED_BUFFER_PTR; BYTE_COUNT : in SIXTEEN_BITS ) is --This subprogram is called by the user via the TCP controller. --it will queue the request or if there is data to satisfy it, return --a buffer full of data if one is available. Otherwise it will simply --queue the request until data becomes available. The subprogram is --passed a LCN, BYTE_COUNT which represents the size of the buffer if --one is passed in, and PACKED_BUFF that contains the data to be --returned to the user. RECEIVE_QUEUE_FULL : BOOLEAN; PACKED_BUFFER : PACKED_BUFFER_PTR; BUFFTYPE, PROCESSED_BYTE_COUNT : SIXTEEN_BITS ; Q_ITEM : STD_Q_ITEM; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; begin T_TCP_GLOBALS_DATA_STRUCTURES.LCN := LCN; -- FOR TEST*** -- ALL RECEIVE REQUESTS THAT WE CAN HANDLE WILL BE SATISIFIED OR QUEUED -- ON THE TCP RECEIVE QUEUE FOR LATER PROCESSING WHEN DATA COMES IN. case LCN.STATE is when T_TCP_GLOBALS_DATA_STRUCTURES.CLOSED => if USER_ACCESS_CHECK(LCN) then -- TELL USER ERROR: CONNECTION ILLEGAL FOR THIS PROCESS SOCKET_PARAMS:= LCN; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS := LCN; UMESSAGE := ( 3, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; when T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN | SYN_SENT | SYN_RECEIVED => -- PUT REQUEST ON QUEUE FOR LATER PROCESSING Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, BYTE_COUNT); QUEUE_ADD(RECEIVE_QUEUE, LCN, Q_ITEM, RECEIVE_QUEUE_FULL); if RECEIVE_QUEUE_FULL then -- TELL USER ERROR: INSUFFICIENT RESOURCES PUT_LINE("NO Q RM IN RECEIVE");-- DEBUG SOCKET_PARAMS := LCN; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; when ESTABLISHED | FIN_WAIT_1 | FIN_WAIT_2 => -- NOTE THAT WE CONSIDER ANY DATA TO BE SUFFICIENT DATA FOR A BUFFER. -- WE DO NOTHING WITH THE PUSH FLAG SINCE WE CURRENTLY PUSH EVERYTHING. -- ALSO WE MAKE NO PROVISION FOR URGENT DATA AND DO NOT CHECK FOR IT. -- GET A BUNCH OF DATA IF WE CAN. QUEUE_GET(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN, Q_ITEM); PROCESSED_BYTE_COUNT := Q_ITEM.LENGTH; PACKED_BUFFER := Q_ITEM.BUFFER; if PACKED_BUFFER = null then -- PUT REQUEST ON QUEUE FOR LATER PROCESSING Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, BYTE_COUNT); QUEUE_ADD(RECEIVE_QUEUE, LCN, Q_ITEM, RECEIVE_QUEUE_FULL); if RECEIVE_QUEUE_FULL then -- TELL USER ERROR: INSUFFICIENT RESOURCES PUT_LINE("NO Q RM IN SEND");-- DEBUG SOCKET_PARAMS := LCN; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; else -- FILL BUFFER WITH QUEUED INCOMING SEGMENTS INSERT_TEXT_IN_BUFFER(BYTE_COUNT, PACKED_BUFF, PROCESSED_BYTE_COUNT, PACKED_BUFFER); -- WE IGNORE A PUSH; WE IGNORE URGENT POINTER -- GIVE THE BUFFER TO THE USER SOCKET_PARAMS := LCN; UMESSAGE := ( 10, SOCKET_PARAMS, PACKED_BUFF); MESSAGE_FOR_USER(UMESSAGE); -- FREE UP THE PACKED BUFFER PACKED_BUFFER.STATUS := NONE; PACKED_BUFFER.IN_USE := FALSE; BUFFREE(PACKED_BUFFER, BUFFTYPE); end if; when CLOSE_WAIT => QUEUE_GET(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN, Q_ITEM); PROCESSED_BYTE_COUNT := Q_ITEM.LENGTH; PACKED_BUFFER := Q_ITEM.BUFFER; if PACKED_BUFFER = null then -- ERROR: CONNECTION CLOSING SOCKET_PARAMS := LCN; UMESSAGE := ( 6, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- FILL BUFFER WITH ANY REMAINING TEXT INSERT_TEXT_IN_BUFFER(BYTE_COUNT, PACKED_BUFF, PROCESSED_BYTE_COUNT, PACKED_BUFFER); -- RETURN BUFFER TO USER SOCKET_PARAMS := LCN; UMESSAGE := ( 10, SOCKET_PARAMS, PACKED_BUFF); MESSAGE_FOR_USER(UMESSAGE); -- FREE UP THE PACKED BUFFER PACKED_BUFFER.IN_USE := FALSE; PACKED_BUFFER.STATUS := NONE; BUFFREE(PACKED_BUFFER, BUFFTYPE); end if; when CLOSING | TIME_WAIT | LAST_ACK => -- TELL USER ERROR: CONNECTION CLOSING SOCKET_PARAMS := LCN; UMESSAGE := ( 6, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end case; exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN TCP RECEIVE"); when others => PUT_LINE("ERROR IN TCP RECEIVE"); end TCP_RECEIVE; procedure TCP_ABORT( LCN : in TCB_PTR) is --This subprogram is called by the user via the TCP controller to --abort a connection. It does this by sending a reset to the remote --host and clearing the TCB associated with the particular local --connection name. All queues will have the items from this connection --removed from them. USER_SHOULD_NOT_HAVE_ACCESS : BOOLEAN; BUFFLEN : SIXTEEN_BITS ; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; PACKED_BUFF : PACKED_BUFFER_PTR; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin T_TCP_GLOBALS_DATA_STRUCTURES.LCN := LCN; -- FOR TEST*** case LCN.STATE is when T_TCP_GLOBALS_DATA_STRUCTURES.CLOSED => if USER_ACCESS_CHECK(LCN) then -- TELL USER ERROR: CONNECTION ILLEGAL FOR THIS PROCESS SOCKET_PARAMS := LCN; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS := LCN; UMESSAGE := ( 3, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; when T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN => QUEUE_CLEAR(RECEIVE_QUEUE, LCN); -- CLEAR THE TCB AND ENTER THE CLOSED STATE LCN.STATE := CLOSED; TCB_CLEAR(LCN); when SYN_SENT => QUEUE_CLEAR(RECEIVE_QUEUE, LCN); -- NONE ON THIS LEVEL. CLEAR_SEND_QUEUE(LCN); -- CLEAR THE TCB AND ENTER THE CLOSED STATE QUEUE_CLEAR(TCP_RETRANSMIT_QUEUE, LCN); QUEUE_CLEAR(TRANSMIT_QUEUE, LCN); TCB_CLEAR(LCN); when SYN_RECEIVED | ESTABLISHED | FIN_WAIT_1 | FIN_WAIT_2 | CLOSE_WAIT => -- SEND A RESET SEGMENT BUFFGET(PACKED_BUFF, BUFFLEN); if PACKED_BUFF = null then -- ERROR OUT OF BUFFERS TCP_ERROR(1); else PACKED_BUFF.STATUS := NONE; PACKED_BUFF.IN_USE := TRUE; TCP_HEADER_FORMAT( LCN, BUFPTR, RST, OPTIONS); -- HERE WE MUST PUT IN THE NECESSARY SECURITY OPTIONS FOR IP. OPTIONS := TCP_SECURITY_OPTIONS; -- PACK THE BUFFER PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFF); LEN := BUFPTR.DATA_OFFSET * 4;-- SINCE NO DATA SENT SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFF, LEN, IDENT, DONT_FRAGMENT, OPTIONS, RESULT); end if; QUEUE_CLEAR(RECEIVE_QUEUE, LCN); -- NONE ON THIS LEVEL. CLEAR_SEND_QUEUE(LCN); -- TRASH TRANSMIT AND RETRANSMIT QUEUES QUEUE_CLEAR(TRANSMIT_QUEUE, LCN); QUEUE_CLEAR(TCP_RETRANSMIT_QUEUE, LCN); QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN); -- CLEAR THE TCB AND ENTER THE CLOSED STATE LCN.STATE := CLOSED; TCB_CLEAR(LCN); when CLOSING | LAST_ACK | TIME_WAIT => -- TELL USER OK SOCKET_PARAMS := LCN; UMESSAGE := ( 8, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); -- CLEAR THE TCB AND ENTER THE CLOSED STATE QUEUE_CLEAR(RECEIVE_QUEUE, LCN); TCB_CLEAR(LCN); -- PUT IN A KNOWN STATE end case; end TCP_ABORT; procedure TCP_CLOSE( LCN : in TCB_PTR) IS BEGIN -- REQUIRED TO REDUCE FILE SIZE T_tcp_utilities_1.tcp_close (LCN ) ; END TCP_CLOSE ; procedure TCP_OPEN(LOCAL_PORT, FOREIGN_PORT :in SIXTEEN_BITS ; FOREIGN_NET_HOST : in THIRTYTWO_BITS ; ACTIVE_PASSIVE : in WITH_TCP_COMMUNICATE.ACKPASS; BUFFER_SIZE, TIMEOUT : in SIXTEEN_BITS ; LOCAL_CONN_NAME : in out TCB_PTR ; SECURITY, PRECEDENCE : in SIXTEEN_BITS ; OPTIONS : in TCP_OPTION_TYPE) IS BEGIN -- REQUIRED TO REDUCE FILE SIZE T_tcp_utilities_1.tcp_open (local_port, foreign_port, foreign_net_host, active_passive, buffer_size,timeout, local_conn_name, security, precedence, options) ; END tcp_open ; procedure TCP_STATUS(LCN : in TCB_PTR) IS BEGIN -- REQUIRED TO REDUCE FILE SIZE T_tcp_utilities_1.tcp_status (LCN) ; END tcp_status ; procedure RETRANS_TCP(LCN : in TCB_PTR) IS BEGIN -- REQUIRED TO REDUCE FILE SIZE T_tcp_utilities_1.retrans_tcp (LCN) ; END retrans_tcp ; end T_TCP_CONTROLLER_UTILITIES; --:::::::::::::: --tcputil1.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01200-100(-) -- E-Systems, Inc. August 07, 1985 -- -- tcputil1.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE ; use WITH_TCP_COMMUNICATE ; with MODULO; use MODULO; with BUFFER_DATA; use BUFFER_DATA; -- COMMUNICATE AND QUEUE CONTAINS THE NECESSARY FACILITIES FOR MESSAGES TO BE -- QUEUED BETWEEN TASKS. with T_TCP_GLOBALS_DATA_STRUCTURES; USE T_TCP_GLOBALS_DATA_STRUCTURES; package T_TCP_UTILITIES_1 is -------------------------------------------------------------------- --This implementation is for use with the TeleSoft/Ada compiler -- --version . -- -------------------------------------------------------------------- procedure TCP_CLOSE( LCN : in TCB_PTR); procedure TCP_OPEN(LOCAL_PORT, FOREIGN_PORT :in SIXTEEN_BITS ; FOREIGN_NET_HOST : in THIRTYTWO_BITS ; ACTIVE_PASSIVE : in WITH_TCP_COMMUNICATE.ACKPASS; BUFFER_SIZE, TIMEOUT : in SIXTEEN_BITS ; LOCAL_CONN_NAME : in out TCB_PTR ; SECURITY, PRECEDENCE : in SIXTEEN_BITS ; OPTIONS : in TCP_OPTION_TYPE); procedure TCP_STATUS(LCN : in TCB_PTR); procedure RETRANS_TCP(LCN : in TCB_PTR); end T_TCP_UTILITIES_1 ; with SYSTEM; with UNCHECKED_CONVERSION; with QUEUES; use QUEUES; with IP_GLOBALS; use IP_GLOBALS; with TCP_SEGMENT_ARRIVES_PROCESSING; use TCP_SEGMENT_ARRIVES_PROCESSING; with TEXT_IO; use TEXT_IO; with TCP_GLOBALS; use TCP_GLOBALS; with TCB_ALLOCATOR; use TCB_ALLOCATOR; with WITH_ULP_COMMUNICATE; use WITH_ULP_COMMUNICATE; with WITH_IP_COMMUNICATE; use WITH_IP_COMMUNICATE; package body T_TCP_UTILITIES_1 is function USER_ACCESS_CHECK( LCN : in TCB_PTR ) return BOOLEAN is RESULT : BOOLEAN := TRUE; I : TCB_PTR := OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; -- The beginning index into the LCN list! begin while I /= null loop if I = LCN then RESULT := FALSE; end if; I := I.NEXT; end loop; return RESULT; exception when OTHERS => PUT("PROBLEM IN USER ACCESS CHECK"); end USER_ACCESS_CHECK; procedure SEND_A_SYN( LCN : in TCB_PTR ) is HEADER_LENGTH : SIXTEEN_BITS := 20; BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; DEST : THIRTYTWO_BITS; SOURCE : THIRTYTWO_BITS; PACKED_BUFF : PACKED_BUFFER_PTR; BUFFLEN : SIXTEEN_BITS; Q_ITEM : STD_Q_ITEM; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE; begin BUFFGET( PACKED_BUFF, 0 ); if PACKED_BUFF = null then SOCKET_PARAMS := LCN; UMESSAGE := ( -1, SOCKET_PARAMS); MESSAGE_FOR_USER( UMESSAGE ); else PACKED_BUFF.STATUS := OWNER_TCP; PACKED_BUFF.IN_USE := TRUE; LCN.ISS := MODULAR_CONVERT( ISS ); LCN.SND_NXT := LCN.ISS; TYPE_FLAG := SYN; OPTIONS := CLEAR; TCP_HEADER_FORMAT( LCN, BUFPTR, TYPE_FLAG, OPTIONS); DEST := LCN.DESTINATION_ADDRESS; OPTIONS := TCP_SECURITY_OPTIONS; PACK_BUFFER_INTO_BIT_STREAM( BUFPTR, PACKED_BUFF ); SOURCE := IP_GLOBALS.WHOIAM; SEND_IP( SOURCE, DEST, TOS, TTL, PACKED_BUFF, HEADER_LENGTH, IDENT, DONT_FRAGMENT, OPTIONS, RESULT); LCN.SND_UNA := LCN.ISS; LCN.SND_NXT := LCN.ISS + MODULAR_CONVERT(SIXTEEN_BITS(1)); Q_ITEM := ( PACKED_BUFF, NULL_UNPACKED_BUFFER, HEADER_LENGTH); QUEUE_ADD( TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); end if; end SEND_A_SYN; procedure TCP_CLOSE(LCN : in TCB_PTR) is --This subprogram is called by the user via the TCP controller. --It will send a FIN to a remote host. This will cause the connection --to close down upon a FIN and/or an ACK from the remote host. UMESSAGE : WITH_ULP_COMMUNICATE.USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; procedure SEND_A_FIN(LCN : in TCB_PTR) is --This subprogram formats and sends a FIN to the IP for transmission --to the remote host. BUFPTR : T_TCP_GLOBALS_DATA_STRUCTURES.BUFFER_POINTER; BUFFLEN : SIXTEEN_BITS ; PACKED_BUFF : PACKED_BUFFER_PTR; SEGMENT_DATA_LENGTH : CONSTANT SIXTEEN_BITS := 1; TCP_HEAD_AND_DATA_LENGTH : CONSTANT SIXTEEN_BITS := 20; -- THE LENGTH OF A FIN SEGMENT WITHOUT OPTIONS NO_ROOM : BOOLEAN; Q_ITEM : STD_Q_ITEM; UMESSAGE : USER_MESSAGE; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin BUFFGET(PACKED_BUFF, BUFFLEN); if PACKED_BUFF = null then -- TELL USE ERROR: INSUFFICIENT RESOURCES SOCKET_PARAMS := LCN; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); SOCKET_PARAMS := LCN; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); elsif LCN.SND_WND + LCN.SND_UNA >= (LCN.SND_NXT + SEGMENT_DATA_LENGTH) then -- WE CAN SEND IT. PACKED_BUFF.IN_USE := TRUE; PACKED_BUFF.STATUS := OWNER_TCP; TYPE_FLAG := FIN; -- CLEAR THE OPTIONS ARRAY OPTIONS := CLEAR; TCP_HEADER_FORMAT(LCN, BUFPTR, TYPE_FLAG, OPTIONS);--FIN -- HERE WE MUST PUT IN THE NECESSARY SECURITY OPTIONS FOR IP. OPTIONS := TCP_SECURITY_OPTIONS; -- PACK THE BUFFER PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFF); SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFF, TCP_HEAD_AND_DATA_LENGTH, IDENT, DONT_FRAGMENT, OPTIONS, RESULT); -- UPDATE THE SEND NEXT LCN.SND_NXT := LCN.SND_NXT + MODULAR_CONVERT ( SIXTEEN_BITS (1)); -- PUT IT ON THE RETRANSMIT QUEUE IT IS QUEUED UP WITH A TIME. Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER,TCP_HEAD_AND_DATA_LENGTH); QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); else -- PUT IT ON THE TRANSMIT QUEUE FOR LATER PROCESSING. Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, TCP_HEAD_AND_DATA_LENGTH); QUEUE_ADD(TRANSMIT_QUEUE, LCN, Q_ITEM); end if; end SEND_A_FIN; begin -- TCP_CLOSE T_TCP_GLOBALS_DATA_STRUCTURES.LCN := LCN; -- FOR TEST case LCN.STATE is when T_TCP_GLOBALS_DATA_STRUCTURES.CLOSED => if USER_ACCESS_CHECK(LCN) then -- TELL USER ERROR: CONNECTION ILLEGAL FOR THIS PROCESS SOCKET_PARAMS := LCN; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS := LCN; UMESSAGE := ( 3, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; when T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN => QUEUE_CLEAR(RECEIVE_QUEUE, LCN); -- CLEAR TCB AND ENTER THE CLOSED STATE TCB_CLEAR(LCN); LCN.STATE := CLOSED; when SYN_SENT => -- NONE ON THIS LEVEL. CLEAR_SEND_QUEUE(LCN); QUEUE_CLEAR(RECEIVE_QUEUE, LCN); -- CLEAR THE TCB AND ENTER THE CLOSED STATE. TCB_CLEAR(LCN); LCN.STATE := CLOSED; when SYN_RECEIVED | ESTABLISHED => if QUEUE_EMPTY(TRANSMIT_QUEUE, LCN) then SEND_A_FIN(LCN); else -- SET THE CLOSE PENDING FLAG IN THE TCB. LCN.CLOSE_PENDING := TRUE; end if; -- ENTER THE FIN-WAIT-1 STATE LCN.STATE := FIN_WAIT_1; when FIN_WAIT_1 | FIN_WAIT_2 => --TELL USER ERROR: CONNECTION CLOSING SOCKET_PARAMS := LCN; UMESSAGE := ( 6, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); when CLOSE_WAIT => if QUEUE_EMPTY(TRANSMIT_QUEUE, LCN) then SEND_A_FIN(LCN); -- ENTER THE LAST ACK STATE LCN.STATE := LAST_ACK; QUEUE_CLEAR(PROCESSED_SEGMENTS_FOR_USER_QUEUE,LCN); else -- SET TH CLOSE PENDING FLAG IN THE TCB. LCN.CLOSE_PENDING := TRUE; -- WHEN THE FIN IS SENT DUE TO THE CLOSE PENDING -- FLAG THE STATE MUST BE CHANGED. end if; when CLOSING | LAST_ACK | TIME_WAIT => --TELL USER ERROR: CONNECTION CLOSING SOCKET_PARAMS := LCN; UMESSAGE := ( 6, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end case; end TCP_CLOSE; procedure TCP_OPEN( LOCAL_PORT, FOREIGN_PORT : in SIXTEEN_BITS ; FOREIGN_NET_HOST : in THIRTYTWO_BITS ; ACTIVE_PASSIVE : in WITH_TCP_COMMUNICATE.ACKPASS; BUFFER_SIZE, TIMEOUT : in SIXTEEN_BITS ; LOCAL_CONN_NAME : in out TCB_PTR ; SECURITY, PRECEDENCE : in SIXTEEN_BITS ; OPTIONS : in TCP_OPTION_TYPE) is --This subprogram will perform the actions necessary to do a passive or --an active OPEN. If a passive OPEN is requested the listen state will --entered. If an active OPEN is requested a SYN will be sent and the --connection actively pursued. The subprogram is called by the user layer --via the TCP controller. The following parameters are passed to the --subprogram : -- LOCAL_PORT : The local port identification number. -- FOREIGN_NET_HOST : The foreign net address of the remote host we wish -- to talk with and the address of the foreign host on the net. -- they are concatenated in a format found in the IP spec. -- FOREIGN_PORT : The port in the foreign host that we wish to send to. -- ACTIVE_PASSIVE : indicates whether an active or passive OPEN is -- desired. -- TIMEOUT : The timeout for transmitting data. if some data does not get -- through in the required time the connection is aborted. -- SECURITY : The request for a level of security. Which must be a -- legal level. -- PRECEDENCE : The precedence of the connection. Used in a multi-level, -- secure environment. -- OPTIONS : This data structure will contain a request for any options -- desired. Currently none will be. -- -- RESTRICTIONS : -- -- CURRENTLY WE ALLOW ONLY ONE CONNECTION PER PORT. -- NO_ROOM_FOR_CONNECTION : BOOLEAN := FALSE; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; begin --if ACTIVE_PASSIVE = WITH_TCP_COMMUNICATE.PASSIVE then T_TCP_GLOBALS_DATA_STRUCTURES.LCN := TCB_ALLOCATOR.TCB_GET; -- SEND THE LCN BACK TO THE USER. TCB_CLEAR( LCN ) ; -- Clear TCB. SOCKET_PARAMS := LCN ; LOCAL_CONN_NAME := LCN ; UMESSAGE := (14, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.LOCAL_PORT := LOCAL_PORT; --end if ; if LCN.STATE = T_TCP_GLOBALS_DATA_STRUCTURES.CLOSED then if USER_ACCESS_CHECK(LCN) then -- TELL USER ERROR: CONNECTION ILLEGAL FOR THIS PROCESS. SOCKET_PARAMS := LCN; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); elsif NO_ROOM_FOR_CONNECTION then -- THERE IS CURRENTLY ALWAYS ROOM -- TELL USER ERROR: INSUFFICIENT RESOURCES PUT_LINE("IN OPEN INSUF RESOURCES");-- DEBUG SOCKET_PARAMS := LCN; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); elsif ACTIVE_PASSIVE = WITH_TCP_COMMUNICATE.ACTIVE then if PRECEDENCE < 0 or (PRECEDENCE > 7) then -- TELL USER ERROR: PRECEDENCE NOT ALLOWED SOCKET_PARAMS := LCN; UMESSAGE := ( 9, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); elsif SECURITY < 0 or (SECURITY > 7) then -- TELL USER ERROR: SECURITY/COMPARTMENT NOT ALLOWED SOCKET_PARAMS := LCN; UMESSAGE := ( 11, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); elsif FOREIGN_NET_HOST = 0 then -- TELL USER ERROR: FOREIGN SOCKET UNSPECIFIED SOCKET_PARAMS := LCN; UMESSAGE := ( 4, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- START THE TIMEOUT FOR CONNECTION TIMER if TIMEOUT /= 0 then -- PUT IN THE NEW CONNECTION TIMEOUT. LCN.CONNECTION_TIMEOUT := TIMEOUT; end if; START_TIMER(LCN, TIMEOUT_TIMER); -- SET UP THE TCB LCN.DESTINATION_ADDRESS := FOREIGN_NET_HOST; LCN.FOREIGN_PORT := FOREIGN_PORT; -- SET UP THE TCB NET AND HOST ADDRESSES BY -- DECODING THE CONCATENATION OF FOREIGN_NET AND -- FOREIGN HOST. ADDRESS_DECODER(FOREIGN_NET_HOST); SEND_A_SYN(LCN); LCN.STATE := SYN_SENT; -- ENTER THE SYN-SENT STATE end if; else -- THIS IS A PASSIVE OPEN if FOREIGN_NET_HOST /= 0 then -- SET UP THE TCB. LCN.FOREIGN_PORT := FOREIGN_PORT; LCN.DESTINATION_ADDRESS := FOREIGN_NET_HOST ; -- DECODE THE TCB DESTINATION ADDRESS. A CONCATENATION -- OF FOREIGN_NET AND FOREIGN HOST AND PUT IT -- IN THE APPROPRIATE VARIABLES IN THE TCB. ADDRESS_DECODER(FOREIGN_NET_HOST); end if; if TIMEOUT /= 0 then -- PUT IN THE NEW CONNECTION TIMEOUT. LCN.CONNECTION_TIMEOUT := TIMEOUT; end if; LCN.ACTIVE_PASSIVE := T_TCP_GLOBALS_DATA_STRUCTURES.PASSIVE; -- A PASSIVE OPEN LCN.STATE := T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN; -- ENTER THE LISTEN STATE end if; elsif LCN.STATE = T_TCP_GLOBALS_DATA_STRUCTURES.LISTEN then if ACTIVE_PASSIVE = WITH_TCP_COMMUNICATE.ACTIVE then if FOREIGN_NET_HOST = 0 then -- TELL USER ERROR: FOREIGN SOCKET UNSPECIFIED SOCKET_PARAMS := LCN; UMESSAGE := ( 4, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- SET UP THE TCB LCN.ACTIVE_PASSIVE := T_TCP_GLOBALS_DATA_STRUCTURES.ACTIVE; -- CONNECTION NOW ACTIVE. LCN.FOREIGN_PORT := FOREIGN_PORT; LCN.DESTINATION_ADDRESS := FOREIGN_NET_HOST ; -- START THE CONNECTION TIMEOUT TIMER. START_TIMER(LCN, TIMEOUT_TIMER);--not used presently (JB 1/25/85) -- DECODE THE TCB DESTINATION ADDRESS. A CONCATENATION -- OF FOREIGN_NET AND FOREIGN HOST AND PUT IT IN -- THE APPROPRIATE VARIABLES IN THE TCB ADDRESS_DECODER(FOREIGN_NET_HOST); SEND_A_SYN(LCN); LCN.STATE := SYN_SENT; -- ENTER THE SYN_SENT STATE end if; end if; if TIMEOUT /= 0 then -- PUT IN THE NEW CONNECTION TIMEOUT. LCN.CONNECTION_TIMEOUT := TIMEOUT; end if; else -- THERE ALREADY IS A CONNECTION -- TELL USER ERROR: CONNECTION ALREADY EXISTS SOCKET_PARAMS := LCN; UMESSAGE := ( 12, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; end TCP_OPEN; procedure TCP_STATUS( LCN : in TCB_PTR) is --This subprogram returns the status of a connection, specified by the --LCN to the user layer. It also returns a pointer to the TCB for the --connection, which will indicate the state of the connection(OPEN --or CLOSED). The subprogram is called by the user interface via the --TCP controller. LCN is passed as a parameter to the subprogram. STATE : T_TCP_GLOBALS_DATA_STRUCTURES.STATUS_TYPE; STATUS_REC : STATUS_RECORD; UMESSAGE :USER_MESSAGE; SOCKET_PARAMS : TCB_PTR; begin T_TCP_GLOBALS_DATA_STRUCTURES.LCN := LCN; -- FOR TEST if USER_ACCESS_CHECK(LCN) then -- TELL USER ERROR: CONNECTION ILLEGAL FOR THIS PROCESS SOCKET_PARAMS := LCN; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); elsif LCN.STATE = T_TCP_GLOBALS_DATA_STRUCTURES.CLOSED THEN -- TELL USER ERROR CONNECTION DOES NOT EXIST SOCKET_PARAMS := LCN; UMESSAGE := ( 3, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else STATUS_REC.SOURCE_PORT := LCN.LOCAL_PORT; STATUS_REC.SOURCE_ADDRESS := LCN.SOURCE_ADDRESS; STATUS_REC.DESTINATION_PORT := LCN.FOREIGN_PORT; STATUS_REC.DESTINATION_ADDRESS := LCN.DESTINATION_ADDRESS; -- THE POSITIONS OF THE ENUMERATED DATA IN EACH RECORD IS THE SAME. -- THEREFORE THE VALUE OF THE CORRESPONDING TYPE GIVES YOU THE CORRECT -- ENUMERATION VALUE. STATUS_REC.CONNECTION_STATE := STATE_TYPE'VAL(STATES'POS(LCN.STATE)); STATUS_REC.STATUS:= WITH_ULP_COMMUNICATE.STATUS_TYPE'VAL( T_TCP_GLOBALS_DATA_STRUCTURES.STATUS_TYPE'POS(LCN.CONNECTION_STATUS)); STATUS_REC.LOCAL_RCV_WINDOW := LCN.RCV_WINDOW; STATUS_REC.REMOTE_RCV_WINDOW := LCN.SND_WND; STATUS_REC.OCTETS_ON_RETRANSMIT_QUEUE := LCN.QHEADS(TCP_RETRANSMIT_QUEUE).ELEMENT_COUNT; -- THIS IS SIMPLE -- UNTIL WE HAVE VARIABLE SIZE PACKETS ON THE QUEUE. STATUS_REC.URGENT_STATE := LCN.USER_NOTIFICATION; -- IF NOTIFIED OF URG. DATA STATUS_REC.PRECEDENCE := LCN.PRECEDENCE; for I in 1..9 loop -- COPY SECURITY PARAMS STATUS_REC.SECURITY(I) := LCN.SECURITY(I); end loop; STATUS_REC.ULP_TIMEOUT := LCN.CONNECTION_TIMEOUT; -- NOW MESSAGE MUST GET BACK TO THE USER INTERFACE. SOCKET_PARAMS := LCN; UMESSAGE := ( 15, SOCKET_PARAMS, STATUS_REC); MESSAGE_FOR_USER(UMESSAGE); end if; exception when others => PUT_LINE(" ERROR IN TCP STATUS"); end TCP_STATUS; procedure RETRANS_TCP( LCN : in TCB_PTR) is --This subprogram will get a segment off the retransmission queue and --send it to the IP for transmission to the remote host. It will --update the window in the segment. This subprogram is called when --a retransmission timeout has occured. It will retransmit a segment --to the remote host. A LCN is passed into the subprogram which pop --a segment off the retransmit to the IP for the remote host. -- ALLOWS US TO ADD TO THE IP ID MOD 2**16. Q_ITEM : STD_Q_ITEM; PACKED_BUFF : PACKED_BUFFER_PTR; BYTE_COUNT : SIXTEEN_BITS ; -- LENGTH OF BUFFER FROM RETRANSMIT QUEUE MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; begin -- GET A SEGMENT OFF THE RETRANS QUEUE. QUEUE_GET(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); if Q_ITEM.BUFFER /= null then if not Q_ITEM.BUFFER.IN_USE then --its not still waiting --for transmission PACKED_BUFF := Q_ITEM.BUFFER; BYTE_COUNT := Q_ITEM.LENGTH; --Reset the IP pointer in the buffer PACKED_BUFF.IP_PTR := PACKED_BUFF.TCP_PTR - 1; --IT WILL NOT BE OUR RESPONSIBILITY TO DETERMINE THE MAX TIME FOR A --TRANS. THAT WILL BELONG TO THE USER LAYER. THE DATAGRAM LAYER MAY --ALSO HAVE A TIME TO LIVE. WE CAN ALWAYS SEND FROM THE RETRANSMIT --QUEUE WE WILL USE THE PREVIOUSLY PACKED BUFFER FROM THE RETRANS Q --AS IS. -- SET UP ID FOR IP IDENT := LCN.RETRANS_IDENT; -- LCN.IDENT := LCN.IDENT + 1; SEND_IP( LCN.SOURCE_ADDRESS, LCN.DESTINATION_ADDRESS, TOS, TTL, PACKED_BUFF, BYTE_COUNT, IDENT, DONT_FRAGMENT, OPTIONS, RESULT); end if; QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); else TCP_ERROR(4); end if; end RETRANS_TCP; end T_TCP_UTILITIES_1 ; --:::::::::::::: --timer.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01201-100(-) -- E-Systems, Inc. August 07, 1985 -- -- timer.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; package REAL_TIME_CLOCK_AND_DATE is subtype IN_MILLISECONDS is THIRTYTWO_BITS ; procedure START_LOCAL_CLOCK; procedure STOP_LOCAL_CLOCK; function SYSTEM_TIME return IN_MILLISECONDS ; end REAL_TIME_CLOCK_AND_DATE; with T_REAL_TIME_CLOCK; package body REAL_TIME_CLOCK_AND_DATE is TOD : IN_MILLISECONDS ; procedure START_LOCAL_CLOCK is begin T_REAL_TIME_CLOCK.START; --Start interval timer end START_LOCAL_CLOCK; procedure STOP_LOCAL_CLOCK is begin T_REAL_TIME_CLOCK.STOP; --Stop interval timer end STOP_LOCAL_CLOCK; function SYSTEM_TIME return IN_MILLISECONDS is begin T_REAL_TIME_CLOCK.READ(TOD); -- read the clock return (TOD/1000) ; end SYSTEM_TIME; end REAL_TIME_CLOCK_AND_DATE; --:::::::::::::: --unpack.txt --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00008-200 80-01202-100(-) -- E-Systems, Inc. August 07, 1985 -- -- unpack.txt Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_GLOBALS; use IP_GLOBALS; with BUFFER_DATA; use BUFFER_DATA; package IP_UNPACK_AND_PACK_UTILITIES is -------------------------------------------------------------- --This implementation is for use with the DEC/Ada compiler. -- -------------------------------------------------------------- function UNPACK (PACKED_BUFFER : PACKED_BUFFER_PTR) return BUFFER_POINTER; --This function will unpack a packet of SYSTEM_BYTE to facilatate --access to data. procedure PACK_BUFFER_INTO_BIT_STREAM (BUFPTR : BUFFER_POINTER; PACKED_BUFFER : in out PACKED_BUFFER_PTR); --This procedure transform an IP header and date into SYSTEM_BYTE function CHECKSUM( START_PTR : in SIXTEEN_BITS ; END_PTR : in SIXTEEN_BITS ; PACKED_BUFFER : in PACKED_BUFFER_PTR) return SIXTEEN_BITS ; --This function performs a checksum calculation on the --arrived datagram and compares its value with that contained --in the IP header. end IP_UNPACK_AND_PACK_UTILITIES; --with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with TEXT_IO; use TEXT_IO, INTEGER_IO; with SYSTEM ; use SYSTEM; with UNCHECKED_CONVERSION; package body IP_UNPACK_AND_PACK_UTILITIES is function UNPACK (PACKED_BUFFER : PACKED_BUFFER_PTR) return BUFFER_POINTER is --This function will unpack a buffer full of bytes and put them in the --proper fields of a record for ease of processing by other routines. -- -- RESTRICTIONS : -- -- ** This routine is likely to be implementation dependent. ** --TEL pragma suppress(OVERFLOW_CHECK); type INDEX is (HIGH_WORD_HI_BYTE, HIGH_WORD_LO_BYTE, LOW_WORD_HI_BYTE, LOW_WORD_LO_BYTE); -- THIS IS THE WAY -- UNCHECKED CONV PUTS -- THE BYTES IN. IT IS -- OPPOSITE FOR THE VAX. type LONG_CONV is array(1..1) of THIRTYTWO_BITS ; -- CURRENTLY NECESSARY FOR -- IMPLEMENTATION RESTRICTION type BYTE_TYPE is array(INDEX) of SYSTEM.BYTE; function CONVERT is new UNCHECKED_CONVERSION(BYTE_TYPE, LONG_CONV); BYTES_TO_CONVERT : BYTE_TYPE; CONVERTED_WORDS : LONG_CONV; BUFPTR : BUFFER_POINTER; COUNT, I, X, Y : SIXTEEN_BITS ; SHIFT_WORD : CONSTANT THIRTYTWO_BITS := 65536; begin -- IT IS ASSUMED THAT THE POINTER IN THE BUFFER POINTS TO --THE PROPER HEADER. I := PACKED_BUFFER.IP_PTR; X := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I)/2**4) ; BUFPTR.VERSION := X; BUFPTR.IHL := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I)) - X * 2**4 ; BUFPTR.TOS := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+1)) ; BUFPTR.TOT_LEN := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+2) * 2**8 + PACKED_BUFFER.BYTE(I+3)) ; BUFPTR.ID := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+4) * 2**8 + PACKED_BUFFER.BYTE(I+5)) ; X := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+6)/2**5) ; BUFPTR.FLAGS := X; BUFPTR.FRAG_OFFSET := (SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+6)) - X * 2**5) * 2**8 + SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+7)) ; BUFPTR.TTL := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+8)) ; BUFPTR.PROT := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+9)) ; BUFPTR.IPCSUM := SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+10)) * 2**8 + SIXTEEN_BITS (PACKED_BUFFER.BYTE(I+11)) ; -- PUT IN SOURCE BYTES_TO_CONVERT(LOW_WORD_LO_BYTE) := PACKED_BUFFER.BYTE(I+12) ; BYTES_TO_CONVERT(LOW_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+13) ; BYTES_TO_CONVERT(HIGH_WORD_LO_BYTE) := PACKED_BUFFER.BYTE(I+14) ; BYTES_TO_CONVERT(HIGH_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+15) ; CONVERTED_WORDS := CONVERT(BYTES_TO_CONVERT); BUFPTR.SOURCE := CONVERTED_WORDS(1); -- PUT IN DESTINATION BYTES_TO_CONVERT(LOW_WORD_LO_BYTE) := PACKED_BUFFER.BYTE(I+16) ; BYTES_TO_CONVERT(LOW_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+17) ; BYTES_TO_CONVERT(HIGH_WORD_LO_BYTE) := PACKED_BUFFER.BYTE(I+18) ; BYTES_TO_CONVERT(HIGH_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+19) ; CONVERTED_WORDS := CONVERT(BYTES_TO_CONVERT); BUFPTR.DEST := CONVERTED_WORDS(1); -- NOW FOR THE OPTIONS IF ANY I := I + 20; if BUFPTR.IHL > 5 then -- OPTIONS EXIST COUNT := 1; for J in 1..BUFPTR.IHL - 5 LOOP for K in 0..3 loop BUFPTR.IP_OPTIONS( COUNT + SIXTEEN_BITS(K) ) := SIXTEEN_BITS (PACKED_BUFFER.BYTE( I + SIXTEEN_BITS(K)) ) ; end loop; COUNT := COUNT + 4; I := I + 4; end loop; end IF; PACKED_BUFFER.TCP_PTR := I; -- UPDATE THE POINTER TO POINT TO THE FIRST -- BYTE OF THE TCP HEADER. return BUFPTR; exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("IP UNPACK?, CONSTRAINT ERROR"); INTEGER_IO.PUT(I); when others => TEXT_IO.PUT_LINE("IP UNPACK?, ERROR"); -- SYSTEM.REPORT_ERROR; end UNPACK; procedure PACK_BUFFER_INTO_BIT_STREAM (BUFPTR : BUFFER_POINTER; PACKED_BUFFER : in out PACKED_BUFFER_PTR) is --This subprogram will take an unpacked IP header record with each --field having its own spot, and pack the fields into a bit --stream( in the form of bytes). It assumes that the pointer given --it (for the packed array) is correctly set. The IP header picture --in the specification shows how the packed stream should look. --It also calls the header checksum routine and packs the checksum --in the stream. --TEL pragma SUPPRESS(OVERFLOW_CHECK); type INDEX is (HIGH_WORD_HI_BYTE, HIGH_WORD_LO_BYTE, LOW_WORD_HI_BYTE, LOW_WORD_LO_BYTE); -- THIS IS THE WAY -- UNCHECKED CONV PUTS -- THE BYTES IN. -- IT IS OPPOSITE FOR -- THE VAX. type LONG_CONV is array(1..1) of THIRTYTWO_BITS ; -- CURRENTLY NECESSARY FOR -- IMPLEMENTATION RESTRICTION type BYTE_TYPE is array(INDEX) of SYSTEM.BYTE; --DEC/Ada type TWO_BYTE is array(1..2) of SYSTEM.BYTE; --DEC/Ada type TELEGOOFUP is array(1..1) of SIXTEEN_BITS ; function CONVERT_TO_TWO_BYTES is new UNCHECKED_CONVERSION(TELEGOOFUP, TWO_BYTE); function CONVERT is new UNCHECKED_CONVERSION(LONG_CONV, BYTE_TYPE); SHIFT_WORD : constant THIRTYTWO_BITS := 65536; J : SIXTEEN_BITS := 1; IP_LENGTH : constant SIXTEEN_BITS := BUFPTR.IHL * 4; HIGH_BYTE : BOOLEAN := TRUE; COUNT : SIXTEEN_BITS := 0; I, CSUM, X : SIXTEEN_BITS ; BYTES: BYTE_TYPE; WORDS_TO_CONVERT : LONG_CONV; TEMP : TWO_BYTE; WORD_TO_CONVERT : TELEGOOFUP; begin --SET POINTER PACKED_BUFFER.IP_PTR := PACKED_BUFFER.IP_PTR - IP_LENGTH + 1;-- POINTER IS -- INITIALLY AT THE FIRST OPEN BYTE IN THE BUFFER(ARRAY). I := PACKED_BUFFER.IP_PTR; PACKED_BUFFER.BYTE(I) := SYSTEM_BYTE (BUFPTR.VERSION * 2**4 + BUFPTR.IHL); PACKED_BUFFER.BYTE(I+1) := SYSTEM_BYTE (BUFPTR.TOS) ; WORD_TO_CONVERT(1) := BUFPTR.TOT_LEN; TEMP := CONVERT_TO_TWO_BYTES(WORD_TO_CONVERT); PACKED_BUFFER.BYTE(I+2) := TEMP(1); -- FOR VAX. TEMP(2);-- HIGH BYTE PACKED_BUFFER.BYTE(I+3) := TEMP(2); -- FOR VAX. TEMP(1); WORD_TO_CONVERT(1) := BUFPTR.ID; TEMP := CONVERT_TO_TWO_BYTES(WORD_TO_CONVERT); PACKED_BUFFER.BYTE(I+4) := TEMP(1); -- HIGH BYTE. OPPOSITE FOR THE mc68000 PACKED_BUFFER.BYTE(I+5) := TEMP(2); WORD_TO_CONVERT(1) := BUFPTR.FRAG_OFFSET; TEMP := CONVERT_TO_TWO_BYTES(WORD_TO_CONVERT); PACKED_BUFFER.BYTE(I+6) := TEMP(1) + SYSTEM_BYTE ( BUFPTR.FLAGS * 2**5) ; -- HIGH BYTE PACKED_BUFFER.BYTE(I+7) := TEMP(2); -- OPPOSITE OF THE VAX. PACKED_BUFFER.BYTE(I+8) := SYSTEM_BYTE ( BUFPTR.TTL ) ; PACKED_BUFFER.BYTE(I+9) := SYSTEM_BYTE ( BUFPTR.PROT ) ; -- CHECKSUM GOES HERE PACKED_BUFFER.BYTE(I+10) := 0; PACKED_BUFFER.BYTE(I+11) := 0; WORDS_TO_CONVERT(1) := BUFPTR.SOURCE; BYTES := CONVERT(WORDS_TO_CONVERT); PACKED_BUFFER.BYTE(I+12) := BYTES(LOW_WORD_LO_BYTE); PACKED_BUFFER.BYTE(I+13) := BYTES(LOW_WORD_HI_BYTE); PACKED_BUFFER.BYTE(I+14) := BYTES(HIGH_WORD_LO_BYTE); PACKED_BUFFER.BYTE(I+15) := BYTES(HIGH_WORD_HI_BYTE); WORDS_TO_CONVERT(1) := BUFPTR.DEST; BYTES := CONVERT(WORDS_TO_CONVERT); PACKED_BUFFER.BYTE(I+16) := BYTES(LOW_WORD_LO_BYTE); PACKED_BUFFER.BYTE(I+17) := BYTES(LOW_WORD_HI_BYTE); PACKED_BUFFER.BYTE(I+18) := BYTES(HIGH_WORD_LO_BYTE); PACKED_BUFFER.BYTE(I+19) := BYTES(HIGH_WORD_HI_BYTE); -- NOW THE OPTIONS I := I + 20; COUNT := (BUFPTR.IHL - 5) * 4; for J in 1..COUNT loop PACKED_BUFFER.BYTE(I + SIXTEEN_BITS ( J ) - 1) := SYSTEM_BYTE (BUFPTR.IP_OPTIONS(J) ) ; end loop; -- MOVE THE POINTER TO POINT TO THE NEXT OPEN SPACE FOR TCP -- PACKED_BUFFER.CPM_PTR := PACKED_BUFFER.IP_PTR - 1; -- PUT IN THE CHECKSUM WORD_TO_CONVERT(1) := CHECKSUM(PACKED_BUFFER.IP_PTR, BUFPTR.IHL * 4, PACKED_BUFFER); TEMP := CONVERT_TO_TWO_BYTES(WORD_TO_CONVERT); I := PACKED_BUFFER.IP_PTR; PACKED_BUFFER.BYTE(I + 10) := TEMP(2); -- FOR THE 68000 TEMP(2); PACKED_BUFFER.BYTE(I + 11) := TEMP(1); -- FOR THE 68000 TEMP(1); exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CONSTRAINT ERROR IN IP PACK"); INTEGER_IO.PUT(PACKED_BUFFER.IP_PTR); when others => TEXT_IO.PUT_LINE("PACK EM ERROR"); INTEGER_IO.PUT(PACKED_BUFFER.IP_PTR); INTEGER_IO.PUT(CSUM); -- SYSTEM.REPORT_ERROR; end PACK_BUFFER_INTO_BIT_STREAM; function PHYSICAL_ADDRESS is new UNCHECKED_CONVERSION(THIRTYTWO_BITS , SYSTEM.ADDRESS); function CHECKSUM( START_PTR : in SIXTEEN_BITS ; END_PTR : in SIXTEEN_BITS ; PACKED_BUFFER : in PACKED_BUFFER_PTR) return SIXTEEN_BITS is --This subprogram performs a checksum on the internet header only. It --will be the 16 bit one's complement of all 16 bit words in the --header. The value of the checksum field for computation will be 0. -- -- RESTRICTIONS : -- --This routine is implementation dependant. It is currently set for --a VAX 11/780. type TWO_WORDS is array(1..2) of SIXTEEN_BITS ; type TELEFOOL is array(1..1) of THIRTYTWO_BITS ; function CONVERSION is new UNCHECKED_CONVERSION(TELEFOOL, TWO_WORDS); HIGH_BYTE : BOOLEAN := TRUE; PCSUM : THIRTYTWO_BITS := 0; CSUM : TWO_WORDS :=(0,0); CHECKSM : TELEFOOL; begin -- ADD UP ALL THE 16 BIT FIELDS. THIS WILL BE SOMEWHAT TRICKY, SO --HANG ON. MUST SWAP HIGH AND LOW BITS IN EACH WORD. HOWEVER WE WILL --TRY IT THE INTUITIVE WAY FOR NOW. for I in 0..END_PTR - 1 loop if (I /= 10) and I /= 11 then -- DON'T ADD IN THE CHECKSUM if HIGH_BYTE then PCSUM := PCSUM + THIRTYTWO_BITS (PACKED_BUFFER.BYTE(START_PTR + I)) * THIRTYTWO_BITS (2**8); HIGH_BYTE := FALSE; else HIGH_BYTE := TRUE; PCSUM := PCSUM + THIRTYTWO_BITS (PACKED_BUFFER.BYTE(START_PTR + I)); end if; end if; end loop; -- GET ONES COMPLEMENT PCSUM := -PCSUM; PCSUM := PCSUM - 1; CHECKSM(1) := PCSUM; CSUM := CONVERSION(CHECKSM); -- GET BOTH WORDS AND RETURN LOW WORD. RETURN CSUM(2); -- IT IS ONE FOR THE VAX exception when CONSTRAINT_ERROR => TEXT_IO.PUT_LINE("CHECKSUM CONSTRAINT ERROR"); INTEGER_IO.PUT(START_PTR); -- SYSTEM.REPORT_ERROR; when others => TEXT_IO.PUT_LINE("CHECKSUM ERROR"); -- SYSTEM.REPORT_ERROR; end CHECKSUM; end IP_UNPACK_AND_PACK_UTILITIES;