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 / tcpsub.src < prev next >

Wrap

Text File | 1988-05-03 | 355.8 KB | 9,998 lines

--:::::::::::::: --buffer_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00988-100(-) -- E-Systems, Inc. August 07, 1985 -- -- BUFFER_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- 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 | -- -- | | -- -- +-------------+ -- -- -- ----------------------------------------------------------------------------- subtype THIRTYTWO_BITS is INTEGER; -- DEC/Ada --TEL subtype THIRTYTWO_BITS is INTEGER; --Telesoft Ada version 1.5 subtype SIXTEEN_BITS is SHORT_INTEGER; -- DEC/Ada --TEL subtype SIXTEEN_BITS is SHORT_INTEGER; --Telesoft Ada version 1.5 subtype SYSTEM_BYTE is UNSIGNED_BYTE; -- DEC/Ada --TEL 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); type BUFFER_AREA IS ARRAY(1..MAXIMUM_DATAGRAM_SIZE) 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; --:::::::::::::: --buffer.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00989-100(-) -- E-Systems, Inc. August 07, 1985 -- -- BUFFER.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with UNCHECKED_CONVERSION; with TEXT_IO; use TEXT_IO; ---------------------------------------------------------------------------- -- -- Implementation for DEC VAX installation only! -- ---------------------------------------------------------------------------- package body BUFFER_DATA is 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; task buffer_manager is pragma priority (15) ; entry free (bufptr : in out packed_buffer_ptr) ; entry get (bufptr : out packed_buffer_ptr) ; end buffer_manager ; task body buffer_manager is begin loop select accept free (bufptr : in out packed_buffer_ptr) do bufptr.next := head; head := bufptr; end free ; or accept get (bufptr : out packed_buffer_ptr) do bufptr := head; if head /= null then head := head.next ; end if ; end get ; end select ; end loop ; exception when others => put_line("ERROR IN BUFFER MANAGER") ; end buffer_manager ; -- -- The view from the outside world: -- procedure BUFFREE ( BUFPTR : in out PACKED_BUFFER_PTR; BUFFTYPE : in SIXTEEN_BITS ) is begin if BUFPTR.STATUS = NONE and then NOT BUFPTR.IN_USE then BUFFER_COUNT := BUFFER_COUNT + 1; bufptr.in_use := true; buffer_manager.free(bufptr) ; bufptr := null; -- return a null pointer else PUT_LINE("FAILED TO FREE BUFFER IN BUFFREE"); end if; TEXT_IO.PUT("FREEING A BUFFER. NUMBER OF FREE BU"); INT_IO.PUT(BUFFER_COUNT); TEXT_IO.NEW_LINE; exception when others => put_line("ERROR IN BUFFREE") ; end BUFFREE; procedure BUFFGET (BUFPTR : in out PACKED_BUFFER_PTR; BUFFTYPE : in SIXTEEN_BITS ) is begin buffer_manager.get(bufptr) ; if bufptr /= null then bufptr.in_use := false ; bufptr.telnet_ptr := 255 ; bufptr.tcp_ptr := 255 ; bufptr.ip_ptr := 255 ; bufptr.subnet_ptr := 255 ; bufptr.status := NONE ; TEXT_IO.NEW_LINE; PUT("BUFFGET No. OF BUFFERS := "); INT_IO.PUT(BUFFER_COUNT); TEXT_IO.NEW_LINE; 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"); -- INT_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 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; 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. INIT; -- generate buffers end BUFFER_DATA; --:::::::::::::: --ipglb_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00996-100(-) -- E-Systems, Inc. August 07, 1985 -- -- IPGLB_.ADA 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 := 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 ; 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; --:::::::::::::: --vmodulo_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01031-100(-) -- E-Systems, Inc. August 07, 1985 -- -- VMODULO_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA ; use BUFFER_DATA ; package MODULO is type MODULAR is record HI, LOW : THIRTYTWO_BITS ; end record; 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); end MODULO; --:::::::::::::: --vmodulo.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01032-100(-) -- E-Systems, Inc. August 07, 1985 -- -- VMODULO.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with TEXT_IO; use TEXT_IO; package body MODULO is package INT_IO is new INTEGER_IO( THIRTYTWO_BITS ); function LONG(X : MODULAR) return THIRTYTWO_BITS is begin return X.HI+X.LOW ; -- DOES NOT WORK ALL THE TIME! MAY RAISE NUMERIC ERROR end LONG; function MODULAR_CONVERT (X : SIXTEEN_BITS ) return MODULAR is Y : MODULAR ; begin Y.HI := 0 ; Y.LOW := 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.HI := X / 2**16 ; Y.LOW := X MOD 2**16 ; 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 "); IF PP.HI <= 2**15-1 THEN INT_IO.PUT((PP.HI * (2**16)) + PP.LOW) ; TEXT_IO.PUT_LINE(""); ELSE TEXT_IO.PUT(" negative ") ; INT_IO.PUT(PP.HI) ; TEXT_IO.PUT(","); INT_IO.PUT(PP.LOW) ; TEXT_IO.PUT_LINE("") ; END IF ; end; function GET_MODULAR(PP:STRING) return MODULAR is X : MODULAR ; begin -- TEXT_IO.PUT_LINE(PP); -- TEXT_IO.PUT_LINE(""); -- return VAL; X.HI := 0 ; X.LOW := 0 ; RETURN(X) ; end; function "+" (X : SIXTEEN_BITS ; Y : MODULAR) return MODULAR is begin RETURN(MODULAR_CONVERT(X) + Y) ; end; function "+" ( X : MODULAR; Y : SIXTEEN_BITS ) return MODULAR is begin RETURN(MODULAR_CONVERT(Y) + X) ; end; function "+" ( X : THIRTYTWO_BITS ; Y : MODULAR) return MODULAR is begin RETURN(MODULAR_CONVERT(X) + Y) ; end; function "+" (X : MODULAR;Y : THIRTYTWO_BITS ) return MODULAR is begin RETURN(MODULAR_CONVERT(Y) + X) ; end; function "+" (X,Y: MODULAR) return MODULAR is Z : MODULAR; CARRY : INTEGER := 0 ; begin Z.LOW := X.LOW + Y.LOW; IF Z.LOW >= 2**16 THEN -- CARRY Z.LOW := Z.LOW - 2**16 ; CARRY := 1 ; END IF ; Z.HI := (Y.HI + X.HI + CARRY) MOD 2**16 ; return Z; end; function "<=" (X,Y : MODULAR) return BOOLEAN is begin if X.HI = Y.HI then RETURN X.LOW <= Y.LOW ; elsif (X.HI - Y.HI) > 2**15 then -- we wrapped around if X.HI > Y.HI then -- Y wrapped around return (TRUE) ; else return (FALSE) ; end if ; else return (X.HI <= Y.HI) ; end if ; end; function ">=" (X,Y : MODULAR) return BOOLEAN is begin if X.HI = Y.HI then RETURN X.LOW >= Y.LOW ; elsif (X.HI - Y.HI) > 2**15 then -- we wrapped around if X.HI < Y.HI then -- Y wrapped around return (TRUE) ; else return (FALSE) ; end if ; else return (X.HI >= Y.HI) ; end if ; end; function "<" (X,Y : MODULAR) return BOOLEAN is begin return(not (X >= Y)) ; end; function ">" (X,Y : MODULAR) return BOOLEAN is begin return(not (X <= Y)) ; end; function "-" ( X : MODULAR; Y : SIXTEEN_BITS ) return MODULAR is begin return(X - MODULAR_CONVERT(Y)) ; end; function "-" (X, Y : MODULAR) return MODULAR is Z : MODULAR ; BORROW : INTEGER := 0 ; begin Z.LOW := X.LOW - Y.LOW ; if Z.LOW < 0 then Z.LOW := Z.LOW + 2**16 ; -- BORROW BORROW := 1 ; end if ; Z.HI := (X.HI - Y.HI - BORROW) ; IF Z.HI < 0 THEN Z.HI := 2**16 - ABS(Z.HI) ; END IF ; RETURN (Z) ; end; end MODULO; --:::::::::::::: --rtclkdate_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01006-100(-) -- E-Systems, Inc. August 07, 1985 -- -- RTCLKDATE_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with CALENDAR; use CALENDAR; with TEXT_IO; use TEXT_IO; with BUFFER_DATA ; use BUFFER_DATA ; package REAL_TIME_CLOCK_AND_DATE is ---------------------------------------------------- --This implementation is for use with the DEC/ADA -- --compiler. -- ---------------------------------------------------- ------------------------------------------------------------------------------- --This package will provide the user with the local time of day in -- --hundred's of seconds. -- -- -- --J. Baldo 17-Jan_85 -- ------------------------------------------------------------------------------- subtype DAY_TYPE is positive range 1..31; subtype MONTH_TYPE is positive range 1..12; subtype YEAR_TYPE is THIRTYTWO_BITS ; type DATE_TYPE is record DAY : DAY_TYPE; MONTH : MONTH_TYPE; YEAR : YEAR_TYPE; end record; --TEL subtype TIME_TYPE is INTEGER; subtype TIME_TYPE is DAY_DURATION; function SYSTEM_TIME return TIME_TYPE; --This function will return the CPU time in milliseconds. function SYSTEM_DATE return DATE_TYPE; --This function returns the day, month , and year , that --is currently set by the system. end REAL_TIME_CLOCK_AND_DATE; --:::::::::::::: --rtclkdate.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01007-100(-) -- E-Systems, Inc. August 07, 1985 -- -- RTCLKDATE.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with TEXT_IO; use TEXT_IO; package body REAL_TIME_CLOCK_AND_DATE is function SYSTEM_TIME return TIME_TYPE is --Implementation restriction : for VAX implementation the time will be obtained -- in hundred's of seconds. --TEL SYSTEM_TIME_FROM_CLOCK : TIME; --TEL RESULT : ERROR_CLASS;--will be implemented later to achieve dynamic error --TEL --checking begin --TEL GET_TIME(SYSTEM_TIME_FROM_CLOCK,RESULT); --TEL return SYSTEM_TIME_FROM_CLOCK.TICKS_SINCE_MIDNIGHT; return SECONDS(CLOCK); end SYSTEM_TIME; function SYSTEM_DATE return DATE_TYPE is SECONDS : DAY_DURATION; CURRENT_SYSTEM_DATE : DATE_TYPE; --TEL SYSTEM_TIME_FROM_CLOCK : TIME; --TEL RESULT : ERROR_CLASS;--will be implemented later to achieve dynamic error --TEL --checking begin --TEL GET_TIME(SYSTEM_TIME_FROM_CLOCK,RESULT); --TEL CURRENT_SYSTEM_DATE := (SYSTEM_TIME_FROM_CLOCK.DAY, --TEL SYSTEM_TIME_FROM_CLOCK.MONTH, --TEL SYSTEM_TIME_FROM_CLOCK.YEAR); SPLIT (CLOCK, --get time from system clock CURRENT_SYSTEM_DATE.YEAR, CURRENT_SYSTEM_DATE.MONTH, CURRENT_SYSTEM_DATE.DAY, SECONDS); return CURRENT_SYSTEM_DATE; end SYSTEM_DATE; end REAL_TIME_CLOCK_AND_DATE; --:::::::::::::: --ip_tcp_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00997-100(-) -- E-Systems, Inc. August 07, 1985 -- -- IP_TCP_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_GLOBALS; use IP_GLOBALS; with BUFFER_DATA; use BUFFER_DATA; package IP_TCP is --------------------------------------- --This implementation is for the -- --DEC/Ada compiler . -- --------------------------------------- subtype Q_ITEM is IP_MESSAGE ; task IP_FROM_TCP is entry Q_ADD ( ITEM : in Q_ITEM ) ; entry Q_GET ( ITEM : in out Q_ITEM ) ; end IP_FROM_TCP ; end IP_TCP ; --:::::::::::::: --ip_tcp.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00998-100(-) -- E-Systems, Inc. August 07, 1985 -- -- IP_TCP.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with TEXT_IO; use TEXT_IO; package body IP_TCP is --------------------------------------- --This implementation is for the -- --DEC/Ada compiler . -- --------------------------------------- package INT_IO is new INTEGER_IO( SIXTEEN_BITS ) ; type QUEUE_ELEMENT; type QUEUE_ELEMENT_POINTER is access QUEUE_ELEMENT; 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; TO_IP_QUEUE : QHEADS ; --queue for IP MAX_QUEUE_SIZE : constant SIXTEEN_BITS := 32; NUMBER_OF_QUEUES : constant SIXTEEN_BITS := 1; QUEUE_FREE_LIST : QUEUE_ELEMENT_POINTER; function QUEUE_EMPTY return BOOLEAN is RESULT : BOOLEAN := FALSE; begin if TO_IP_QUEUE.ELEMENT_COUNT = 0 then RESULT := TRUE; end if; return RESULT; end QUEUE_EMPTY; function QUEUE_FULL return BOOLEAN is RESULT : BOOLEAN := FALSE ; begin if TO_IP_QUEUE.ELEMENT_COUNT = MAX_QUEUE_SIZE then RESULT := TRUE ; end if; return RESULT ; end QUEUE_FULL ; 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; procedure QUEUE_GET ( ITEM : out Q_ITEM) is Q_ELEMENT_TO_BE_FREED : QUEUE_ELEMENT_POINTER; begin if TO_IP_QUEUE.ELEMENT_COUNT > 0 then TO_IP_QUEUE.ELEMENT_COUNT := TO_IP_QUEUE.ELEMENT_COUNT - 1; Q_ELEMENT_TO_BE_FREED := TO_IP_QUEUE.FIRST_ELEMENT; ITEM := TO_IP_QUEUE.FIRST_ELEMENT.ELEMENT; TO_IP_QUEUE.FIRST_ELEMENT := TO_IP_QUEUE.FIRST_ELEMENT.NEXT; if TO_IP_QUEUE.ELEMENT_COUNT = 0 then -- AN EMPTY LIST TO_IP_QUEUE.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 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 ( ITEM : Q_ITEM) is NEW_ITEM : QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; begin NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if TO_IP_QUEUE.ELEMENT_COUNT < MAX_QUEUE_SIZE then if TO_IP_QUEUE.ELEMENT_COUNT /= 0 then -- ITS NOT AN EMPTY QUEUE. SO LINK FORMER -- LAST ITEM TO NEW ONE. TO_IP_QUEUE.LAST_ELEMENT.NEXT := NEW_ITEM; else -- FIRST ADD TO THE QUEUE TO_IP_QUEUE.FIRST_ELEMENT := NEW_ITEM; end if; TO_IP_QUEUE.LAST_ELEMENT := NEW_ITEM; TO_IP_QUEUE.ELEMENT_COUNT := TO_IP_QUEUE.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"); INT_IO.PUT(TO_IP_QUEUE.ELEMENT_COUNT); end QUEUE_ADD; task body IP_FROM_TCP is begin loop select when not QUEUE_FULL => accept Q_ADD ( ITEM : in Q_ITEM ) do QUEUE_ADD ( ITEM ) ; end Q_ADD ; or when not QUEUE_EMPTY => accept Q_GET ( ITEM : in out Q_ITEM ) do QUEUE_GET ( ITEM ) ; end Q_GET ; end select ; end loop ; end IP_FROM_TCP ; procedure INITIALIZE_QUEUES is --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. 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; begin INITIALIZE_QUEUES ; end IP_TCP ; --:::::::::::::: --subnet_calls_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01012-100(-) -- E-Systems, Inc. August 07, 1985 -- -- SUBNET_CALLS_.ADA 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 -- --DEC/Ada -- ------------------------------------------------- ----------------------------------------------------------------------------- --This package contains procedure calls and data structures necessary for -- --the Internet Protocol Group and the Subnet Protocol Group to communicate.-- ----------------------------------------------------------------------------- task SNP is pragma priority(14) ; entry 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. entry 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. entry SEND_TO_IP( DATAGRAM : in out PACKED_BUFFER_PTR); end SNP; procedure start_subnet_driver ; end SUBNET_CALLS; --:::::::::::::: --subnet_calls.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01013-100(-) -- E-Systems, Inc. August 07, 1985 -- -- SUBNET_CALLS.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with system; use system ; with starlet; use starlet; with condition_handling ; use condition_handling ; with unchecked_conversion ; with tasking_services; use tasking_services; with text_io ; use text_io ; package body SUBNET_CALLS is ------------------------------------------------- --This implementation version is for use with -- --DEC/Ada and ethernet -- ------------------------------------------------- ------------------------------------------------------------------------------- -- -- subnet driver routines -- ------------------------------------------------------------------------------- -- -- for passing addresses as long integers in qio calls: function physical_address is new unchecked_conversion(address,unsigned_longword) ; -- ethernet subnet driver routines ret_status : condition_handling.cond_value_type ; deuna_number : channel_type ; enet_iosb : iosb_type ; bufaddr : unsigned_longword ; buflen : unsigned_longword ; devname : device_name_type (1..4) := "XEA0" ; type ethernet_address is array (1..8) 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#, -- unused 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#))) ; subtype zero is THIRTYTWO_BITS ; pad : array (1..512) of zero ; -- -- ethernet setup characteristics -- type parm_block_type is record number_of_buffers : SIXTEEN_BITS := 16#451# ; -- nma_c_plci_bfn number_1 : unsigned_longword := 1 ; protocol_type : SIXTEEN_BITS := 16#B0E# ; -- nma_c_plci_pty non_decnet : unsigned_longword := 16#6006# ; end record ; parm_block : parm_block_type ; type parm_descriptor_type is record parm_length : unsigned_longword := parm_block'size / 8 ; -- in bytes parm_addr : system.address := parm_block'address ; end record ; parm_descriptor : parm_descriptor_type ; -- -- The actual i/o tasks for reading.... -- task ethernet_read_task is pragma priority (12) ; entry start ; end ethernet_read_task ; task body ethernet_read_task is response_buffer, response_buffer1 : packed_buffer_ptr ; begin accept start ; buffget(response_buffer,0) ; loop task_qiow ( status => ret_status, chan => deuna_number, func => io_readvblk, p1 => physical_address(response_buffer.byte'address), p2 => 512, iosb => enet_iosb) ; if not condition_handling.success(ret_status) then put_line("QIOW GET FROM ETHERNET ERROR") ; signal(ret_status) ; end if ; ret_status := unsigned_longword(enet_iosb.status) ; if not condition_handling.success(ret_status) then signal(ret_status) ; end if ; buffget(response_buffer1,0) ; -- get a free one before giving up old one if response_buffer1 /= null then response_buffer.size := SIXTEEN_BITS (enet_iosb.count) ; response_buffer.ip_ptr := 1 ; snp.send_to_ip(response_buffer) ; response_buffer := response_buffer1 ; else put_line("LOST ETHERNET PACKET -- OUT OF BUFFERS") ; -- debug end if ; end loop ; exception when others => put_line ("EXCEPTION IN ETHERNET READ TASK") ; end ethernet_read_task ; -- -- writing to the subnet is done directly, without a buffer -- procedure subnet_put (buf : in out packed_buffer_ptr; adr : in local_address_type; len : in datagram_length) is adr_address : system.address ; adr_valid : boolean := false ; begin for i in 1..max_hosts loop if address_table(i).host_number = adr then adr_address := address_table(i).local_addr'address ; adr_valid := true ; exit ; end if ; end loop ; if adr_valid then task_qiow( status => ret_status, chan => deuna_number, func => starlet.io_writevblk, iosb => enet_iosb, p1 => physical_address(buf.byte(buf.subnet_ptr)'address) , p2 => unsigned_longword(len), p5 => physical_address(adr_address)) ; if not condition_handling.success(ret_status) then put_line("QIOW PUT TO ETHERNET ERROR") ; signal(ret_status) ; end if ; ret_status := unsigned_longword(enet_iosb.status) ; if not condition_handling.success(ret_status) then signal(ret_status) ; end if ; BUF.IN_USE := FALSE; buffree(buf,0) ; -- put_line("put ok") ; else put_line("INVALID ADDRESS TO ETHERNET PUT") ; -- for debug end if ; end ; -- -- Interface to the users of this stuff -- task body SNP is buffer_size : constant := 16 ; type dg_array is array (0..buffer_size) of packed_buffer_ptr ; type buffer_type is record put : THIRTYTWO_BITS range 0..buffer_size := 0 ; get : THIRTYTWO_BITS range 0..buffer_size := 0 ; val : dg_array ; end record ; buffer : buffer_type ; begin loop select when (buffer.put /= buffer.get) => accept deliver( datagram : OUT packed_buffer_ptr) do datagram := buffer.val(buffer.get) ; buffer.get := (buffer.get + 1) mod buffer_size ; end deliver ; or accept 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) do subnet_put(datagram, local_destination, length) ; end send ; or accept send_to_ip(datagram : in out packed_buffer_ptr) do if buffer.get /= (buffer.put + 1) mod buffer_size then buffer.val(buffer.put) := datagram ; buffer.put := (buffer.put + 1) mod buffer_size ; else put_line("LOST AN ETHERNET PACKET -- NO QUEUE SPACE ") ; DATAGRAM.IN_USE := FALSE; buffree(datagram,0) ; end if ; end send_to_ip ; end select ; end loop ; exception when others => put_line (" EXCEPTION IN SUBNET INTERFACE PACKAGE - SNP ") ; end SNP; -- -- package initialization -- procedure start_subnet_driver is begin put_line("assign deuna...") ; starlet.assign( status => ret_status, devnam => devname, chan => deuna_number) ; if not condition_handling.success(ret_status) then put_line("COULD NOT ASSIGN DEUNA") ; signal(ret_status) ; end if ; put_line("start deuna...") ; starlet.qiow( status => ret_status, chan => deuna_number, func => IO_setmode+io_m_ctrl+io_m_startup, p2 => physical_address(parm_descriptor'address), iosb => enet_iosb ); if not condition_handling.success(ret_status) then put_line("COULD NOT INITIALIZE DEUNA") ; signal(ret_status) ; end if ; ret_status := unsigned_longword(enet_iosb.status) ; if not condition_handling.success(ret_status) then signal(ret_status) ; end if ; put_line("deuna initialized") ; ethernet_read_task.start ; exception when others => put_line (" EXCEPTION IN START_SUBNET_DRIVER") ; end start_subnet_driver ; begin null ; exception when others => put_line (" EXCEPTION IN SUBNET INTERFACE PACKAGE INITIALIZTION") ; end SUBNET_CALLS; --:::::::::::::: --tcpglbdat_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01016-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCPGLBDAT_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with STARLET ; use STARLET ; with MODULO; use MODULO; with IP_GLOBALS; use IP_GLOBALS; with BUFFER_DATA; use BUFFER_DATA; package T_TCP_GLOBALS_DATA_STRUCTURES is ----------------------------------------------------------- --This implementation is for use with the DEC/Ada -- --compiler . -- ----------------------------------------------------------- --***************************************************************************** --*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 TWO_BITS is INTEGER; 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 TCP_CHANNEL_NAME : STRING(1..30) ; TCP_CHANNEL_PTR : CHANNEL_TYPE ; 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); MAX_PORTS : constant SIXTEEN_BITS := 4; type PORT_LIST is array(1..MAX_PORTS) of SIXTEEN_BITS ; VALID_PORT_LIST : PORT_LIST := ( 20, 21, 23, 25); 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; --:::::::::::::: --lcnkeep_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00999-100(-) -- E-Systems, Inc. August 07, 1985 -- -- LCNKEEP_.ADA 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; --:::::::::::::: --lcnkeep.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01000-100(-) -- E-Systems, Inc. August 07, 1985 -- -- LCNKEEP.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with STARLET ; use STARLET ; 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); --These variables are used by TCB_FREE only! --They are instantiated durning intialization --Rationale for this method is that garbage collection --may not be implemented for the Unchecked_Deallocate. CURRENT_LIST_POINTER : TCB_PTR; PRIOR_LIST_POINTER : TCB_PTR; procedure TCB_CLEAR( LCN : in TCB_PTR) is begin LCN.TCP_CHANNEL_NAME := " "; LCN.TCP_CHANNEL_PTR := CHANNEL_ZERO ; LCN.STATE := CLOSED; LCN.CONNECTION_STATUS := CONNECTION_CLOSED; LCN.LOCAL_PORT := -1; LCN.LOCAL_NET :=0; LCN.LOCAL_HOST :=1; LCN.SOURCE_ADDRESS := 1; 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 = 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"); when OTHERS => PUT_LINE("Unkown 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; --:::::::::::::: --ncomm_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01001-100(-) -- E-Systems, Inc. August 07, 1985 -- -- NCOMM_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with STARLET ; use STARLET ; with IP_GLOBALS; use IP_GLOBALS; 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 DEC/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. -- ------------------------------------------------------------------------------- type STATUS_TYPE is ( CONNECTION_OPEN, CONNECTION_CLOSED, OPENING, CLOSING); type SECURITIES is array(1..9) of SIXTEEN_BITS ; type STATE_TYPE is ( CLOSED, SYSN_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; subtype LCN_TYPE is TCB_PTR; type LCN_PTR_TYPE is record LCN : LCN_TYPE := null; CHANNEL_PTR : CHANNEL_TYPE ; CHANNEL_NAME : STRING(1..30) ; end record; type USER_MESSAGE(MESSAGE_NUMBER : SIXTEEN_BITS := 0) is record LOCAL_CONNECTION_NAME : LCN_PTR_TYPE; 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; 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); subtype SECURITY_OPTION_ARRAY is SIXTEEN_BITS range 1..9; type SECURITY_OPTION_TYPE is array( SECURITY_OPTION_ARRAY ) 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_BLOCK : LCN_PTR_TYPE ; 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_BLOCK : LCN_PTR_TYPE ; SECURITY, PRECEDENCE : SIXTEEN_BITS ; OPTIONS : TCP_OPTION_TYPE; end record; type STATUS_PARAMS is record LCN_BLOCK : LCN_PTR_TYPE ; 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_BLOCK : LCN_PTR_TYPE ; BUFPTR : PACKED_BUFFER_PTR; BYTE_COUNT, PUSH_FLAG, URG_FLAG, TIMEOUT : SIXTEEN_BITS ; end record; type RECEIVE_PARAMS is record LCN_BLOCK : LCN_PTR_TYPE ; BUFPTR : PACKED_BUFFER_PTR; BYTE_COUNT : SIXTEEN_BITS ; end record; type ABORT_CLOSE_PARAMS is record LCN_BLOCK : LCN_PTR_TYPE ; 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; TO_TCP_CHANNEL : CHANNEL_TYPE ; end WITH_TCP_COMMUNICATE; --:::::::::::::: --unpack_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01029-100(-) -- E-Systems, Inc. August 07, 1985 -- -- UNPACK_.ADA 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; --:::::::::::::: --unpack.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01030-100(-) -- E-Systems, Inc. August 07, 1985 -- -- UNPACK.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with TEXT_IO; use TEXT_IO; with SYSTEM; use SYSTEM; with UNCHECKED_CONVERSION; package body IP_UNPACK_AND_PACK_UTILITIES is package INT_IO is new INTEGER_IO( SIXTEEN_BITS ); 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(HIGH_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+12) ; BYTES_TO_CONVERT(HIGH_WORD_LO_BYTE) := PACKED_BUFFER.BYTE(I+13) ; BYTES_TO_CONVERT(LOW_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+14) ; BYTES_TO_CONVERT(LOW_WORD_LO_BYTE) := PACKED_BUFFER.BYTE(I+15) ; CONVERTED_WORDS := CONVERT(BYTES_TO_CONVERT); BUFPTR.SOURCE := CONVERTED_WORDS(1); -- PUT IN DESTINATION BYTES_TO_CONVERT(HIGH_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+16) ; BYTES_TO_CONVERT(HIGH_WORD_LO_BYTE) := PACKED_BUFFER.BYTE(I+17) ; BYTES_TO_CONVERT(LOW_WORD_HI_BYTE) := PACKED_BUFFER.BYTE(I+18) ; BYTES_TO_CONVERT(LOW_WORD_LO_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)) ) ; if BUFPTR.IP_OPTIONS( COUNT + SIXTEEN_BITS(K) ) < 0 then BUFPTR.IP_OPTIONS( COUNT + SIXTEEN_BITS(K) ) := BUFPTR.IP_OPTIONS( COUNT + SIXTEEN_BITS(K) ) + 256 ; -- for unsigned_byte conversion (DEC/ADA) end if; 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 => PUT_LINE("IP UNPACK?, CONSTRAINT ERROR"); INT_IO.PUT(I); when others => 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(2); -- FOR VAX. TEMP(2);-- HIGH BYTE PACKED_BUFFER.BYTE(I+3) := TEMP(1); -- 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(2) + SYSTEM_BYTE ( BUFPTR.FLAGS * 2**5) ; -- HIGH BYTE PACKED_BUFFER.BYTE(I+7) := TEMP(1); -- 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(HIGH_WORD_HI_BYTE); PACKED_BUFFER.BYTE(I+13) := BYTES(HIGH_WORD_LO_BYTE); PACKED_BUFFER.BYTE(I+14) := BYTES(LOW_WORD_HI_BYTE); PACKED_BUFFER.BYTE(I+15) := BYTES(LOW_WORD_LO_BYTE); WORDS_TO_CONVERT(1) := BUFPTR.DEST; BYTES := CONVERT(WORDS_TO_CONVERT); PACKED_BUFFER.BYTE(I+16) := BYTES(HIGH_WORD_HI_BYTE); PACKED_BUFFER.BYTE(I+17) := BYTES(HIGH_WORD_LO_BYTE); PACKED_BUFFER.BYTE(I+18) := BYTES(LOW_WORD_HI_BYTE); PACKED_BUFFER.BYTE(I+19) := BYTES(LOW_WORD_LO_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(1); -- FOR THE 68000 TEMP(2); PACKED_BUFFER.BYTE(I + 11) := TEMP(2); -- FOR THE 68000 TEMP(1); exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN IP PACK"); INT_IO.PUT(PACKED_BUFFER.IP_PTR); when others => PUT_LINE("PACK EM ERROR"); INT_IO.PUT(PACKED_BUFFER.IP_PTR); INT_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(1); -- IT IS ONE FOR THE VAX exception when CONSTRAINT_ERROR => PUT_LINE("CHECKSUM CONSTRAINT ERROR"); INT_IO.PUT(START_PTR); -- SYSTEM.REPORT_ERROR; when others => PUT_LINE("CHECKSUM ERROR"); -- SYSTEM.REPORT_ERROR; end CHECKSUM; end IP_UNPACK_AND_PACK_UTILITIES; --:::::::::::::: --tcp_q_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01018-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_Q_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; package TCP_Q_TASK is -------------------------------------- --This implementation is for the -- --the DEC/Ada compiler . -- -------------------------------------- subtype Q_ITEM is MESSAGE; task TCP_Q is entry Q_ADD ( ITEM : in Q_ITEM ) ; entry Q_GET ( ITEM : in out Q_ITEM ) ; end TCP_Q ; end TCP_Q_TASK ; --:::::::::::::: --tcp_q.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01019-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_Q.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with TEXT_IO; use TEXT_IO; with BUFFER_DATA ; use BUFFER_DATA ; package body TCP_Q_TASK is package INT_IO is new INTEGER_IO ( SIXTEEN_BITS ); type QUEUE_ELEMENT; type QUEUE_ELEMENT_POINTER is access QUEUE_ELEMENT; 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; TO_TCP_QUEUE : QHEADS; 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 NO_ADD_COUNT : SIXTEEN_BITS := 0; function QUEUE_FULL return BOOLEAN is RESULT : BOOLEAN := FALSE; begin if TO_TCP_QUEUE.ELEMENT_COUNT = 32 then RESULT := TRUE ; end if ; return RESULT; exception when others => PUT_LINE(" Error in QUEUE_EMPTY function "); end QUEUE_FULL; function QUEUE_EMPTY return BOOLEAN is RESULT : BOOLEAN := FALSE; begin if TO_TCP_QUEUE.ELEMENT_COUNT = 0 then RESULT := TRUE; end if; return RESULT; end QUEUE_EMPTY; 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; procedure QUEUE_DELETE ( ITEM :Q_ITEM) is BEFORE_PTR : QUEUE_ELEMENT_POINTER := TO_TCP_QUEUE.FIRST_ELEMENT; CURRENT_ELEMENT_POINTER : QUEUE_ELEMENT_POINTER := TO_TCP_QUEUE.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 TO_TCP_QUEUE.FIRST_ELEMENT = CURRENT_ELEMENT_POINTER then TO_TCP_QUEUE.FIRST_ELEMENT := CURRENT_ELEMENT_POINTER.NEXT; end if; if TO_TCP_QUEUE.LAST_ELEMENT = CURRENT_ELEMENT_POINTER then -- WE ARE DELETING LAST ELEMENT. if TO_TCP_QUEUE.FIRST_ELEMENT /= null then TO_TCP_QUEUE.LAST_ELEMENT := BEFORE_PTR; else -- AN EMPTY LIST NOW TO_TCP_QUEUE.LAST_ELEMENT := NULL; end if; end if; -- FREE THE ELEMENT AND DECREMENT THE ELEMENT COUNT FREE_Q_STRUCTURE(CURRENT_ELEMENT_POINTER); TO_TCP_QUEUE.ELEMENT_COUNT := TO_TCP_QUEUE.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 is X : QUEUE_ELEMENT_POINTER; begin while TO_TCP_QUEUE.ELEMENT_COUNT > 0 loop X := TO_TCP_QUEUE.FIRST_ELEMENT; TO_TCP_QUEUE.FIRST_ELEMENT := X.NEXT; FREE_Q_STRUCTURE(X); TO_TCP_QUEUE.ELEMENT_COUNT := TO_TCP_QUEUE.ELEMENT_COUNT - 1; end loop; -- RESET THE HEAD AND TAIL POINTERS. TO_TCP_QUEUE.FIRST_ELEMENT := null; TO_TCP_QUEUE.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 ( ITEM : Q_ITEM) is NEW_ITEM : QUEUE_ELEMENT_POINTER := GET_Q_STRUCTURE; begin NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if TO_TCP_QUEUE.ELEMENT_COUNT < MAX_QUEUE_SIZE theN if TO_TCP_QUEUE.ELEMENT_COUNT /= 0 then -- ITS NOT AN EMPTY QUEUE. SO LINK FORMER -- LAST ITEM TO NEW ONE. TO_TCP_QUEUE.LAST_ELEMENT.NEXT := NEW_ITEM; else -- FIRST ADD TO THE QUEUE TO_TCP_QUEUE.FIRST_ELEMENT := NEW_ITEM; end if; TO_TCP_QUEUE.LAST_ELEMENT := NEW_ITEM; TO_TCP_QUEUE.ELEMENT_COUNT := TO_TCP_QUEUE.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"); when others => PUT_LINE("ERROR IN QADD"); INT_IO.PUT ( TO_TCP_QUEUE.ELEMENT_COUNT); end QUEUE_ADD; procedure QUEUE_GET ( ITEM : in out Q_ITEM) is Q_ELEMENT_TO_BE_FREED : QUEUE_ELEMENT_POINTER; begin if TO_TCP_QUEUE.ELEMENT_COUNT > 0 then TO_TCP_QUEUE.ELEMENT_COUNT := TO_TCP_QUEUE.ELEMENT_COUNT - 1; Q_ELEMENT_TO_BE_FREED := TO_TCP_QUEUE.FIRST_ELEMENT; ITEM := TO_TCP_QUEUE.FIRST_ELEMENT.ELEMENT; TO_TCP_QUEUE.FIRST_ELEMENT := TO_TCP_QUEUE.FIRST_ELEMENT.NEXT; if TO_TCP_QUEUE.ELEMENT_COUNT = 0 then -- AN EMPTY LIST TO_TCP_QUEUE.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 => PUT_LINE("CONSTRAINT ERROR IN QGET"); when others => PUT_LINE("UNKNOWN ERROR IN QUEUE_GET"); end QUEUE_GET; task body TCP_Q is begin loop select when not QUEUE_EMPTY => accept Q_GET ( ITEM : in out Q_ITEM ) do QUEUE_GET ( ITEM ) ; end Q_GET; or when not QUEUE_FULL => accept Q_ADD ( ITEM : in Q_ITEM ) do QUEUE_ADD ( ITEM ) ; end Q_ADD ; end select ; end loop ; end TCP_Q ; 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; begin --intialization INITIALIZE_QUEUES; end TCP_Q_TASK ; --:::::::::::::: --tcp_queue_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01020-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_QUEUE_.ADA 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 ; --:::::::::::::: --tcp_queue.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01021-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_QUEUE.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- -----------------------------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; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with IP_GLOBALS ; use IP_GLOBALS ; package BODY QUEUES is package INT_IO_16 is new INTEGER_IO ( SIXTEEN_BITS ) ; package INT_IO_32 is new INTEGER_IO ( THIRTYTWO_BITS ) ; FREE_Q_ELEMENT : SIXTEEN_BITS ; 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 QUEUE_CHECKER is -- --QUEUE_COUNTER : SIXTEEN_BITS := FREE_Q_ELEMENT; --QUEUE_POINTER : STD_QUEUE_ELEMENT_POINTER := QUEUE_FREE_LIST; --COUNTER : SIXTEEN_BITS := FREE_Q_ELEMENT; --DUMMY : CHARACTER; -- --begin -- while QUEUE_COUNTER > 1 loop -- if QUEUE_POINTER = null then -- PUT_LINE("FOUND A MODIFIED QUEUE ELEMENT"); -- PUT("NO. := "); -- INT_IO_16.PUT(QUEUE_COUNTER); -- NEW_LINE; -- PUT("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- exit; -- end if; -- QUEUE_COUNTER := QUEUE_COUNTER - 1; -- QUEUE_POINTER := QUEUE_POINTER.NEXT; -- end loop; --exception -- when CONSTRAINT_ERROR => -- PUT_LINE("CONSTRAINT_ERROR IN QUEUE_CHECKER"); -- when others => -- PUT_LINE("UNKNOWN ERROR IN QUEUE_CHECKER"); --end QUEUE_CHECKER; 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; FREE_Q_ELEMENT := 162; 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 if Q_STRUCTURE /= null then Q_STRUCTURE.NEXT := QUEUE_FREE_LIST; QUEUE_FREE_LIST := Q_STRUCTURE; --Adds to front of list Q_STRUCTURE := null; --make the pointer null now if QUEUE_FREE_LIST.NEXT = null then TEXT_IO.PUT(ASCII.BEL); PUT_LINE("QUEUE_FREE_LIST.NEXT set to null in FREE_Q_STRUCTURE"); end if; FREE_Q_ELEMENT := FREE_Q_ELEMENT + 1; -- NEW_LINE; -- PUT("FREE_Q_ELEMENT := "); -- INT_IO_16.PUT(FREE_Q_ELEMENT); else TEXT_IO.PUT(ASCII.BEL); PUT_LINE("null pointer passed to FREE_Q_STRUCTURE"); end if; 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; DUMMY : CHARACTER; begin --QUEUE_CHECKER; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_GET= null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_GET/= null"); -- end if; 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; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_GET= null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_GET/= null"); -- end if; -- QUEUE_CHECKER; 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 ; DUMMY : CHARACTER; begin --QUEUE_CHECKER; while CURRENT_ELEMENT_POINTER /= null and (not FOUND) loop -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_DELETE = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_DELETE /= null"); -- end if; 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; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_DELETE = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_DELETE /= null"); -- end if; end loop; if not FOUND then --ERROR NEW_LINE;-- DEBUG JB 7/5/85 PUT_LINE("ERROR IN DELETE_QUEUE package QUEUES"); TCP_ERROR(11); end if; -- QUEUE_CHECKER; 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 -- QUEUE_CHECKER; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next DELETE_FROM_RETRANS_Q = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next DELETE_FROM_RETRANS_Q /= null"); -- end if; -- 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; TEMP(4) := PACKED_BUFFER.BYTE ( INDEX + SIXTEEN_BITS ( 4 ) + 4) ; TEMP(3) := PACKED_BUFFER.BYTE ( INDEX + SIXTEEN_BITS ( 3 ) + 4) ; TEMP(2) := PACKED_BUFFER.BYTE ( INDEX + SIXTEEN_BITS ( 2 ) + 4) ; TEMP(1) := PACKED_BUFFER.BYTE ( INDEX + SIXTEEN_BITS ( 1 ) + 4) ; -- GET THE SEQ NUMBER -- INITIALIZE RESULT RESULT(1) := 0; RESULT := CONVERT(TEMP); -- NEW_LINE; -- PUT_LINE("RESULT := "); -- INT_IO_32.PUT(RESULT(1)); -- NEW_LINE; -- 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; -- xxx := SEQUENCE_NUM + DATA_LENGTH ; -- new_line; -- put("SEQUENCE_NUM + DATA_LENGTH := "); -- int_io_32.put(xxx.hi); -- int_io_32.put(xxx.low); -- new_line; if SEQUENCE_NUM + DATA_LENGTH <= SEARCH_NUM then -- DELETE THIS QUEUE ELEMENT. 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. -- PUT_LINE("MY NAME IS TROUBLE"); -- PUT("**************"); -- GET(DUMMY); -- NEW_LINE; BEFORE_PTR := CURRENT_ELEMENT_POINTER; CURRENT_ELEMENT_POINTER := CURRENT_ELEMENT_POINTER.NEXT; end if; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next DELETE_FROM_RETRANS_Q = null"); -- PUT_LINE("HIT ANY CHARACTER TO CONTINUE "); -- GET(DUMMY); -- else -- put_line("queue_free_list.next DELETE_FROM_RETRANS_Q /= null"); -- end if; -- QUEUE_CHECKER; end loop; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN DELETE FROM RETRANS QUEUE"); PUT_LINE(""); PUT("INDEX VALUE IS "); INT_IO_16.PUT(INDEX); INT_IO_16.PUT(PACKED_BUFFER.TCP_PTR); if CURRENT_ELEMENT_POINTER = null then PUT_LINE("A NULL CURRENT ELEMENT POINTER."); end if; if BEFORE_PTR.NEXT = null then PUT_LINE("A NULL BEFORE POINTER NEXT FIELD"); end if; if PACKED_BUFFER = null then PUT_LINE("A NULL PACKED BUFFER ON THE RETRANS QUEUE"); end if; when others => 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 => PUT_LINE("CONSTRAINT ERROR in QUEUE_SIZE"); when others => 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 ; DUMMY : CHARACTER; begin while QHEAD.ELEMENT_COUNT > 0 loop --QUEUE_CHECKER; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_CLEAR= null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_CLEAR /= null"); -- end if; 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; 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; --NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_CLEAR = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_CLEAR /= null"); -- end if; -- QUEUE_CHECKER; 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"); when others => 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 ; DUMMY : CHARACTER; begin while QHEAD.ELEMENT_COUNT > 0 loop --QUEUE_CHECKER; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_CLEAR = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_CLEAR /= null"); -- end if; 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; --NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_CLEAR = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_CLEAR /= null"); -- end if; -- QUEUE_CHECKER; 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"); when others => 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; DUMMY : CHARACTER; begin X := QUEUE_FREE_LIST; if X = null then TEXT_IO.PUT(ASCII.BEL); put_line("who stuffed the queue element with a null pointer?"); put_line("GET_Q_STRUCTURE"); end if; if QUEUE_FREE_LIST.NEXT /= null then QUEUE_FREE_LIST := QUEUE_FREE_LIST.NEXT; -- NEW_LINE; -- PUT("FREE_Q_ELEMENT := "); -- FREE_Q_ELEMENT := FREE_Q_ELEMENT - 1; -- INT_IO_16.PUT(FREE_Q_ELEMENT); if X = QUEUE_FREE_LIST then NEW_LINE; PUT_LINE("X = QUEUE_FREE_LIST (OH NO!!!)"); PUT_LINE("STIKE ANY CHARACTER TO CONTINUE"); GET(DUMMY); end if; return X; else TEXT_IO.PUT(ASCII.BEL); PUT_LINE("NULL POINTER GET_Q_STRUCTURE"); RETURN null; end if; exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN GET_Q_STRUCTURE"); when others => 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; DUMMY : CHARACTER; begin --QUEUE_CHECKER; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_ADD = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_ADD /= null"); -- end if; NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if QUEUE = TCP_RETRANSMIT_QUEUE then -- PUT ON A TIME FOR THE RETRANS QUEUE 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; --NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_ADD = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_ADD /= null"); -- end if; -- QUEUE_CHECKER; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QUEUE ADD"); when others => PUT_LINE("ERROR IN QADD"); -- INTEGER_IO.PUT(LCN); INT_IO_16.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; DUMMY : CHARACTER; begin --QUEUE_CHECKER; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_ADD = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_ADD /= null"); -- end if; NEW_ITEM.ELEMENT := ITEM; NEW_ITEM.NEXT := null; if QUEUE = TCP_RETRANSMIT_QUEUE then -- PUT ON A TIME FOR THE RETRANS QUEUE 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; --NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_ADD = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_ADD /= null"); -- end if; -- QUEUE_CHECKER; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN "); PUT_LINE("QUEUE ADD, WITH RESULT INDICATION."); when others => PUT_LINE("UNKNOWN ERROR TYPE IN "); 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; DUMMY : CHARACTER; -- GET A QUEUE STRUCTURE FROM FREE LIST. begin --QUEUE_CHECKER; -- NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_ADD_TO_FRONT = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_ADD_TO_FRONT /= null"); -- end if; 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. PUT_LINE("NO ROOM FOR QUEUE ADD TO FRONT IN TCP"); end if; --NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- put_line("queue_free_list.next QUEUE_ADD_TO_FRONT = null"); -- PUT_LINE("STRIKE ANY CHAR TO CONTINUE"); -- GET(DUMMY); -- else -- put_line("queue_free_list.next QUEUE_ADD_TO_FRONT /= null"); -- end if; -- QUEUE_CHECKER; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN QUEUE ADD TO FRONT"); when others => 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; --:::::::::::::: --tcp_to_ulp_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01023-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_TO_ULP_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE ; use WITH_TCP_COMMUNICATE ; package TCP_TO_ULP_COMMUNICATE is procedure MESSAGE_FOR_USER ( USER_MESS : in out USER_MESSAGE ) ; --This procedure is used by TCP to put a message for the ULP. end TCP_TO_ULP_COMMUNICATE ; --:::::::::::::: --tcp_to_ulp.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01024-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_TO_ULP.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; with STARLET ; use STARLET ; with CONDITION_HANDLING ; use CONDITION_HANDLING ; with UNCHECKED_CONVERSION ; with TEXT_IO ; use TEXT_IO; with TASKING_SERVICES ; use TASKING_SERVICES ; with SYSTEM ; use SYSTEM ; package body TCP_TO_ULP_COMMUNICATE is function PHYSICAL_ADDRESS is new UNCHECKED_CONVERSION ( ADDRESS, UNSIGNED_LONGWORD ) ; type XUSER_MESSAGE_TYPE is record THE_USER_MESSAGE : USER_MESSAGE; THE_BUFFER : PACKED_BUFFER; THE_STATUS_PARAMS : STATUS_RECORD; end record; procedure MESSAGE_FOR_USER ( USER_MESS : in out USER_MESSAGE ) is MBX_STATUS : COND_VALUE_TYPE ; XUSER_MESSAGE : XUSER_MESSAGE_TYPE; begin XUSER_MESSAGE.THE_USER_MESSAGE := USER_MESS; case USER_MESS.MESSAGE_NUMBER is when 10 | 19 => XUSER_MESSAGE.THE_BUFFER := USER_MESS.DATA_BUFFER.ALL; USER_MESS.DATA_BUFFER.IN_USE := FALSE; USER_MESS.DATA_BUFFER.STATUS := NONE; BUFFREE( USER_MESS.DATA_BUFFER, 0 ); when 15 => new_line;--debug put_line("About to send a STATUS to ULP"); XUSER_MESSAGE.THE_STATUS_PARAMS := USER_MESS.STATUS_PARAMS ; when others => null; end case; TASK_QIOW ( STATUS => MBX_STATUS, CHAN => USER_MESS.LOCAL_CONNECTION_NAME.CHANNEL_PTR, FUNC => IO_WRITEVBLK + IO_M_NOW, P1 => PHYSICAL_ADDRESS ( XUSER_MESSAGE'ADDRESS ), P2 => UNSIGNED_LONGWORD( XUSER_MESSAGE'SIZE/8 ) ) ; if not SUCCESS ( MBX_STATUS ) then PUT_LINE ( "Error in write attempt to ULP mailbox from TCP ") ;--for debug SIGNAL(MBX_STATUS) ; end if; case USER_MESS.MESSAGE_NUMBER is when 8 | 16 | 18 | 24 => --delete mailbox: successful close; abort; --connection timeout; connection reset DELMBX( STATUS => MBX_STATUS, CHAN => USER_MESS.LOCAL_CONNECTION_NAME.CHANNEL_PTR ) ; when others => null; end case; end MESSAGE_FOR_USER ; end TCP_TO_ULP_COMMUNICATE ; --:::::::::::::: --tcp_ulp_get_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01025-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_ULP_GET_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE ; use WITH_TCP_COMMUNICATE ; package GET_MESSAGES_FROM_ULP is ------------------------------------------------ --This implementation is for the DEC/Ada -- --compiler . -- ------------------------------------------------ task OBTAIN_MESSAGE_FROM_ULP_QUEUE ; end GET_MESSAGES_FROM_ULP ; --:::::::::::::: --tcp_ulp_get.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01026-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_ULP_GET.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with TCP_Q_TASK ; use TCP_Q_TASK ; with UNCHECKED_CONVERSION ; with TASKING_SERVICES ; use TASKING_SERVICES ; with SYSTEM ; use SYSTEM ; with CONDITION_HANDLING ; use CONDITION_HANDLING ; with STARLET ; use STARLET ; with TEXT_IO ; use TEXT_IO ; with BUFFER_DATA ; use BUFFER_DATA ; package body GET_MESSAGES_FROM_ULP is package INT_IO is new INTEGER_IO( SIXTEEN_BITS ) ; --Conversion information type XMESSAGE_TYPE is record THE_TCP_MESSAGE : MESSAGE; THE_BUFFER : PACKED_BUFFER; end record; type XUSER_MESSAGE_TYPE is record THE_USER_MESSAGE : USER_MESSAGE ; THE_BUFFER : PACKED_BUFFER ; THE_STATUS : STATUS_RECORD ; end record ; --Mailbox information RETURN_STATUS : COND_VALUE_TYPE ; PERMANENT_MAILBOX : BOOLEAN := TRUE ; TO_TCP_CHANNEL : CHANNEL_TYPE ; MAILBOX_PROTECTION : FILE_PROTECTION_TYPE := 0; --for debug function PHYSICAL_ADDRESS is new UNCHECKED_CONVERSION ( ADDRESS, UNSIGNED_LONGWORD); task body OBTAIN_MESSAGE_FROM_ULP_QUEUE is BUFFER : PACKED_BUFFER_PTR ; XTCP_MESSAGE : XMESSAGE_TYPE; TCP_MESSAGE : MESSAGE ; begin PUT ( "TCP_MESSAGE SIZE := " ) ; INT_IO.PUT ( TCP_MESSAGE'SIZE ) ; NEW_LINE ; CREMBX( STATUS => RETURN_STATUS , PRMFLG => PERMANENT_MAILBOX , -- permanent CHAN => TO_TCP_CHANNEL, MAXMSG => XTCP_MESSAGE'SIZE/8, --size of message BUFQUO => 5 * XTCP_MESSAGE'SIZE/8 , --size of queue LOGNAM => "TO_TCP_CHANNEL") ; -- fixed name if NOT SUCCESS( RETURN_STATUS ) then PUT_LINE("Could not assign tcp channel") ; end if ; loop TASK_QIOW ( STATUS => RETURN_STATUS , CHAN => TO_TCP_CHANNEL , FUNC => IO_READVBLK , P1 => PHYSICAL_ADDRESS ( XTCP_MESSAGE'ADDRESS ) , P2 => UNSIGNED_LONGWORD ( XTCP_MESSAGE'SIZE/8 ) ) ; if NOT SUCCESS ( RETURN_STATUS ) then PUT_LINE ( "Error in reading to mailbox TO_TCP_MAILBOX " ); else TCP_MESSAGE := XTCP_MESSAGE.THE_TCP_MESSAGE ; if TCP_MESSAGE.EVENT = SEND then BUFFGET( BUFFER, 1 ) ; BUFFER.IN_USE := TRUE; BUFFER.STATUS := OWNER_TCP; TCP_MESSAGE.SEND_PARAMETERS.BUFPTR := BUFFER ; -- Give it a buffer TCP_MESSAGE.SEND_PARAMETERS.BUFPTR.ALL := XTCP_MESSAGE.THE_BUFFER; elsif TCP_MESSAGE.EVENT = RECEIVE then BUFFGET( BUFFER, 1); -- BUFFER.IN_USE := TRUE; BUFFER.STATUS := OWNER_TCP; TCP_MESSAGE.RECEIVE_PARAMETERS.BUFPTR := BUFFER ; end if; end if ; if TCP_MESSAGE.EVENT = OPEN then CREMBX( STATUS => RETURN_STATUS , PRMFLG => PERMANENT_MAILBOX , -- permanent CHAN => TCP_MESSAGE.OPEN_PARAMETERS.LCN_BLOCK.CHANNEL_PTR, MAXMSG => XUSER_MESSAGE_TYPE'SIZE, --size of message BUFQUO => 5 * XUSER_MESSAGE_TYPE'SIZE , --size of queue LOGNAM => TCP_MESSAGE.OPEN_PARAMETERS.LCN_BLOCK.CHANNEL_NAME(1..30) ) ; -- fixed name PUT("TCP_MESSAGE.LOCAL_PORT := "); INT_IO.PUT( TCP_MESSAGE.OPEN_PARAMETERS.LOCAL_PORT ) ; end if ; TCP_Q.Q_ADD ( TCP_MESSAGE ) ; end loop ; end OBTAIN_MESSAGE_FROM_ULP_QUEUE ; end GET_MESSAGES_FROM_ULP ; --:::::::::::::: --send_ip_task_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01010-100(-) -- E-Systems, Inc. August 07, 1985 -- -- SEND_IP_TASK_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_GLOBALS ; use IP_GLOBALS ; with BUFFER_DATA ; use BUFFER_DATA ; package SEND_IP_TASK is task TCP_TO_IP; end SEND_IP_TASK ; --:::::::::::::: --send_ip_task.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01011-100(-) -- E-Systems, Inc. August 07, 1985 -- -- SEND_IP_TASK.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with TCP_Q_TASK; use TCP_Q_TASK; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with IP_UNPACK_AND_PACK_UTILITIES; use IP_UNPACK_AND_PACK_UTILITIES; with IP_TCP ; use IP_TCP ; with SUBNET_CALLS ; use SUBNET_CALLS ; with TEXT_IO ; use TEXT_IO ; package body SEND_IP_TASK is package INT_IO_16 is new INTEGER_IO ( SIXTEEN_BITS ) ; task body TCP_TO_IP is type TEST_RESULT is (CORRECT, INCORRECT); ITEM : IP_MESSAGE ; BUFPTR : BUFFER_POINTER; 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 BYTE_COUNT : SIXTEEN_BITS ; TASK_MESSAGE : MESSAGE ; IP_PARAMS : SEG_ARRIVE_PARAMS; SECURITY_OPTION : SECURITY_OPTION_TYPE ; BUFFER : PACKED_BUFFER_PTR; function OPTION_CHECKER ( OPTIONS : in 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 : 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 loop IP_FROM_TCP.Q_GET ( ITEM ) ; if ITEM.EVENT /= FROM_TCP then PUT_LINE ( "Error from SEND_IP_TASK; IP_MESSAGE /= IP_SEND " ) ; --exit ; --terminate Q_GET end if ; --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. -- CHECK ALL PARAMETERS ON SEND CALL HERE. ARE ANY NOT CHECKED?? PROPER_DESTINATION := DESTINATION_CHECK( ITEM.DEST ); ERROR := 0; if PROPER_DESTINATION = INCORRECT then ERROR := 1; elsif (ITEM.TOS > 256) or (ITEM.TOS < 0) then ERROR := 2; elsif ( ITEM.TTL > 255) or ( ITEM.TTL < 0) then -- TIMES ARE IN SECONDS. ERROR := 3; else OPTION_CHECK := OPTION_CHECKER( ITEM.OPTIONS ); if OPTION_CHECK = INCORRECT then ERROR := 4; end if; end if; if ERROR /= 0 then NEW_LINE; PUT("BAD PACKET FOR TRANSMIT"); --** TEMP INT_IO_16.PUT( ERROR); --** TEMP NEW_LINE; ITEM.BUFPTR.IN_USE := FALSE; BUFFREE( ITEM.BUFPTR, 1 ); -- TEMPORARY FOR TEST** else if ITEM.DEST = WHOIAM then for INDEX in 3..11 loop SECURITY_OPTION( SIXTEEN_BITS(INDEX - 2) ) := ITEM.OPTIONS( SIXTEEN_BITS(INDEX) ) ; end loop ; -- BYTE_COUNT := MAXIMUM_DATAGRAM_SIZE - ITEM.BUFPTR.IP_PTR ; BYTE_COUNT := 255 - ITEM.BUFPTR.IP_PTR ; BUFFGET( BUFFER, 0 ); BUFFER.STATUS := OWNER_TCP; BUFFER.ALL := ITEM.BUFPTR.ALL; IP_PARAMS := ( BUFFER, BYTE_COUNT, ITEM.SRC, ITEM.DEST, 5, -- TCP Protocol Number ITEM.TOS, SECURITY_OPTION ) ; TASK_MESSAGE := ( DATA_FROM_IP, IP_PARAMS ) ; TCP_Q.Q_ADD( TASK_MESSAGE ) ; -- Send to TCP -- PUT_LINE("BUFFREE LOOP BACK AT IP");--DEBUG JB 7/3/85 ITEM.BUFPTR.IN_USE := FALSE; BUFFREE( ITEM.BUFPTR, 0 ); else -- FORMAT AN IP HEADER BUFPTR.VERSION := CURRENT_VERSION; BUFPTR.TOS := ITEM.TOS; BUFPTR.ID := ITEM.ID ; BUFPTR.FLAGS := 2; -- REALLY THREE BITS (010) MEANS DONT FRAGMENT. BUFPTR.FRAG_OFFSET := 0; -- WE DO NOT FRAGMENT. BUFPTR.TTL := ITEM.TTL; -- TIME TO LIVE (TBD) BUFPTR.PROT := TCP; -- PROTOCOL NUMBERS DEFINED IN RFC 870 BUFPTR.SOURCE := ITEM.SRC ; BUFPTR.DEST := ITEM.DEST ; -- SET UP TRANSMIT OPTIONS AS REQUESTED BY THE ABOVE --LAYER(TCP). COPY ARRAY. BUFPTR.IP_OPTIONS := ITEM.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) + ITEM.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 PACK_BUFFER_INTO_BIT_STREAM ( BUFPTR, ITEM.BUFPTR ); --/ SEND IT ON TO THE CHANNEL PROTOCOL MODULE/ ITEM.BUFPTR.SUBNET_PTR := ITEM.BUFPTR.IP_PTR ; SNP.SEND ( ITEM.BUFPTR , LOCAL_ADDRESS_TYPE ( ITEM.DEST ) , ROUTINE , NORMAL , NORMAL , NORMAL , BUFPTR.TOT_LEN ) ; -- PUT_LINE("Just sent a datagram to SUBNET");--debug JB 3/June/85 end if; end if; end loop ; 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 TCP_TO_IP ; end SEND_IP_TASK ; --:::::::::::::: --tcp_globals_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01017-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_GLOBALS_.ADA 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; --:::::::::::::: --vtcp_globals.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01033-100(-) -- E-Systems, Inc. August 07, 1985 -- -- VTCP_GLOBALS.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with QUEUES; use QUEUES; with SYSTEM; with MODULO; use MODULO; with TEXT_IO; use TEXT_IO; with UNCHECKED_CONVERSION; with REAL_TIME_CLOCK_AND_DATE; use REAL_TIME_CLOCK_AND_DATE; package BODY TCP_GLOBALS is package INT_IO_16 is new INTEGER_IO ( SIXTEEN_BITS ) ; package INT_IO_32 is new INTEGER_IO ( THIRTYTWO_BITS ) ; 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(1) := 0; --intialized here due to Telesoft subset BYTES_FROM_INTEGER(2) := 0; BYTES_FROM_INTEGER := CONVERT_INTEGER_TO_BYTES(TEMP_INT); for I in 1..2 loop PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS ( I ) - 1 ) := BYTES_FROM_INTEGER(I); end loop; INDEX := INDEX + 2; exception when others => PUT_LINE("ERROR IN PUT INTEGER INTO BUFFER"); INT_IO_16.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(I) - 1 ) := BYTES_FROM_LONG_INT(I); end loop; INDEX := INDEX + 4; exception when others => PUT_LINE("ERROR IN PUT LONG INTEGER INTO BUFFER"); INT_IO_16.PUT(INDEX); end PUT_A_LONG_INTEGER_IN_THE_BUFFER; procedure PUT_A_LO_WORD_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 for I in 1..4 loop --due TELESOFT 1.3d compiler BYTES_FROM_LONG_INT(I) := 0 ; end loop ; TEMP_LONG_INT(1) := DOUBLE_WORD; BYTES_FROM_LONG_INT := CONVERT_LONG_INT_TO_BYTES(TEMP_LONG_INT); for I in 1..2 loop -- PUT THEM IN PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS(I) - 1 ) := BYTES_FROM_LONG_INT(I); end loop; INDEX := INDEX + 2; exception when others => PUT_LINE("ERROR IN PUT LO WORD INTO BUFFER"); INT_IO_16.PUT(INDEX); end PUT_A_LO_WORD_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); --NEW_LINE; --PUT("XSEQ_NUM.HI := "); --INT_IO_32.PUT(BUFPTR.SEQ_NUM.HI); --NEW_LINE; --NEW_LINE; --PUT("XSEQ_NUM.LO := "); --INT_IO_32.PUT(BUFPTR.SEQ_NUM.LOW); --NEW_LINE; PUT_A_LO_WORD_IN_THE_BUFFER(BUFPTR.SEQ_NUM.LOW); PUT_A_LO_WORD_IN_THE_BUFFER(BUFPTR.SEQ_NUM.HI); PUT_A_LO_WORD_IN_THE_BUFFER(BUFPTR.ACK_NUM.LOW); PUT_A_LO_WORD_IN_THE_BUFFER(BUFPTR.ACK_NUM.HI); -- 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 => PUT_LINE("ERROR IN PACK BUFFER MAIN"); INT_IO_16.PUT(INDEX); PUT_LINE(""); INT_IO_16.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; -- NEW_LINE; -- PUT_LINE("ASSIGNED IN TCP_HEADER_FORMAT"); -- PUT("SEQ_NUM.HI := "); -- INT_IO_32.PUT(BUFPTR.SEQ_NUM.HI); -- NEW_LINE; -- PUT("SEQ_NUM.LO := "); -- INT_IO_32.PUT(BUFPTR.SEQ_NUM.LOW); -- NEW_LINE; 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; TEMP, 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; TEMP := THIRTYTWO_BITS( PACKED_BUFFER.BYTE(START_PTR + I) ); if TEMP < 0 then TEMP := TEMP + 256;-- VAX SIGN EXTENSION(PROBLEM) end if; if HIGH_BYTE then TCSUM := TCSUM + TEMP * THIRTYTWO_BITS ( 2**8 ); HIGH_BYTE := FALSE; else HIGH_BYTE := TRUE; TCSUM := TCSUM + TEMP ; 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(1); exception when others => PUT_LINE("ERROR IN CHECKSUM"); INT_IO_16.PUT(START_PTR); PUT_LINE("END POINTER"); INT_IO_16.PUT(END_PTR); end CHECKSUM; procedure TCP_ERROR( ERROR_INDICATION : in ERROR_TYPE ) is begin -- INCREMENT THE ERROR COUNTER. case ERROR_INDICATION is when 15 | 16 => -- currently cannot proccess null; when others => LCN.ERROR_TABLE(ERROR_INDICATION) := LCN.ERROR_TABLE(ERROR_INDICATION) + 1; end case ; 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) := SYSTEM."-" (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) := SYSTEM."-" (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 => PUT_LINE("ADDRESS DECODER FAILED"); for I in 1..4 loop INT_IO_16.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 => PUT_LINE("ERROR IN INSERT TEXT INTO BUFFER."); INT_IO_16.PUT(INDEX); INT_IO_16.PUT(INDEX1); INT_IO_16.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.(VAX clock units are every .01 secs) 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 => PUT_LINE("CONSTRAINT_ERROR in START_TIMER"); NEW_LINE; when others => PUT_LINE("unknown error in START_TIMER"); NEW_LINE; end START_TIMER; END TCP_GLOBALS; --:::::::::::::: --icmp_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00990-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ICMP_.ADA 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; --:::::::::::::: --icmp.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00991-100(-) -- E-Systems, Inc. August 07, 1985 -- -- ICMP.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; with IP_UNPACK_AND_PACK_UTILITIES; with UNCHECKED_CONVERSION; with WITH_TCP_COMMUNICATE; with TEXT_IO; package body UTILITIES_FOR_ICMP is package INT_IO is new TEXT_IO.INTEGER_IO( SIXTEEN_BITS ); 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 )" ); INT_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; --:::::::::::::: --reassem_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01004-100(-) -- E-Systems, Inc. August 07, 1985 -- -- REASSEM_.ADA 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; --:::::::::::::: --reassem.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01005-100(-) -- E-Systems, Inc. August 07, 1985 -- -- REASSEM.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_UNPACK_AND_PACK_UTILITIES; with UNCHECKED_CONVERSION; with TEXT_IO; use TEXT_IO; with IP_GLOBALS; with UTILITIES_FOR_ICMP; package body REASSEMBLY_UTILITIES is --------------------------------------------------------- --This implementation is for the DEC/Ada compiler -- --------------------------------------------------------- package INT_IO is new INTEGER_IO( SIXTEEN_BITS ); 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 => PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure INITIALIZE_REASSEMBLY_QUEUE "); when others => PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); 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 => PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure OBTAIN_TOP_OF_REASSEMBLY_TABLE "); when others => PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); 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 => PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure ADD_ENTRY_TO_REASSEMBLY_TABLE "); when others => PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); 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 => PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure ADD_REASSEMBLY_ELEMENT_TO_FREE_LIST "); when others => PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); 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 => PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure DELETE_ENTRY_FROM_REASSEMBLY_TABLE "); when others => PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); 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 => PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure DELETE_REASSEMBLY_STRUCTURE_FROM_FREE_LIST "); when others => PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); 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 => PUT_LINE("CONSTRAINT ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure GET_REASSEMBLY_STRUCTURE "); when others => PUT_LINE("ERROR in package REASSEMBLY_UTILITIES "); 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; PUT("Flag error := "); INT_IO.PUT(BUFPTR.FLAGS); NEW_LINE; 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 => PUT_LINE(" CONSTRAINT_ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure REASS_DONE "); when others => PUT_LINE(" UNKNOWN ERROR in package REASSEMBLY_UTILITIES "); 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 => PUT_LINE(" CONSTRAINT_ERROR in package REASSEMBLY_UTILITIES "); PUT_LINE("procedure REASSEMBLY_TIMEOUT "); when others => PUT_LINE(" UNKNOWN ERROR in package REASSEMBLY_UTILITIES "); 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; PUT("CONSTRAINT ERROR procedure STUFF_DATA_FROM_FRAGMENT"); NEW_LINE; 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; PUT("CONSTRAINT ERROR procedure SET_BIT_MAP "); NEW_LINE; 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; 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; --:::::::::::::: --per1_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01002-100(-) -- E-Systems, Inc. August 07, 1985 -- -- PER1_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- 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. -- ------------------------------------------------------------------------------ type RES is (GOOD, BAD); --***********************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 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 : RES; BUFFTYPE : CONSTANT SIXTEEN_BITS := 1; -- ONLY ONE TYPE OF BUFFER FOR NOW. GLOBAL_PACKED_BUFFER : PACKED_BUFFER_PTR; end TCP_ARRIVES_PERIPHERALS; --:::::::::::::: --per1.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01003-100(-) -- E-Systems, Inc. August 07, 1985 -- -- PER1.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_GLOBALS ; use IP_GLOBALS ; with IP_TCP ; use IP_TCP ; with TCP_TO_ULP_COMMUNICATE ; use TCP_TO_ULP_COMMUNICATE ; with TEXT_IO; use TEXT_IO; with SYSTEM; with UNCHECKED_CONVERSION; with MODULO; use MODULO; with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with TCB_ALLOCATOR; use TCB_ALLOCATOR; package body TCP_ARRIVES_PERIPHERALS is package INT_IO_16 is new INTEGER_IO ( SIXTEEN_BITS ) ; package INT_IO_32 is new INTEGER_IO ( THIRTYTWO_BITS ) ; DUMMY : CHARACTER ; 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 : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 : LCN_PTR_TYPE; MESSAGE_FOR_IP : IP_MESSAGE ; begin -- GET A BUFFER BUFFGET(PACKED_BUFFER, BUFFTYPE); if PACKED_BUFFER = null then -- TELL USER ERROR OUT OF BUFFERS SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFFER.STATUS := OWNER_TCP; PACKED_BUFFER.IN_USE := TRUE; -- 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; MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFFER, LCN.DESTINATION_ADDRESS, TOS, TTL, LEN, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 if BUFPTR.FIN = BIT_SET then PROCESS_A_FIN(LCN, BUFPTR); LCN.STATE := CLOSE_WAIT; end if; exception when constraint_error => PUT_LINE("CONSTRAINT ERROR IN FIN CHECKER"); when others => 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 : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 10, SOCKET_PARAMS, RECEIVE_BUFFER); MESSAGE_FOR_USER(UMESSAGE); -- FREE UP THE BUFFER FROM THE PROCESSED Q SINCE ONE EXISTS. QUEUED_DATA_BUFFER.STATUS := NONE; --PUT_LINE("BUFFREE PROCESS_SEGMENT_TEXT"); --DEBUG JB 7/3/85 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); 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 19, SOCKET_PARAMS, NULL_BUFFER); MESSAGE_FOR_USER(UMESSAGE); end if; -- GIVE IT TO THE USER -- SET UP MESSAGE SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 => PUT_LINE("CONSTRAINT ERROR IN PROCESS SEGMENT TEXT"); INT_IO_16.PUT(RECEIVE_BUFFER.TCP_PTR); INT_IO_16.PUT(NEW_DATA); PUT_LINE(""); when others => 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 : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 => PUT_LINE("CONSTRAINT ERROR IN PROCESS URGENT FLAG"); when others => 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 : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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; --PUT_LINE("BUFFREE PROCESS_A_FIN"); --DEBUG JB 7/3/85 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 => PUT_LINE("CONSTRAINT ERROR IN PROCESS A FIN"); when others => 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_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.STATUS := NONE; PACKED_BUFFER.IN_USE := FALSE; 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; MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFFER, LCN.DESTINATION_ADDRESS, TOS, TTL, LEN, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 => 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_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 MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFF, LCN.DESTINATION_ADDRESS, TOS, TTL, LEN, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 => PUT_LINE("A CONSTRAINT ERROR IN SEND "); PUT_LINE("FROM TRANSMIT QUEUE"); when others => 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 >= SIXTEEN_BITS(2) ** THIRTYTWO_BITS(I) then BIT_ARRAY( THIRTYTWO_BITS(I + SIXTEEN_BITS(1)) ) := SIXTEEN_BITS (1); TEMP := TEMP - SIXTEEN_BITS (2)** THIRTYTWO_BITS(I) ; else BIT_ARRAY( THIRTYTWO_BITS(I + SIXTEEN_BITS (1)) ) := 0; end if; end loop; return BIT_ARRAY; exception when others => PUT_LINE("ERROR IN UNPACK CONVERT BYTES TO BITS"); INT_IO_16.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(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 => PUT_LINE("ERROR IN UNPACK CONVERTED LONG INTEGER"); INT_IO_16.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 for I in 1..2 loop TWO_BYTE_HOLDER(I) := PACKED_BUFFER.BYTE( INDEX + SIXTEEN_BITS(I) - 1 ) ; end loop; HOLD_INTEGER := CONVERT_BYTES_TO_INTEGER(TWO_BYTE_HOLDER); return HOLD_INTEGER(1); exception when others => PUT_LINE("ERROR IN UNPACK CONVERTED INTEGER"); INT_IO_16.PUT(INDEX); end CONVERTED_INTEGER; begin -- MAIN -- PUT UNPACKED DATA IN THE BUFFER UNPACKED_BUFFER.SOURCE_PORT := CONVERTED_INTEGER(INDEX); INDEX := INDEX + 2; UNPACKED_BUFFER.DESTINATION_PORT := CONVERTED_INTEGER(INDEX); INDEX := INDEX + 2; UNPACKED_BUFFER.SEQ_NUM := MODULAR_CONVERT(CONVERTED_LONG_INTEGER(INDEX)); --PUT_LINE("UNPACK.SEQ_NUM(HI) := "); --INT_IO_16.PUT(SIXTEEN_BITS(UNPACKED_BUFFER.SEQ_NUM.HI)); --NEW_LINE; --PUT_LINE("UNPACK.SEQ_NUM(LO) := "); --INT_IO_16.PUT(SIXTEEN_BITS(UNPACKED_BUFFER.SEQ_NUM.LOW)); --NEW_LINE; INDEX := INDEX + 4; UNPACKED_BUFFER.ACK_NUM := MODULAR_CONVERT(CONVERTED_LONG_INTEGER(INDEX)); -- PUT_LINE("UNPACK.ACK_NUM(HI) := "); -- INT_IO_32.PUT(UNPACKED_BUFFER.ACK_NUM.HI); -- NEW_LINE; -- PUT_LINE("UNPACK.ACK_NUM(LO) := "); -- INT_IO_32.PUT(UNPACKED_BUFFER.ACK_NUM.LOW); -- NEW_LINE; 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 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 => PUT_LINE("ERROR IN UNPACK MAIN"); INT_IO_16.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 => PUT_LINE("CONSTRAINT ERROR IN PROCESS COMMON ACK"); when others => 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 => PUT_LINE("CONSTRAINT ERROR IN ENTER ESTABLISHED "); PUT_LINE("STATE PROCESSING"); when others => PUT_LINE("UNKNOWN ERROR IN ENTER ESTABLISHED "); PUT_LINE("STATE PROCESSING"); 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 : LCN_PTR_TYPE; MESSAGE_FOR_IP : IP_MESSAGE ; begin -- CLEAR THE OPTIONS ARRAY AND THE NECESSARY -- EXTRA HEADER OCTETS GET ADDED IN. BUFFGET(PACKED_BUFFER, BUFFTYPE); if PACKED_BUFFER = null then -- TELL USER ERROR OUT OF BUFFERS SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFFER.STATUS := OWNER_TCP; PACKED_BUFFER.IN_USE := TRUE; 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; MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFFER, LCN.DESTINATION_ADDRESS, TOS, TTL, LEN, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 : LCN_PTR_TYPE; MESSAGE_FOR_IP : IP_MESSAGE ; begin -- GET A BUFFER BUFFGET(PACKED_BUFFER, BUFFTYPE); if PACKED_BUFFER = null then -- TELL USER ERROR OUT OF BUFFERS SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFFER.STATUS := OWNER_TCP; PACKED_BUFFER.IN_USE := TRUE; -- 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 MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFFER, LCN.DESTINATION_ADDRESS, TOS, TTL, BUFPTR.DATA_OFFSET * 4 , IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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; --:::::::::::::: --iparrive_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00992-100(-) -- E-Systems, Inc. August 07, 1985 -- -- IPARRIVE_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; use BUFFER_DATA; package IP_ARRIVE_PROCESSING is ----------------------------------------------------- --This implementation is for use with the DEC/ADA -- --compiler. -- ----------------------------------------------------- ------------------------------------------------------------------------------ -- 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); --This subprogram is called by the ip controller when a --datagram arrives for the IP. end IP_ARRIVE_PROCESSING; --:::::::::::::: --iparrive.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00993-100(-) -- E-Systems, Inc. August 07, 1985 -- -- IPARRIVE.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with WITH_TCP_COMMUNICATE; use WITH_TCP_COMMUNICATE; with UNCHECKED_CONVERSION; with SYSTEM; use SYSTEM; with TEXT_IO; use TEXT_IO; with IP_GLOBALS; use IP_GLOBALS; with TCP_Q_TASK; use TCP_Q_TASK; with IP_UNPACK_AND_PACK_UTILITIES; use IP_UNPACK_AND_PACK_UTILITIES; with UTILITIES_FOR_ICMP; with REASSEMBLY_UTILITIES; use REASSEMBLY_UTILITIES; package body IP_ARRIVE_PROCESSING is package INT_IO is new INTEGER_IO( SIXTEEN_BITS ); 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) 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); BYTE_COUNT : SIXTEEN_BITS := 0; 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; --OUTPUT : INTEGER := 0; OUTPUT : FILE_TYPE; REASSEMBLY_TABLE_ELEMENT : REASSEMBLY_UTILITIES.REASSEMBLY_TABLE_POINTER; function ADDRESS_FOR_ME(ADDRESS : THIRTYTWO_BITS ) return BOOLEAN is RESULT : BOOLEAN := FALSE; begin for I in 1..MAX_HOSTS loop 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"); --TEL INTEGER_IO.PUT(I); INT_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 := SIXTEEN_BITS ( 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+10); -- FIRST BYTE OF CSUM BUF_CSUM(2) := PACKED_BUFF.BYTE(PACKED_BUFF.IP_PTR+11); -- 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; -- if PRINT_DATAGRAM_FLAG = 0 then -- PUT_LINE("GOT A BUFFER FROM THE SUBNET"); -- PUT("DESTINATION := "); -- LONG_INTEGER_IO.PUT( BUFPTR.DEST); -- NEW_LINE; -- PUT("VERSION := "); -- INTEGER_IO.PUT(BUFPTR.VERSION); -- NEW_LINE; -- PUT("IHL := "); -- INTEGER_IO.PUT(BUFPTR.IHL); -- NEW_LINE; -- PUT("TOS := "); -- INTEGER_IO.PUT(BUFPTR.TOS); -- NEW_LINE; -- PUT("TOT_LEN := "); -- INTEGER_IO.PUT(BUFPTR.TOT_LEN); -- NEW_LINE; -- PUT("ID := "); -- INTEGER_IO.PUT(BUFPTR.ID); -- NEW_LINE; -- PUT("FLAGS :="); -- INTEGER_IO.PUT(BUFPTR.FLAGS); -- NEW_LINE; -- PUT("FRAG_OFFSET := "); -- INTEGER_IO.PUT(BUFPTR.FRAG_OFFSET); -- NEW_LINE; -- PUT("TTL := "); -- INTEGER_IO.PUT(BUFPTR.TTL); -- NEW_LINE; -- PUT("PROTOCOL := "); -- INTEGER_IO.PUT(BUFPTR.PROT); -- NEW_LINE; -- PUT("IP CHECKSUM := "); -- INTEGER_IO.PUT(BUFPTR.IPCSUM); -- NEW_LINE; -- PUT("SOURCE := "); -- LONG_INTEGER_IO.PUT(BUFPTR.SOURCE); -- NEW_LINE; -- PUT(" THE OPTION DATA IS"); -- NEW_LINE; -- for I in 1..(BUFPTR.IHL - 5) * 4 loop -- X := BUFPTR.IP_OPTIONS(I); -- INTEGER_IO.PUT(X); -- end loop; -- -- provide for separation in output file -- NEW_LINE; -- NEW_LINE; -- end if; -- TEST PRINTER 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); TCP_Q.Q_ADD( TASK_MESSAGE );--SEND TO THE TCP 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. TCP_Q.Q_ADD( TASK_MESSAGE );--SEND TO THE TCP end if; end if; end if; else --/ERROR EXIT: ILLEGAL OPTION/ -- DELETE DATAGRAM PUT("BAD OPTION");--**TESTING BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- WE HAVE TIMED OUT SO DROP THE DATAGRAM. BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- /ERROR EXIT: NOT FOR ME/ -- DELETE DATAGRAM BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- / ERROR: ILLEGAL DESTINATION/ BUFFREE(PACKED_BUFF, BUFFTYPE); end if; else -- BAD CHECKSUM. COUNT IT AND GET OUT BAD_CHECKSUM := BAD_CHECKSUM + 1; BUFFREE(PACKED_BUFF, BUFFTYPE); end if; exception when CONSTRAINT_ERROR => PUT_LINE("CONSTRAINT ERROR IN IPARRIVE"); --TEL INTEGER_IO.PUT(I); INT_IO.PUT(I); when others => PUT_LINE("ERROR IN IPARRIVE");---DEBUG raise; end IP_DATAGRAM_ARRIVE; END IP_ARRIVE_PROCESSING; -- PACKAGE --:::::::::::::: --segarrive_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01008-100(-) -- E-Systems, Inc. August 07, 1985 -- -- SEGARRIVE_.ADA 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; --:::::::::::::: --segarrive.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01009-100(-) -- E-Systems, Inc. August 07, 1985 -- -- SEGARRIVE.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- 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 IP_TCP ; use IP_TCP ; with TCP_TO_ULP_COMMUNICATE ; use TCP_TO_ULP_COMMUNICATE ; with TEXT_IO; use TEXT_IO; with TCP_ARRIVES_PERIPHERALS; use TCP_ARRIVES_PERIPHERALS; with MODULO; use MODULO; with TCB_ALLOCATOR; use TCB_ALLOCATOR; package body TCP_SEGMENT_ARRIVES_PROCESSING is package INT_IO_16 is new INTEGER_IO ( SIXTEEN_BITS ) ; package INT_IO_32 is new INTEGER_IO ( THIRTYTWO_BITS ) ; 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); LCN.STATE := SYN_RECEIVED; ELSE -- THE SEGMENT IS NOT THE ONE WE WANT SO IGNOR IT?? TCP_ERROR(12); END IF; END IF; END IF; END IF; -- RELEASE BUFFER --PUT_LINE("BUFFREE SEG_ARRIVED_IN_LISTEN_STATE");-- DEBUG JB 7/3/85 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 : LCN_PTR_TYPE; 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; SEND_A_RESET(LCN); elsif BUFPTR.RST = BIT_SET then if BUFPTR.ACK = BIT_SET then -- TELL USER -- ERROR: CONNECTION RESET SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 --PUT_LINE("BUFFREE SEGARRIVED_IN_SYN_SENT_STATE"); --DEBUG JB 7/3/85 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 : LCN_PTR_TYPE; 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.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 --PUT_LINE("BUFFREE SEG_ARRIVED_IN_SYN_RECEIVED_STATE"); --DEBUG JB 7/3/85 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 : RES; UMESSAGE : USER_MESSAGE; SOCKET_PARAMS : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 = 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 --PUT_LINE("BUFFREE SEG_ARRIVED_IN_ESTABLISHED_STATE"); --DEBUG JB 7/3/85 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 : 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 = 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); 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 --PUT_LINE("BUFFREE SEG_ARRIVED_IN_FIN_WAIT_1_STATE"); --DEBUG JB 7/3/85 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 : 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 = 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 --PUT_LINE("BUFFREE SEG_ARRIVED_IN_FIN_WAIT_2_STATE"); --DEBUG JB 7/3/85 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 : 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 --PUT_LINE("BUFFREE SEG_ARRIVED_IN_CLOSE_WAIT_STATE"); --DEBUG JB 7/3/85 GLOBAL_PACKED_BUFFER.IN_USE := FALSE; GLOBAL_PACKED_BUFFER.STATUS := NONE; 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 : 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 = 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, BUFFTYPE); 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 : LCN_PTR_TYPE; 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; -- Tell ULP that "OK on close" SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 18, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); -- HERE WE MAY HAVE TO CLEAR THE TCB QUEUE_CLEAR(RECEIVE_QUEUE, LCN); 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, BUFFTYPE); 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, BUFFTYPE); END SEG_ARRIVED_IN_TIME_WAIT_STATE; 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 : RESULT_TYPE; MESSAGE_FOR_IP : 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; MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFFER, LCN.DESTINATION_ADDRESS, TOS, TTL, BUFPTR.DATA_OFFSET * 4, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 := 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 INT_IO_32.PUT(SOURCE_FROM_IP); PUT_LINE(""); -- WHY 128 LOST ON ABORT. INT_IO_16.PUT(BUFPTR.TCP_CSUM); INT_IO_16.PUT( CHECKSUM(BYTE_COUNT, PACKED_BUFFER, DEST, SOURCE_FROM_IP, PROT));---DEBUG PUT_LINE("POINTER AND BYTE COUNT"); INT_IO_16.PUT(PACKED_BUFFER.TCP_PTR); INT_IO_16.PUT(BYTE_COUNT); TCP_ERROR(15); PACKED_BUFFER.IN_USE := FALSE; PACKED_BUFFER.STATUS := NONE; 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 a connection is closing on the same host -- if (LCN.STATE = T_TCP_GLOBALS_DATA_STRUCTURES.CLOSING) then -- LCN_LIST := OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; -- while LCN_LIST /= null 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); PUT_LINE("BUFFREE SEG_ARRIVE"); --DEBUG JB 7/3/85 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 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, RESULTS, TCP_LENGTH); if RESULTS = 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, RESULTS, TCP_LENGTH); if RESULTS = 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, RESULTS, TCP_LENGTH); IF RESULTS = 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, RESULTS, TCP_LENGTH); IF RESULTS = 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, RESULTS, TCP_LENGTH); IF RESULTS = 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, RESULTS, TCP_LENGTH); if RESULTS = 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, RESULTS, TCP_LENGTH); if RESULTS = 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, RESULTS, TCP_LENGTH); if RESULTS = 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; --:::::::::::::: --ip_from_subnet_task_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00994-100(-) -- E-Systems, Inc. August 07, 1985 -- -- IP_FROM_SUBNET_TASK_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- package IP_FROM_SUBNET_TASK is ----------------------------------------------- --This implementation is for the DEC/Ada -- --compiler . -- ----------------------------------------------- task IP_GET_FROM_SUBNET_TASK; --This task will check to see if the subnet protocol --has a message to send to IP. end IP_FROM_SUBNET_TASK; --:::::::::::::: --ip_from_subnet_task.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-00995-100(-) -- E-Systems, Inc. August 07, 1985 -- -- IP_FROM_SUBNET_TASK.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with TEXT_IO; use TEXT_IO; with SUBNET_CALLS; use SUBNET_CALLS; with IP_ARRIVE_PROCESSING; use IP_ARRIVE_PROCESSING; with IP_GLOBALS; use IP_GLOBALS; with CALENDAR; use CALENDAR; with BUFFER_DATA; use BUFFER_DATA; package body IP_FROM_SUBNET_TASK is ----------------------------------------------- --This implementation is for the DEC/Ada -- --compiler . -- ----------------------------------------------- task body IP_GET_FROM_SUBNET_TASK is TIME_OUT_DELAY : constant DAY_DURATION := 1.0; DATAGRAM : PACKED_BUFFER_PTR := null; MESSAGE_TO_IP : IP_MESSAGE; BUFFTYPE : SIXTEEN_BITS := 0; begin loop select SNP.DELIVER( DATAGRAM ); MESSAGE_TO_IP := ( DATA_FROM_SUBNET, DATAGRAM, 0 ); -- PUT_LINE(" Just received a message from the SUBNET");--DEBUG JB 6/3/85 IP_DATAGRAM_ARRIVE( MESSAGE_TO_IP.BUFPTR ); or delay( TIME_OUT_DELAY ); end select; end loop; end IP_GET_FROM_SUBNET_TASK; end IP_FROM_SUBNET_TASK; --:::::::::::::: --tcp_utilities_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01027-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_UTILITIES_.ADA 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 LCN_PTR_TYPE ; 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; --:::::::::::::: --tcp_utilities.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01028-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_UTILITIES.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with IP_TCP ; use IP_TCP ; with TCP_TO_ULP_COMMUNICATE ; use TCP_TO_ULP_COMMUNICATE ; 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; package body T_TCP_CONTROLLER_UTILITIES is package INT_IO_16 is new INTEGER_IO ( SIXTEEN_BITS ) ; 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 : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 1, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else PACKED_BUFF.STATUS := OWNER_TCP; PACKED_BUFF.IN_USE := TRUE; 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; MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFF, DEST, TOS, TTL, HEADER_LENGTH, IDENT, DONT_FRAGMENT, OPTIONS, SOURCE ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 : LCN_PTR_TYPE; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; DUMMY : CHARACTER; begin -- PUT_LINE("HIT ANY CHARACTER TO CONTINUE"); -- GET(DUMMY); 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER -- ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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; MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFF, LCN.DESTINATION_ADDRESS, TOS, TTL, LEN, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 NEW_LINE; -- if QUEUE_FREE_LIST.NEXT = null then -- PUT("QUEUE_FREE_LIST = null "); -- else -- Put("QUEUE_FREE_LIST /= null "); -- end if; -- NEW_LINE; QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); -- WECOULD MESS WITH OUR RECEIVE WINDOW HERE IF WE WISHED. -- NEW_LINE; -- PUT_LINE("AFTER QUEUE_ADD TCP_SEND"); -- if QUEUE_FREE_LIST.NEXT = null then -- PUT("QUEUE_FREE_LIST = null "); -- else -- Put("QUEUE_FREE_LIST /= null "); -- end if; -- NEW_LINE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 5, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); end if; end if; when others => -- TELL USER ERROR: CONNECTION CLOSING SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 : LCN_PTR_TYPE; DUMMY : CHARACTER; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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. if QUEUE_FREE_LIST.NEXT = null then NEW_LINE; PUT_LINE("QUEUE_FREE_LIST.NEXT TCP_RECEIVE = null"); PUT_LINE("STRIKE ANY CHARACTER TO CONTINUE"); GET(DUMMY); end if; QUEUE_GET(PROCESSED_SEGMENTS_FOR_USER_QUEUE, LCN, Q_ITEM); -- if QUEUE_FREE_LIST.NEXT = null then -- NEW_LINE; -- PUT_LINE("QUEUE_FREE_LIST.NEXT TCP_RECEIVE = null"); -- PUT_LINE("STRIKE ANY CHARACTER TO CONTINUE"); -- GET(DUMMY); -- end if; PROCESSED_BYTE_COUNT := Q_ITEM.LENGTH; -- if QUEUE_FREE_LIST.NEXT = null then -- NEW_LINE; -- PUT_LINE("QUEUE_FREE_LIST.NEXT TCP_RECEIVE = null"); -- PUT_LINE("STRIKE ANY CHARACTER TO CONTINUE"); -- GET(DUMMY); -- end if; PACKED_BUFFER := Q_ITEM.BUFFER; -- if QUEUE_FREE_LIST.NEXT = null then -- NEW_LINE; -- PUT_LINE("QUEUE_FREE_LIST.NEXT TCP_RECEIVE = null"); -- PUT_LINE("STRIKE ANY CHARACTER TO CONTINUE"); -- GET(DUMMY); -- end if; if PACKED_BUFFER = null then -- PUT REQUEST ON QUEUE FOR LATER PROCESSING -- if QUEUE_FREE_LIST.NEXT = null then -- NEW_LINE; -- PUT_LINE("QUEUE_FREE_LIST.NEXT TCP_RECEIVE = null"); -- PUT_LINE("STRIKE ANY CHARACTER TO CONTINUE"); -- GET(DUMMY); -- end if; Q_ITEM := (PACKED_BUFF, NULL_UNPACKED_BUFFER, BYTE_COUNT); -- if QUEUE_FREE_LIST.NEXT = null then -- NEW_LINE; -- PUT_LINE("QUEUE_FREE_LIST.NEXT TCP_RECEIVE = null"); -- PUT_LINE("STRIKE ANY CHARACTER TO CONTINUE"); -- GET(DUMMY); -- end if; QUEUE_ADD(RECEIVE_QUEUE, LCN, Q_ITEM, RECEIVE_QUEUE_FULL); -- if QUEUE_FREE_LIST.NEXT = null then -- NEW_LINE; -- PUT_LINE("QUEUE_FREE_LIST.NEXT TCP_RECEIVE = null"); -- PUT_LINE("STRIKE ANY CHARACTER TO CONTINUE"); -- GET(DUMMY); -- end if; if RECEIVE_QUEUE_FULL then -- TELL USER ERROR: INSUFFICIENT RESOURCES PUT_LINE("NO Q RM IN SEND");-- DEBUG SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 CLOSING | TIME_WAIT | LAST_ACK => -- TELL USER ERROR: CONNECTION CLOSING SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 : LCN_PTR_TYPE; MESSAGE_FOR_IP : IP_GLOBALS.IP_MESSAGE ; TEMP_LCN : TCB_PTR ; begin TEMP_LCN := LCN; -- To contain modification locally***** 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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; -- TELL USER OK SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 8, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); TCB_CLEAR(LCN); TCB_FREE( TEMP_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); -- TELL USER OK SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 8, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); TCB_CLEAR(LCN); TCB_FREE( TEMP_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 := OWNER_TCP; 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; -- TELL USER OK SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 8, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); -- PACK THE BUFFER PACK_BUFFER_INTO_BIT_STREAM(BUFPTR, PACKED_BUFF); LEN := BUFPTR.DATA_OFFSET * 4;-- SINCE NO DATA SENT MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFF, LCN.DESTINATION_ADDRESS, TOS, TTL, LEN, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; 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 => -- CLEAR THE TCB AND ENTER THE CLOSED STATE QUEUE_CLEAR(RECEIVE_QUEUE, LCN); TCB_CLEAR(LCN); -- PUT IN A KNOWN STATE TCB_FREE ( TEMP_LCN ); end case; end TCP_ABORT; 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 : USER_MESSAGE; SOCKET_PARAMS : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 20, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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.STATUS := OWNER_TCP; PACKED_BUFF.IN_USE := TRUE; 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); MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFF, LCN.DESTINATION_ADDRESS, TOS, TTL, TCP_HEAD_AND_DATA_LENGTH, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; -- 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 2, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else -- TELL USER ERROR: CONNECTION DOES NOT EXIST SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 LCN_PTR_TYPE ; 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 : LCN_PTR_TYPE; begin -- if ACTIVE_PASSIVE = WITH_TCP_COMMUNICATE.PASSIVE then LCN := TCB_GET; -- SEND THE LCN BACK TO THE USER. TCB_CLEAR( LCN ) ; -- Clear TCB. SOCKET_PARAMS.LCN := LCN ; LCN.TCP_CHANNEL_NAME := LOCAL_CONN_NAME.CHANNEL_NAME ; LCN.TCP_CHANNEL_PTR := LOCAL_CONN_NAME.CHANNEL_PTR ; SOCKET_PARAMS.CHANNEL_NAME := LOCAL_CONN_NAME.CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LOCAL_CONN_NAME.CHANNEL_PTR ; LOCAL_CONN_NAME.LCN := LCN ; UMESSAGE := (14, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); LCN.LOCAL_PORT := LOCAL_PORT; -- else --set lcn -- LCN := LOCAL_CONN_NAME.LCN; -- 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 11, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); elsif FOREIGN_NET_HOST = 0 then -- TELL USER ERROR: FOREIGN SOCKET UNSPECIFIED SOCKET_PARAMS.LCN := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 : WITH_TCP_COMMUNICATE.STATUS_TYPE; STATUS_REC : STATUS_RECORD; UMESSAGE :USER_MESSAGE; SOCKET_PARAMS : LCN_PTR_TYPE; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; UMESSAGE := ( 3, SOCKET_PARAMS); MESSAGE_FOR_USER(UMESSAGE); else NEW_LINE; --FOR DEBUG PUT_LINE("ULP just requested a STATUS"); 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_TCP_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 := LCN; SOCKET_PARAMS.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; 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; MESSAGE_FOR_IP := ( FROM_TCP, PACKED_BUFF, LCN.DESTINATION_ADDRESS, TOS, TTL, BYTE_COUNT, IDENT, DONT_FRAGMENT, OPTIONS, LCN.SOURCE_ADDRESS ) ; IP_FROM_TCP.Q_ADD( MESSAGE_FOR_IP ) ; end if; QUEUE_ADD(TCP_RETRANSMIT_QUEUE, LCN, Q_ITEM); else TCP_ERROR(4); end if; end RETRANS_TCP; end T_TCP_CONTROLLER_UTILITIES; --:::::::::::::: --tcp_controller_.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01014-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_CONTROLLER_.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- package TCP_CONTROLLER_TASK is -------------------------------------------------------------- --This implementation is for the DEC/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. -- ------------------------------------------------------------------------------ task 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 ; --:::::::::::::: --tcp_controller.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01015-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_CONTROLLER.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- 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 TCP_TO_ULP_COMMUNICATE ; use TCP_TO_ULP_COMMUNICATE ; 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_TCP_COMMUNICATE ; use WITH_TCP_COMMUNICATE ; with TEXT_IO ; use TEXT_IO ; with GET_MESSAGES_FROM_ULP ; use GET_MESSAGES_FROM_ULP ; with TCP_Q_TASK ; use TCP_Q_TASK ; with CALENDAR ; use CALENDAR ; package body TCP_CONTROLLER_TASK is -------------------------------------------------------------- --This implementation is for the DEC/Ada compiler . -- -------------------------------------------------------------- task body TCP_CONTROLLER is package int_io_32 is new integer_io (thirtytwo_bits); MESSAGE_FROM_IP : MESSAGE ; UMESSAGE : USER_MESSAGE; TASK_MESSAGE : MESSAGE; FLAG : BOOLEAN := TRUE; -- for message RETRANSMIT : BOOLEAN := TRUE; MAX_TEMP : SIXTEEN_BITS ; SOCKET_PARAMS : LCN_PTR_TYPE; TIMEOUT : constant DAY_DURATION := 1.0 ; 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 loop --determine if any timeouts have occurred LCN := OBTAIN_HEAD_OF_LCN_IN_USE_QUEUE; while LCN /= null loop -- put("system time = "); -- int_io_32.put(thirtytwo_bits(system_time)); -- 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.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; SOCKET_PARAMS.LCN := 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.CHANNEL_NAME := LCN.TCP_CHANNEL_NAME ; SOCKET_PARAMS.CHANNEL_PTR := LCN.TCP_CHANNEL_PTR ; SOCKET_PARAMS.LCN := 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; select TCP_Q.Q_GET ( 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_BLOCK.LCN ) then TCP_SEND( TASK_MESSAGE.SEND_PARAMETERS.LCN_BLOCK.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_BLOCK.LCN ) then TCP_RECEIVE( TASK_MESSAGE.RECEIVE_PARAMETERS.LCN_BLOCK.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_BLOCK.LCN) then TCP_ABORT( TASK_MESSAGE.ABORT_CLOSE_PARAMETERS.LCN_BLOCK.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_BLOCK.LCN ) then TCP_CLOSE( TASK_MESSAGE.ABORT_CLOSE_PARAMETERS.LCN_BLOCK.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_BLOCK, 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_BLOCK.LCN ) then TCP_STATUS( TASK_MESSAGE.STATUS_PARAMETERS.LCN_BLOCK.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 => -- put_line("NO_TCP_ACTION");--for debug (JB 1/31/85) null; end case; or DELAY ( TIMEOUT ) ; end select ; end loop ; 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 ; --:::::::::::::: --tcp_standalone.ada --:::::::::::::: ----------------------------------------------------------------------- -- -- DoD Protocols NA-00001-200 80-01022-100(-) -- E-Systems, Inc. August 07, 1985 -- -- TCP_STANDALONE.ADA Author : Jim Baldo -- ----------------------------------------------------------------------- with BUFFER_DATA; with ip_tcp; with SUBNET_CALLS; use SUBNET_CALLS; with TCP_Q_TASK; with GET_MESSAGES_FROM_ULP; with SEND_IP_TASK; with IP_FROM_SUBNET_TASK; with TCP_CONTROLLER_TASK; procedure TCP_STANDALONE is begin START_SUBNET_DRIVER ; -- null; end TCP_STANDALONE ; --:::::::::::::: --delete_mailboxes.ada --:::::::::::::: with SYSTEM ; use SYSTEM ; with TASKING_SERVICES; use TASKING_SERVICES; with STARLET; use STARLET; with CONDITION_HANDLING; use CONDITION_HANDLING; with TEXT_IO; use TEXT_IO; procedure DELETE_MAILBOXES_FOR_TESTER is -- This procedure is used to delete permanent mailboxes created by -- test programs. MAILBOX_NAMES_CHANNEL : CHANNEL_TYPE; TO_TCP_CHANNEL : CHANNEL_TYPE; RETURN_STATUS : COND_VALUE_TYPE; MAILBOX_NAME : STRING(1..7) ; TEMP_MAILBOX_NAME : STRING(1..4); LENGTH : NATURAL ; begin loop MAILBOX_NAME := "MBA " ; TEMP_MAILBOX_NAME := " "; PUT("Enter Mailbox Number := ") ; GET_LINE(TEMP_MAILBOX_NAME, LENGTH) ; if TEMP_MAILBOX_NAME(1) = '0' then exit ; end if ; for I in 1..4 loop if TEMP_MAILBOX_NAME(I) /= ' ' then MAILBOX_NAME(3 + I) := TEMP_MAILBOX_NAME(I); else MAILBOX_NAME(3 + I) := ':'; exit; end if; end loop; ASSIGN( STATUS => RETURN_STATUS, CHAN => TO_TCP_CHANNEL, DEVNAM => MAILBOX_NAME); if SUCCESS ( RETURN_STATUS ) then PUT_LINE ( "Successful assign TO MAILBOX " ) ; else PUT_LINE ( "Unsuccessful assign TO_MAILBOX " ) ; end if ; DELMBX( STATUS => RETURN_STATUS, CHAN => TO_TCP_CHANNEL ); if SUCCESS ( RETURN_STATUS ) then PUT_LINE ( "Successful delete TO_MAILBOX " ) ; else PUT_LINE ( "Unsuccessful delete TO_MAILBOX " ) ; end if ; end loop ; end DELETE_MAILBOXES_FOR_TESTER ;