diff --git a/obsolete/tcp/TCP b/obsolete/tcp/TCP
new file mode 100644
index 00000000..49a212eb
--- /dev/null
+++ b/obsolete/tcp/TCP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Aug-90 12:01:50" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCP.;5 98103  

      changes to%:  (FILES TCPLLIP)
                    (FNS \TCP.DELETE.TCB)

      previous date%: "13-Feb-89 21:04:17" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCP.;3)


(* "
Copyright (c) 1983, 1984, 1985, 1986, 1901, 1900, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPCOMS)

(RPAQQ TCPCOMS 
       [(COMS 
              (* ;; "Transmission Control Protocol.  RFC 793, September 1981")
)
        (COMS (DECLARE%: EVAL@LOAD (FILES (SYSLOAD)
                                          TCPLLIP))
              (GLOBALVARS \TCP.LOCK \TCP.CONTROL.BLOCKS \TCP.CHECKSUMS.ON \TCP.PSEUDOHEADER \TCP.MSL
                     \TCP.DEFAULT.USER.TIMEOUT \TCP.DEFAULT.RECEIVE.WINDOW \TCP.DEVICE 
                     \TCP.MASTER.SOCKET))
        (COMS 
              (* ;; "DoD Internet addresses")

              (FNS SET.IP.ADDRESS STRING.TO.IP.ADDRESS IP.ADDRESS.TO.STRING \LOCAL.IP.ADDRESS))
        [COMS 
              (* ;; "TCP segments")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "control bits for TCP.CTRL field of TCP header")

                     (EXPORT (CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST 
                                    \TCP.CTRL.SYN \TCP.CTRL.URG)
                            
                            (* ;; "option definitions")

                            (CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG)
                            
                            (* ;; "TCP protocol number for IP level dispatch")

                            (CONSTANTS \TCP.PROTOCOL)
                            
                            (* ;; "TCP header length in bytes (= 4 * min data offset)")

                            (CONSTANTS \TCP.HEADER.LENGTH)
                            
                            (* ;; 
                        "minimum offset of data from segment in 32-bit words (= header length / 4)")

                            (CONSTANTS \TCP.MIN.DATA.OFFSET)
                            
                            (* ;; "default maximum segment size")

                            (CONSTANTS \TCP.DEFAULT.MAXSEG)
                            
                            (* ;; "TCP segment")

                            (RECORDS TCPSEGMENT]
        (COMS 
              (* ;; "TCP sequence numbers")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "macros for comparing TCP sequence numbers")

                     (MACROS \32BIT.EQ \32BIT.LT \32BIT.LEQ \32BIT.GT \32BIT.GEQ)
                     
                     (* ;; "fast multiply by 3 -- evaluates its argument twice")

                     (MACROS \3TIMES))
              (FNS \TCP.SELECT.ISS))
        (COMS 
              (* ;; "TCP control blocks")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "TCP control block")

                     (EXPORT (RECORDS TCP.CONTROL.BLOCK TCPSTREAM))
                     
                     (* ;; "TCP stream")
)
              (INITRECORDS TCP.CONTROL.BLOCK TCPSTREAM)
              
              (* ;; "global lock for TCP-related mutual exclusion")

              (INITVARS (\TCP.LOCK (CREATE.MONITORLOCK)))
              
              (* ;; "list of TCP control blocks for connection lookup")

              (INITVARS (\TCP.CONTROL.BLOCKS NIL))
              (FNS \TCP.CREATE.TCB \TCP.SELECT.PORT \TCP.LOOKUP.TCB \TCP.DELETE.TCB \TCP.NOSOCKETFN 
                   \TCP.PORTCOMPARE))
        (COMS 
              (* ;; "TCP checksums")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "pseudo-header for checksum calculation")

                     (RECORDS TCP.PSEUDOHEADER)
                     (CONSTANTS \TCP.PSEUDOHEADER.LENGTH)
                     (MACROS \16BIT.COMPLEMENT \16BIT.1C.PLUS))
              (INITRECORDS TCP.PSEUDOHEADER)
              (INITVARS (\TCP.PSEUDOHEADER NIL))
              
              (* ;; "this variable controls whether checksums are performed on incoming segments")

              (INITVARS (\TCP.CHECKSUMS.ON NIL))
              
              (* ;; "checksum routines")

              (FNS \COMPUTE.CHECKSUM \TCP.CHECKSUM.INCOMING \TCP.CHECKSUM.OUTGOING))
        (COMS (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "constants for retransmission timeout calculation")

                     
                     (* ;; "initial retransmission timeout")

                     (CONSTANTS \TCP.INITIAL.RTO)
                     
                     (* ;; "upper and lower bounds on retransmission timeout")

                     (CONSTANTS (\TCP.UBOUND 5000)
                            (\TCP.LBOUND 1000)))
              
              (* ;; "maximum segment lifetime")

              (INITVARS (\TCP.MSL 5000))
              (INITVARS (\TCP.DEFAULT.USER.TIMEOUT 60000)
                     (\TCP.DEFAULT.RECEIVE.WINDOW 4096)
                     (\TCP.DEVICE NIL))
              
              (* ;; "TCP protocol routines")

              (FNS \TCP.ACK# \TCP.PACKET.FILTER \TCP.SETUP.SEGMENT \TCP.RELEASE.SEGMENT 
                   \TCP.CONNECTION \TCP.FIX.INCOMING.SEGMENT \TCP.DATA.LENGTH \TCP.SYN.OR.FIN 
                   \TCP.INPUT \TCP.INPUT.INITIAL \TCP.INPUT.UNSYNC \TCP.INPUT.LISTEN 
                   \TCP.INPUT.SYN.SENT \TCP.CHECK.WINDOW \TCP.CHECK.RESET \TCP.CHECK.SECURITY 
                   \TCP.CHECK.NO.SYN \TCP.CHECK.ACK \TCP.HANDLE.ACK \TCP.HANDLE.URG \TCP.QUEUE.INPUT
                   \TCP.HANDLE.FIN \TCP.OUR.FIN.IS.ACKED \TCP.SIGNAL.URGENT.DATA \TCP.PROCESS 
                   \TCP.TEMPLATE \TCP.SETUP.SEGMENT.OPTIONS \TCP.SEND.CONTROL \TCP.SEND.ACK 
                   \TCP.SEND.RESET \TCP.FIX.OUTGOING.SEGMENT \TCP.SEND.DATA \TCP.SEND.SEGMENT 
                   \TCP.NEW.TEMPLATE \TCP.START.PROBE.TIMER \TCP.RETRANSMIT \TCP.START.TIME.WAIT 
                   \TCP.CONNECTION.DROPPED \TCP.CHECK.OPTIONS \TCP.PROCESS.OPTIONS))
        (COMS 
              (* ;; "support for ICMP messages that affect TCP connections")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "ICMP protocol number for IP level dispatch")

                     (CONSTANTS \ICMP.PROTOCOL)
                     
                     (* ;; 
                   "number of 32 bit words in ICMP message before start of original datagram")

                     (CONSTANTS \ICMP.32BIT.WORDS)
                     
                     (* ;; "relevant ICMP message types")

                     (CONSTANTS \ICMP.DESTINATION.UNREACHABLE \ICMP.SOURCE.QUENCH))
              (FNS \TCP.HANDLE.ICMP))
        (COMS 
              (* ;; "TCP stream routines")

              (FNS TCP.OPEN TCP.OTHER.STREAM \TCP.BOUTS \TCP.OTHER.BIN \TCP.OTHER.BOUT \TCP.BIN 
                   \TCP.BACKFILEPTR \TCP.GETNEXTBUFFER \TCP.GET.SEGMENT \TCP.PEEKBIN \TCP.GETFILEPTR
                   \TCP.READP \TCP.EOFP TCP.URGENTP TCP.URGENT.EVENT \TCP.BOUT \TCP.FLUSH 
                   \TCP.FORCEOUTPUT TCP.URGENT.MARK \TCP.FILL.IN.SEGMENT \TCP.CLOSE \TCP.RESETCLOSE 
                   TCP.CLOSE.SENDER TCP.DESTADDRESS TCP.STOP))
        (COMS 
              (* ;; "well-known ports for network standard functions")

              (CONSTANTS * \TCP.ASSIGNED.PORTS))
        (COMS 
              (* ;; "Stub for debugging")

              (INITVARS (\TCP.DEBUGGABLE)
                     (TCPTRACEFLG))
              (GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG)
              (FNS PPTCB \TCP.TRACE.SEGMENT \TCP.TRACE.TRANSITION))
        (COMS 
              (* ;; "TCP initialization")

              (FNS \TCP.INIT)
              (P (\TCP.INIT])



(* ;; "Transmission Control Protocol.  RFC 793, September 1981")

(DECLARE%: EVAL@LOAD 

(FILESLOAD (SYSLOAD)
       TCPLLIP)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCP.LOCK \TCP.CONTROL.BLOCKS \TCP.CHECKSUMS.ON \TCP.PSEUDOHEADER \TCP.MSL 
       \TCP.DEFAULT.USER.TIMEOUT \TCP.DEFAULT.RECEIVE.WINDOW \TCP.DEVICE \TCP.MASTER.SOCKET)
)



(* ;; "DoD Internet addresses")

(DEFINEQ

(SET.IP.ADDRESS
(LAMBDA NIL (* ejs%: "28-Dec-84 18:45") (* set local IP address manually) (PROG ((ADDR (\IP.READ.STRING.ADDRESS (PROMPTFORWORD "Enter IP address:" (\IP.ADDRESS.TO.STRING (OR (CAR \IP.LOCAL.ADDRESSES) 0)))))) (SETQ \IP.LOCAL.ADDRESSES (LIST ADDR))))
)

(STRING.TO.IP.ADDRESS
(LAMBDA (STR) (* ecc "14-May-84 15:01") (APPLY (FUNCTION IP\Make\Address) (to 4 bind (I _ 0) OFFSET collect (SETQ OFFSET (ADD1 I)) (MKATOM (SUBSTRING STR OFFSET (AND (SETQ I (STRPOS "." STR OFFSET)) (SUB1 I)))))))
)

(IP.ADDRESS.TO.STRING
(LAMBDA (IPADDR) (* ecc "14-May-84 14:32") (PROG ((A (LOADBYTE IPADDR 24 8)) (B (LOADBYTE IPADDR 16 8)) (C (LOADBYTE IPADDR 8 8)) (D (LOADBYTE IPADDR 0 8))) (RETURN (CONCAT A "." B "." C "." D))))
)

(\LOCAL.IP.ADDRESS
(LAMBDA NIL (* ejs%: "28-Dec-84 18:45") (* return our IP address (or the first if we're multi-homed)) (if (NULL \IP.LOCAL.ADDRESSES) then (ERROR "You must set \IP.LOCAL.ADDRESSES to a list of our local IP addresses")) (CAR \IP.LOCAL.ADDRESSES))
)
)



(* ;; "TCP segments")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.CTRL.ACK 16)

(RPAQQ \TCP.CTRL.FIN 1)

(RPAQQ \TCP.CTRL.PSH 8)

(RPAQQ \TCP.CTRL.RST 4)

(RPAQQ \TCP.CTRL.SYN 2)

(RPAQQ \TCP.CTRL.URG 32)


(CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCPOPT.END 0)

(RPAQQ \TCPOPT.NOP 1)

(RPAQQ \TCPOPT.MAXSEG 2)


(CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.PROTOCOL 6)


(CONSTANTS \TCP.PROTOCOL)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.HEADER.LENGTH 20)


(CONSTANTS \TCP.HEADER.LENGTH)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.MIN.DATA.OFFSET 5)


(CONSTANTS \TCP.MIN.DATA.OFFSET)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.DEFAULT.MAXSEG 536)


(CONSTANTS \TCP.DEFAULT.MAXSEG)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS TCPSEGMENT ((TCPHEADER (\IPDATABASE DATUM)))
                          (BLOCKRECORD TCPHEADER ((TCP.SRC.PORT WORD)
                                                  (TCP.DST.PORT WORD)
                                                  (TCP.SEQ FIXP)
                                                  (TCP.ACK FIXP)
                                                  (TCP.DATA.OFFSET BITS 4)
                                                  (TCP.MBZ BITS 6)
                                                  (TCP.CTRL BITS 6)
                                                  (TCP.WINDOW WORD)
                                                  (TCP.CHECKSUM WORD)
                                                  (TCP.URG.PTR WORD)))
                          [ACCESSFNS TCPSEGMENT ((TCP.DATA.LENGTH (fetch (IP IPHEADERCHECKSUM)
                                                                     of DATUM)
                                                        (replace (IP IPHEADERCHECKSUM)
                                                           of DATUM with NEWVALUE))
                                                 (TCP.SRC.ADDR (fetch (IP IPSOURCEADDRESS)
                                                                  of DATUM)
                                                        (replace (IP IPSOURCEADDRESS)
                                                           of DATUM with NEWVALUE))
                                                 (TCP.DST.ADDR (fetch (IP IPDESTINATIONADDRESS)
                                                                  of DATUM)
                                                        (replace (IP IPDESTINATIONADDRESS)
                                                           of DATUM with NEWVALUE))
                                                 (TCP.HEADER.LENGTH (LLSH (fetch TCP.DATA.OFFSET
                                                                             of DATUM)
                                                                          2))
                                                 (TCP.CONTENTS (\ADDBASE (fetch TCPHEADER
                                                                            of DATUM)
                                                                      (UNFOLD (fetch 
                                                                                     TCP.DATA.OFFSET
                                                                                 of DATUM)
                                                                             WORDSPERCELL)))
                                                 (TCP.OPTIONS (\ADDBASE (fetch TCPHEADER
                                                                           of DATUM)
                                                                     (UNFOLD \TCP.MIN.DATA.OFFSET 
                                                                            WORDSPERCELL])
)

(* "END EXPORTED DEFINITIONS")

)



(* ;; "TCP sequence numbers")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \32BIT.EQ MACRO ((A B)
                           (IEQP A B)))

(PUTPROPS \32BIT.LT MACRO ((A B)
                           (ILESSP (IDIFFERENCE A B)
                                  0)))

(PUTPROPS \32BIT.LEQ MACRO ((A B)
                            (ILEQ (IDIFFERENCE A B)
                                  0)))

(PUTPROPS \32BIT.GT MACRO ((A B)
                           (IGREATERP (IDIFFERENCE A B)
                                  0)))

(PUTPROPS \32BIT.GEQ MACRO ((A B)
                            (IGEQ (IDIFFERENCE A B)
                                  0)))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \3TIMES MACRO ((N)
                         (IPLUS (LLSH N 1)
                                N)))
)
)
(DEFINEQ

(\TCP.SELECT.ISS
(LAMBDA NIL (* ecc "16-May-84 11:40") (* select an initial send sequence number -- use the time of day to make sure we won't repeat after a crash) (LOGAND (DAYTIME) 65535))
)
)



(* ;; "TCP control blocks")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(DATATYPE TCP.CONTROL.BLOCK ((TCB.LOCK POINTER)          (* monitor lock for synchronizing 
                                                           access)
                                 (TCB.STATE POINTER)         (* one of CLOSED LISTEN SYN.SENT 
                                                           SYN.RECEIVED ESTABLISHED FIN.WAIT.1 
                                                           FIN.WAIT.2 CLOSE.WAIT CLOSING 
                                                           LAST.ACK TIME.WAIT)
                                 (TCB.SND.STREAM POINTER)    (* user's send stream)
                                 (TCB.SND.SEGMENT POINTER)   (* current output packet being 
                                                           filled)
                                 (TCB.RCV.STREAM POINTER)    (* user's receive stream)
                                 (TCB.RCV.SEGMENT POINTER)   (* current input packet being read)
                                 (TCB.2MSL.TIMER POINTER)    (* 2*MSL quiet time)
                                 (TCB.MAXSEG POINTER)        (* maximum segment size)
                                 (TCB.CLOSEDFLG POINTER)     (* T if user has initiated close
                                                           (no more data to send))
                                 (TCB.FINSEQ POINTER)        (* one past the sequence number of 
                                                           the FIN we sent)
                                 (TCB.ACKFLG POINTER)        (* when to ACK peer%: NOW or LATER)
                                 (TCB.TEMPLATE POINTER)      (* TCP header template)
                                 (TCB.PH POINTER)            (* TCP pseudo-header for 
                                                           checksumming)
                                 (TCB.SRC.PORT WORD)         (* local port)
                                 (TCB.DST.PORT WORD)         (* remote port)
                                 (TCB.DST.HOST FIXP)         (* remote host address)
                                 (TCB.INPUT.QUEUE POINTER)   (* queue of received segments to be 
                                                           read)
                                 (TCB.REXMT.QUEUE POINTER)   (* queue of unacked segments to be 
                                                           retransmitted)
                                 (TCB.SND.UNA FIXP)          (* first unacknowledged sequence 
                                                           number)
                                 (TCB.SND.NXT FIXP)          (* next sequence number to be sent)
                                 (TCB.SND.UP FIXP)           (* send urgent pointer)
                                 (TCB.SND.WL1 FIXP)          (* segment sequence number used for 
                                                           last window update)
                                 (TCB.SND.WL2 FIXP)          (* segment acknowledgment number 
                                                           used for last window update)
                                 (TCB.ISS FIXP)              (* initial send sequence number)
                                 (TCB.SND.WND WORD)          (* send window)
                                 (TCB.RCV.WND WORD)          (* receive window)
                                 (TCB.RCV.NXT FIXP)          (* next sequence number expected)
                                 (TCB.RCV.UP FIXP)           (* receive urgent pointer)
                                 (TCB.IRS FIXP)              (* initial receive sequence number)
                                 (TCB.USER.TIMEOUT POINTER)  (* in milliseconds)
                                 (TCB.ESTABLISHED POINTER)   (* processes waiting for this event 
                                                           are notified when the connection 
                                                           becomes established)
                                 (TCB.SND.EVENT POINTER)     (* processes waiting for this event 
                                                           are notified when the send window 
                                                           opens up)
                                 (TCB.RCV.EVENT POINTER)     (* processes waiting for this event 
                                                           are notified when data is received)
                                 (TCB.URGENT.EVENT POINTER)  (* processes waiting for this event 
                                                           are notified when urgent data is 
                                                           received)
                                 (TCB.FINACKED.EVENT POINTER)(* processes waiting for this event 
                                                           are notified when our FIN has been 
                                                           acked)
                                 (TCB.MODE POINTER)          (* ACTIVE or PASSIVE)
                                 (TCB.RTFLG POINTER)         (* T if round trip time being 
                                                           measured)
                                 (TCB.RTSEQ POINTER)         (* sequence number being timed)
                                 (TCB.RTTIMER POINTER)       (* round trip timer)
                                 (TCB.SRTT POINTER)          (* smoothed round trip time)
                                 (TCB.RTO POINTER)           (* retransmission timeout based on 
                                                           smoothed round trip time)
                                 (TCB.PROBE.TIMER POINTER)   (* timer for delayed ACKs and window 
                                                           probes)
                                 (TCB.IPSOCKET POINTER)      (* Pointer to open IP socket for 
                                                           this connection)
                                 (TCB.PROCESS POINTER)       (* TCP monitor process for this 
                                                           connection)
                                 (TCB.SENT.ZERO FLAG)        (* Sent a zero allocation last time)
                                 (TCB.OUTPUT.HELD FLAG)      (* True if output window shut)
                                 (TCB.NO.IDLE.PROBING FLAG)  (* True if we don't probe when 
                                                           nothing to output)
                                 (NIL BITS 5)
                                 (TCB.OUR.MAXSEG WORD)
                                 (TCB.LAST.SENT.RCV.WND WORD)(* The value of the last rcv window 
                                                           we sent)
                                 )
                                TCB.LOCK _ (CREATE.MONITORLOCK)
                                TCB.STATE _ 'CLOSED TCB.RCV.WND _ \TCP.DEFAULT.RECEIVE.WINDOW 
                                TCB.USER.TIMEOUT _ \TCP.DEFAULT.USER.TIMEOUT TCB.ESTABLISHED _ (
                                                                                         CREATE.EVENT
                                                                                                )
                                TCB.SND.EVENT _ (CREATE.EVENT)
                                TCB.RCV.EVENT _ (CREATE.EVENT)
                                TCB.URGENT.EVENT _ (CREATE.EVENT)
                                TCB.FINACKED.EVENT _ (CREATE.EVENT)
                                TCB.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.OUR.MAXSEG _ \TCP.DEFAULT.MAXSEG
                                TCB.SRTT _ \TCP.INITIAL.RTO TCB.RTO _ \TCP.INITIAL.RTO)

(ACCESSFNS TCPSTREAM ((TCB (fetch (STREAM F1) of DATUM)
                               (replace (STREAM F1) of DATUM with NEWVALUE))
                          (BYTECOUNT (fetch (STREAM F2) of DATUM)
                                 (replace (STREAM F2) of DATUM with NEWVALUE))
                          (ACCESS (fetch (STREAM ACCESS) of DATUM)
                                 (replace (STREAM ACCESS) of DATUM with NEWVALUE))
                          (ORIGINAL.COFFSET (fetch (STREAM FW6) of DATUM)
                                 (replace (STREAM FW6) of DATUM with NEWVALUE)))
                         (CREATE (create STREAM
                                            DEVICE _ \TCP.DEVICE)))
)

(/DECLAREDATATYPE 'TCP.CONTROL.BLOCK
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER POINTER WORD WORD FIXP POINTER POINTER FIXP FIXP FIXP FIXP FIXP FIXP WORD WORD
               FIXP FIXP FIXP POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
               POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG (BITS 5)
               WORD WORD)
       '((TCP.CONTROL.BLOCK 0 POINTER)
         (TCP.CONTROL.BLOCK 2 POINTER)
         (TCP.CONTROL.BLOCK 4 POINTER)
         (TCP.CONTROL.BLOCK 6 POINTER)
         (TCP.CONTROL.BLOCK 8 POINTER)
         (TCP.CONTROL.BLOCK 10 POINTER)
         (TCP.CONTROL.BLOCK 12 POINTER)
         (TCP.CONTROL.BLOCK 14 POINTER)
         (TCP.CONTROL.BLOCK 16 POINTER)
         (TCP.CONTROL.BLOCK 18 POINTER)
         (TCP.CONTROL.BLOCK 20 POINTER)
         (TCP.CONTROL.BLOCK 22 POINTER)
         (TCP.CONTROL.BLOCK 24 POINTER)
         (TCP.CONTROL.BLOCK 26 (BITS . 15))
         (TCP.CONTROL.BLOCK 27 (BITS . 15))
         (TCP.CONTROL.BLOCK 28 FIXP)
         (TCP.CONTROL.BLOCK 30 POINTER)
         (TCP.CONTROL.BLOCK 32 POINTER)
         (TCP.CONTROL.BLOCK 34 FIXP)
         (TCP.CONTROL.BLOCK 36 FIXP)
         (TCP.CONTROL.BLOCK 38 FIXP)
         (TCP.CONTROL.BLOCK 40 FIXP)
         (TCP.CONTROL.BLOCK 42 FIXP)
         (TCP.CONTROL.BLOCK 44 FIXP)
         (TCP.CONTROL.BLOCK 46 (BITS . 15))
         (TCP.CONTROL.BLOCK 47 (BITS . 15))
         (TCP.CONTROL.BLOCK 48 FIXP)
         (TCP.CONTROL.BLOCK 50 FIXP)
         (TCP.CONTROL.BLOCK 52 FIXP)
         (TCP.CONTROL.BLOCK 54 POINTER)
         (TCP.CONTROL.BLOCK 56 POINTER)
         (TCP.CONTROL.BLOCK 58 POINTER)
         (TCP.CONTROL.BLOCK 60 POINTER)
         (TCP.CONTROL.BLOCK 62 POINTER)
         (TCP.CONTROL.BLOCK 64 POINTER)
         (TCP.CONTROL.BLOCK 66 POINTER)
         (TCP.CONTROL.BLOCK 68 POINTER)
         (TCP.CONTROL.BLOCK 70 POINTER)
         (TCP.CONTROL.BLOCK 72 POINTER)
         (TCP.CONTROL.BLOCK 74 POINTER)
         (TCP.CONTROL.BLOCK 76 POINTER)
         (TCP.CONTROL.BLOCK 78 POINTER)
         (TCP.CONTROL.BLOCK 80 POINTER)
         (TCP.CONTROL.BLOCK 82 POINTER)
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 0))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 16))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 32))
         (TCP.CONTROL.BLOCK 82 (BITS . 52))
         (TCP.CONTROL.BLOCK 84 (BITS . 15))
         (TCP.CONTROL.BLOCK 85 (BITS . 15)))
       '86)

(* "END EXPORTED DEFINITIONS")

)

(/DECLAREDATATYPE 'TCP.CONTROL.BLOCK
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER POINTER WORD WORD FIXP POINTER POINTER FIXP FIXP FIXP FIXP FIXP FIXP WORD WORD
               FIXP FIXP FIXP POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
               POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG (BITS 5)
               WORD WORD)
       '((TCP.CONTROL.BLOCK 0 POINTER)
         (TCP.CONTROL.BLOCK 2 POINTER)
         (TCP.CONTROL.BLOCK 4 POINTER)
         (TCP.CONTROL.BLOCK 6 POINTER)
         (TCP.CONTROL.BLOCK 8 POINTER)
         (TCP.CONTROL.BLOCK 10 POINTER)
         (TCP.CONTROL.BLOCK 12 POINTER)
         (TCP.CONTROL.BLOCK 14 POINTER)
         (TCP.CONTROL.BLOCK 16 POINTER)
         (TCP.CONTROL.BLOCK 18 POINTER)
         (TCP.CONTROL.BLOCK 20 POINTER)
         (TCP.CONTROL.BLOCK 22 POINTER)
         (TCP.CONTROL.BLOCK 24 POINTER)
         (TCP.CONTROL.BLOCK 26 (BITS . 15))
         (TCP.CONTROL.BLOCK 27 (BITS . 15))
         (TCP.CONTROL.BLOCK 28 FIXP)
         (TCP.CONTROL.BLOCK 30 POINTER)
         (TCP.CONTROL.BLOCK 32 POINTER)
         (TCP.CONTROL.BLOCK 34 FIXP)
         (TCP.CONTROL.BLOCK 36 FIXP)
         (TCP.CONTROL.BLOCK 38 FIXP)
         (TCP.CONTROL.BLOCK 40 FIXP)
         (TCP.CONTROL.BLOCK 42 FIXP)
         (TCP.CONTROL.BLOCK 44 FIXP)
         (TCP.CONTROL.BLOCK 46 (BITS . 15))
         (TCP.CONTROL.BLOCK 47 (BITS . 15))
         (TCP.CONTROL.BLOCK 48 FIXP)
         (TCP.CONTROL.BLOCK 50 FIXP)
         (TCP.CONTROL.BLOCK 52 FIXP)
         (TCP.CONTROL.BLOCK 54 POINTER)
         (TCP.CONTROL.BLOCK 56 POINTER)
         (TCP.CONTROL.BLOCK 58 POINTER)
         (TCP.CONTROL.BLOCK 60 POINTER)
         (TCP.CONTROL.BLOCK 62 POINTER)
         (TCP.CONTROL.BLOCK 64 POINTER)
         (TCP.CONTROL.BLOCK 66 POINTER)
         (TCP.CONTROL.BLOCK 68 POINTER)
         (TCP.CONTROL.BLOCK 70 POINTER)
         (TCP.CONTROL.BLOCK 72 POINTER)
         (TCP.CONTROL.BLOCK 74 POINTER)
         (TCP.CONTROL.BLOCK 76 POINTER)
         (TCP.CONTROL.BLOCK 78 POINTER)
         (TCP.CONTROL.BLOCK 80 POINTER)
         (TCP.CONTROL.BLOCK 82 POINTER)
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 0))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 16))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 32))
         (TCP.CONTROL.BLOCK 82 (BITS . 52))
         (TCP.CONTROL.BLOCK 84 (BITS . 15))
         (TCP.CONTROL.BLOCK 85 (BITS . 15)))
       '86)



(* ;; "global lock for TCP-related mutual exclusion")


(RPAQ? \TCP.LOCK (CREATE.MONITORLOCK))



(* ;; "list of TCP control blocks for connection lookup")


(RPAQ? \TCP.CONTROL.BLOCKS NIL)
(DEFINEQ

(\TCP.CREATE.TCB
(LAMBDA (DST.HOST DST.PORT SRC.PORT MODE OUR.MAXSEG) (* ejs%: "27-May-86 14:39") (* create a new TCB and the input and output streams that go with it) (WITH.FAST.MONITOR \TCP.LOCK (PROG ((TCB (create TCP.CONTROL.BLOCK TCB.DST.HOST _ DST.HOST TCB.DST.PORT _ DST.PORT TCB.SRC.PORT _ (if (ZEROP SRC.PORT) then (\TCP.SELECT.PORT) else SRC.PORT) TCB.INPUT.QUEUE _ (create SYSQUEUE) TCB.REXMT.QUEUE _ (create SYSQUEUE) TCB.MODE _ MODE TCB.OUR.MAXSEG _ (OR OUR.MAXSEG \TCP.DEFAULT.MAXSEG)))) (replace (STREAM STRMBOUTFN) of (replace TCB.RCV.STREAM of TCB with (create TCPSTREAM ACCESS _ (QUOTE INPUT) TCB _ TCB BYTECOUNT _ 0)) with (FUNCTION \TCP.OTHER.BOUT)) (replace (STREAM STRMBINFN) of (replace TCB.SND.STREAM of TCB with (create TCPSTREAM ACCESS _ (QUOTE APPEND) TCB _ TCB BYTECOUNT _ 0)) with (FUNCTION \TCP.OTHER.BIN)) (\TCP.START.PROBE.TIMER TCB) (push \TCP.CONTROL.BLOCKS TCB) (* put it on the global list of TCBs so it can be found by \TCP.LOOKUP.TCB) (replace TCB.IPSOCKET of TCB with (\IP.OPEN.SOCKET \TCP.PROTOCOL TCB)) (* Tell IP about it) (RETURN TCB))))
)

(\TCP.SELECT.PORT
(LAMBDA NIL (* ecc " 7-May-84 17:23") (* find a port unique among all TCP connections on this host) (PROG ((PORT (LOGAND (DAYTIME) 65535))) (until (for TCB in \TCP.CONTROL.BLOCKS always (NEQ PORT (fetch TCB.SRC.PORT of TCB))) do (add PORT 1)) (RETURN PORT)))
)

(\TCP.LOOKUP.TCB
(LAMBDA (DST.HOST DST.PORT SRC.PORT NOWILDCARDFLG) (* ejs%: "21-Mar-86 18:40") (* Find a TCB that matches the specified addresses. If NOWILDCARDFLG is non-NIL we match against a partially specified TCB if no fully specified one was found.) (WITH.FAST.MONITOR \TCP.LOCK (bind WILDCARD for TCB in \TCP.CONTROL.BLOCKS do (if (EQ SRC.PORT (fetch TCB.SRC.PORT of TCB)) then (* only check further if the local ports match) (if (AND (IEQP DST.HOST (fetch TCB.DST.HOST of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB))) then (* a full match) (RETURN TCB) elseif (AND (NOT NOWILDCARDFLG) (NULL WILDCARD) (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (IEQP DST.HOST (fetch TCB.DST.HOST of TCB))) (OR (ZEROP (fetch TCB.DST.PORT of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB)))) then (* a wildcard match) (SETQ WILDCARD TCB))) finally (RETURN (if NOWILDCARDFLG then NIL else WILDCARD)))))
)

(\TCP.DELETE.TCB
  [LAMBDA (TCB)                                          (* ; "Edited 25-Aug-88 18:39 by bvm")
    (WITH.FAST.MONITOR \TCP.LOCK (\TCP.TRACE.TRANSITION TCB 'CLOSED)
           (replace TCB.STATE of TCB with 'CLOSED)
           (\FLUSH.PACKET.QUEUE (fetch TCB.INPUT.QUEUE of TCB))
           (\FLUSH.PACKET.QUEUE (fetch TCB.REXMT.QUEUE of TCB))
           (SETQ \TCP.CONTROL.BLOCKS (DREMOVE TCB \TCP.CONTROL.BLOCKS))
           (\IP.CLOSE.SOCKET (fetch TCB.IPSOCKET of TCB)
                  \TCP.PROTOCOL T)
           (replace TCB.IPSOCKET of TCB with NIL)
           [LET [(WHENCLOSEDFN (PROCESSPROP (THIS.PROCESS)
                                      'WHENCLOSEDFN]
                (COND
                   (WHENCLOSEDFN (CL:FUNCALL WHENCLOSEDFN (fetch TCB.RCV.STREAM of TCB)
                                        (fetch TCB.SND.STREAM of TCB]
                                                             (* ; "break circular links")
           (replace TCB.SND.STREAM of TCB with NIL)
           (replace TCB.RCV.STREAM of TCB with NIL)
                                                             (* ; 
                                                       "wake up anyone waiting for events to occur")
           (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB))
           (NOTIFY.EVENT (fetch TCB.SND.EVENT of TCB))
           (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB))
           (NOTIFY.EVENT (fetch TCB.URGENT.EVENT of TCB))
           (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB])

(\TCP.NOSOCKETFN
(LAMBDA (IP) (* ejs%: " 1-Feb-86 18:12") (* * Called when no TCP port corresponding to IP packet is found. We try again, allowing for wildcards) (LET* ((PROTOCOLCHAIN (\IP.FIND.PROTOCOL \TCP.PROTOCOL \IP.PROTOCOLS)) (IPSOCKET (fetch (IPSOCKET IPSLINK) of PROTOCOLCHAIN))) (while IPSOCKET do (COND ((\TCP.PORTCOMPARE IP IPSOCKET T) (APPLY* (ffetch (IPSOCKET IPSINPUTFN) of IPSOCKET) IP IPSOCKET) (RETURN)) (T (SETQ IPSOCKET (fetch (IPSOCKET IPSLINK) of IPSOCKET)))) finally (COND ((NOT (BITTEST (fetch TCP.CTRL of IP) \TCP.CTRL.RST)) (COND ((BITTEST (fetch TCP.CTRL of IP) \TCP.CTRL.ACK) (\TCP.SEND.RESET IP (fetch TCP.ACK of IP) 0 \TCP.CTRL.RST)) (T (\TCP.SEND.RESET IP 0 (IPLUS (fetch TCP.SEQ of IP) (fetch TCP.DATA.LENGTH of IP)) (LOGOR \TCP.CTRL.ACK \TCP.CTRL.RST))))) (T (\RELEASE.ETHERPACKET IP))))))
)

(\TCP.PORTCOMPARE
(LAMBDA (SEGMENT IPSOCKET WILDCARDFLG) (* ejs%: "13-Apr-85 17:44") (* Find a TCB that matches the specified addresses. If NOWILDCARDFLG is non-NIL we match against a partially specified TCB if no fully specified one was found.) (WITH.FAST.MONITOR \TCP.LOCK (PROG ((DST.HOST (fetch (TCPSEGMENT TCP.SRC.ADDR) of SEGMENT)) (DST.PORT (fetch (TCPSEGMENT TCP.SRC.PORT) of SEGMENT)) (SRC.PORT (fetch (TCPSEGMENT TCP.DST.PORT) of SEGMENT)) (TCB (fetch (IPSOCKET IPSOCKET) of IPSOCKET))) (COND ((AND TCB (EQ SRC.PORT (fetch TCB.SRC.PORT of TCB))) (* only check further if the local ports match) (COND ((AND (IEQP DST.HOST (fetch TCB.DST.HOST of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB))) (* a full match) (RETURN IPSOCKET)) ((AND WILDCARDFLG (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (IEQP DST.HOST (fetch TCB.DST.HOST of TCB))) (OR (ZEROP (fetch TCB.DST.PORT of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB)))) (* a wildcard match) (RETURN IPSOCKET))))))))
)
)



(* ;; "TCP checksums")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(DATATYPE TCP.PSEUDOHEADER ((PH.SRC.ADDR FIXP)
                                (PH.DST.ADDR FIXP)
                                (NIL BYTE)
                                (PH.PROTOCOL BYTE)
                                (PH.LENGTH WORD))
                               PH.PROTOCOL _ \TCP.PROTOCOL)
)

(/DECLAREDATATYPE 'TCP.PSEUDOHEADER '(FIXP FIXP BYTE BYTE WORD)
       '((TCP.PSEUDOHEADER 0 FIXP)
         (TCP.PSEUDOHEADER 2 FIXP)
         (TCP.PSEUDOHEADER 4 (BITS . 7))
         (TCP.PSEUDOHEADER 4 (BITS . 135))
         (TCP.PSEUDOHEADER 5 (BITS . 15)))
       '6)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.PSEUDOHEADER.LENGTH 12)


(CONSTANTS \TCP.PSEUDOHEADER.LENGTH)
)

(DECLARE%: EVAL@COMPILE 

[PUTPROPS \16BIT.COMPLEMENT MACRO ((X)
                                   (LOGXOR X (MASK.1'S 0 16]

[PUTPROPS \16BIT.1C.PLUS MACRO ((X Y)

         (* compute the one's complement sum of X and Y without creating FIXP boxes --
       the sum modulo |2^16| plus an end-around carry)

                                (PROG ((DELTA (IDIFFERENCE MAX.SMALLP Y)))
                                      (RETURN (if (ILEQ X DELTA)
                                                  then (IPLUS X Y)
                                                else (IDIFFERENCE X DELTA]
)
)

(/DECLAREDATATYPE 'TCP.PSEUDOHEADER '(FIXP FIXP BYTE BYTE WORD)
       '((TCP.PSEUDOHEADER 0 FIXP)
         (TCP.PSEUDOHEADER 2 FIXP)
         (TCP.PSEUDOHEADER 4 (BITS . 7))
         (TCP.PSEUDOHEADER 4 (BITS . 135))
         (TCP.PSEUDOHEADER 5 (BITS . 15)))
       '6)

(RPAQ? \TCP.PSEUDOHEADER NIL)



(* ;; "this variable controls whether checksums are performed on incoming segments")


(RPAQ? \TCP.CHECKSUMS.ON NIL)



(* ;; "checksum routines")

(DEFINEQ

(\COMPUTE.CHECKSUM
(LAMBDA (BASE LENGTH DONTCOMPLEMENTFLG) (* ecc "25-May-84 18:47") (* TCP/IP protocol checksum is the 16-bit 1's complement of the 1's complement sum of the 16-bit words) (PROG ((CHECKSUM 0) (N (SUB1 (LRSH LENGTH 1)))) (for I from 0 to N do (SETQ CHECKSUM (\16BIT.1C.PLUS CHECKSUM (\GETBASE BASE I)))) (if (ODDP LENGTH) then (* if LENGTH is odd, the last byte must be padded on the right by a zero byte) (SETQ CHECKSUM (\16BIT.1C.PLUS CHECKSUM (LLSH (\GETBASEBYTE BASE (SUB1 LENGTH)) 8)))) (RETURN (if DONTCOMPLEMENTFLG then (* if DONTCOMPLEMENTFLG is non-NIL just return the 1's complement sum) CHECKSUM else (\16BIT.COMPLEMENT CHECKSUM)))))
)

(\TCP.CHECKSUM.INCOMING
(LAMBDA (SEGMENT) (* ecc "16-May-84 11:53") (* computes the TCP checksum and returns T or NIL depending on whether it matches the checksum in the header) (PROG ((LENGTH (IPLUS (fetch TCP.HEADER.LENGTH of SEGMENT) (\TCP.DATA.LENGTH SEGMENT))) (SEGMENT.CHECKSUM (fetch TCP.CHECKSUM of SEGMENT)) CHECKSUM OK) (WITH.FAST.MONITOR \TCP.LOCK (* need to lock this because we're using \TCP.PSEUDOHEADER) (replace PH.SRC.ADDR of \TCP.PSEUDOHEADER with (fetch TCP.SRC.ADDR of SEGMENT)) (replace PH.DST.ADDR of \TCP.PSEUDOHEADER with (fetch TCP.DST.ADDR of SEGMENT)) (replace PH.LENGTH of \TCP.PSEUDOHEADER with LENGTH) (replace TCP.CHECKSUM of SEGMENT with 0) (* checksum field must be 0 while we are computing checksum) (SETQ CHECKSUM (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM \TCP.PSEUDOHEADER \TCP.PSEUDOHEADER.LENGTH T) (\COMPUTE.CHECKSUM (fetch TCPHEADER of SEGMENT) LENGTH T))))) (SETQ OK (EQ CHECKSUM SEGMENT.CHECKSUM)) (if (AND (NOT OK) (MEMB (QUOTE CHECKSUM) TCPTRACEFLG)) then (printout TCPTRACEFILE .TAB0 0 "[bad checksum " CHECKSUM "]" T)) (RETURN OK)))
)

(\TCP.CHECKSUM.OUTGOING
(LAMBDA (TCB SEGMENT) (* ecc "16-May-84 11:53") (* compute checksum and place in header) (PROG ((LENGTH (IPLUS (fetch TCP.HEADER.LENGTH of SEGMENT) (\TCP.DATA.LENGTH SEGMENT))) (PH (if TCB then (fetch TCB.PH of TCB) else \TCP.PSEUDOHEADER))) (WITH.FAST.MONITOR \TCP.LOCK (* need to lock this in case we're using \TCP.PSEUDOHEADER) (replace PH.SRC.ADDR of PH with (fetch TCP.SRC.ADDR of SEGMENT)) (replace PH.DST.ADDR of PH with (fetch TCP.DST.ADDR of SEGMENT)) (replace PH.LENGTH of PH with LENGTH) (replace TCP.CHECKSUM of SEGMENT with 0) (* checksum field must be 0 while we are computing checksum) (replace TCP.CHECKSUM of SEGMENT with (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM PH \TCP.PSEUDOHEADER.LENGTH T) (\COMPUTE.CHECKSUM (fetch TCPHEADER of SEGMENT) LENGTH T)))))))
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.INITIAL.RTO 1000)


(CONSTANTS \TCP.INITIAL.RTO)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.UBOUND 5000)

(RPAQQ \TCP.LBOUND 1000)


(CONSTANTS (\TCP.UBOUND 5000)
       (\TCP.LBOUND 1000))
)
)



(* ;; "maximum segment lifetime")


(RPAQ? \TCP.MSL 5000)

(RPAQ? \TCP.DEFAULT.USER.TIMEOUT 60000)

(RPAQ? \TCP.DEFAULT.RECEIVE.WINDOW 4096)

(RPAQ? \TCP.DEVICE NIL)



(* ;; "TCP protocol routines")

(DEFINEQ

(\TCP.ACK#
(LAMBDA (TCB) (* ejs%: " 7-Jun-85 13:18") (* * Returns the byte id for the next ACK) (* (LET* ((STREAM (fetch TCB.RCV.STREAM of TCB)) (BUFFER (fetch TCB.RCV.SEGMENT of TCB))) (COND (BUFFER (IPLUS (fetch TCP.SEQ of BUFFER) (fetch (STREAM COFFSET) of STREAM))) ((SETQ BUFFER (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (IMIN (fetch TCB.RCV.NXT of TCB) (fetch TCP.SEQ of BUFFER))) (T (fetch TCB.RCV.NXT of TCB))))) (fetch TCB.RCV.NXT of TCB))
)

(\TCP.PACKET.FILTER
(LAMBDA (SEGMENT PROTOCOL) (* ecc " 7-May-84 17:27") (* packet filter used by IP code to dispatch packets by protocol) (SELECTC PROTOCOL (\TCP.PROTOCOL (ERSETQ (\TCP.INPUT SEGMENT)) T) (\ICMP.PROTOCOL (ERSETQ (\TCP.HANDLE.ICMP SEGMENT)) T) NIL))
)

(\TCP.SETUP.SEGMENT
(LAMBDA (SRC.HOST SRC.PORT DST.HOST DST.PORT) (* ejs%: " 1-Jan-01 10:28") (* allocate a new TCP segment and set up its header) (PROG ((SEGMENT (\IP.SETUPIP (\ALLOCATE.ETHERPACKET) DST.HOST NIL \TCP.MASTER.SOCKET (QUOTE FREE)))) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) \TCP.HEADER.LENGTH) (replace TCP.SRC.PORT of SEGMENT with SRC.PORT) (replace TCP.DST.PORT of SEGMENT with DST.PORT) (replace TCP.DATA.OFFSET of SEGMENT with \TCP.MIN.DATA.OFFSET) (replace TCP.MBZ of SEGMENT with 0) (RETURN SEGMENT)))
)

(\TCP.RELEASE.SEGMENT
(LAMBDA (SEGMENT) (* ecc " 7-May-84 17:28") (* release a TCP segment -- it had better not be on anyone's queue) (CHECK (OR (NULL (fetch QLINK of SEGMENT)) (SHOULDNT "releasing queued segment"))) (\RELEASE.ETHERPACKET SEGMENT))
)

(\TCP.CONNECTION
(LAMBDA (DST.HOST DST.PORT SRC.PORT MODE OPTIONS) (* ; "Edited 23-May-88 19:14 by Snow") (* ;; "open a TCP connection and return the TCB or NIL if the connection fails") (PROG (SPECIFIED TCB ISS TCP.PROCESS) (SELECTQ MODE (ACTIVE) (PASSIVE) (ERROR "TCP open mode must be ACTIVE or PASSIVE")) (if (NULL DST.HOST) then (SETQ DST.HOST 0)) (if (NULL DST.PORT) then (SETQ DST.PORT 0)) (if (NULL SRC.PORT) then (SETQ SRC.PORT 0)) (SETQ SPECIFIED (NOT (OR (ZEROP DST.HOST) (ZEROP DST.PORT)))) (if (AND (EQ MODE (QUOTE ACTIVE)) (NOT SPECIFIED)) then (ERROR "foreign socket unspecified")) (* ;; "Check for conflict with existing connections.  ACTIVE open only conflicts with other fully specified connections.  PASSIVE open conflicts with fully specified connections if the open is fully specifed, and with partially specified connections if the open is partially specified") (if (SETQ TCB (OR (AND (OR (EQ MODE (QUOTE ACTIVE)) SPECIFIED) (\TCP.LOOKUP.TCB DST.HOST DST.PORT SRC.PORT T)) (AND (EQ MODE (QUOTE PASSIVE)) (NOT SPECIFIED) (SETQ TCB (\TCP.LOOKUP.TCB DST.HOST DST.PORT SRC.PORT NIL)) (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (ZEROP (fetch TCB.DST.PORT of TCB))) TCB))) then (COND ((type? TCP.CONTROL.BLOCK TCB) (COND ((FMEMB (fetch TCB.STATE of TCB) (QUOTE (CLOSED CLOSE.WAIT TIME.WAIT FIN.WAIT.1 FIN.WAIT.2))) (\TCP.DELETE.TCB TCB)) (T (ERROR "TCP connection already exists")))) (T (ERROR "TCP connection already exists")))) (SETQ TCB (\TCP.CREATE.TCB DST.HOST DST.PORT SRC.PORT MODE (OR (LISTGET OPTIONS (QUOTE MAXSEG)) \TCP.DEFAULT.MAXSEG))) (replace TCB.NO.IDLE.PROBING of TCB with (LISTGET OPTIONS (QUOTE NO.IDLE.PROBING))) (SELECTQ MODE (ACTIVE (WITH.MONITOR \TCP.LOCK (SETQ ISS (\TCP.SELECT.ISS)) (replace TCB.ISS of TCB with ISS)) (\TCP.TEMPLATE TCB (COND ((LISTGET OPTIONS (QUOTE MAXSEG)) OPTIONS) (T (APPEND OPTIONS (BQUOTE (MAXSEG %, \TCP.DEFAULT.MAXSEG)))))) (replace TCB.SND.UNA of TCB with ISS) (replace TCB.SND.NXT of TCB with ISS) (replace TCB.SND.UP of TCB with ISS) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.SENT)) (replace TCB.STATE of TCB with (QUOTE SYN.SENT)) (SETQ TCP.PROCESS (ADD.PROCESS (BQUOTE (\TCP.PROCESS %, TCB)) (QUOTE NAME) (QUOTE TCP) (QUOTE WHENCLOSEDFN) (LISTGET OPTIONS (QUOTE WHENCLOSEDFN)))) (* ; "initiate the three-way handshake to establish the connection") (\TCP.FLUSH (fetch TCB.SND.STREAM of TCB) \TCP.CTRL.SYN) (* ; "wait until established") (WITH.MONITOR (fetch TCB.LOCK of TCB) (RESETLST (RESETSAVE NIL (BQUOTE (AND RESETSTATE (DEL.PROCESS %, TCP.PROCESS)))) (until (NEQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB)))))) (PASSIVE (\TCP.TRACE.TRANSITION TCB (QUOTE LISTEN)) (replace TCB.STATE of TCB with (QUOTE LISTEN)) (SETQ TCP.PROCESS (ADD.PROCESS (BQUOTE (\TCP.PROCESS %, TCB)) (QUOTE NAME) (QUOTE TCP) (QUOTE WHENCLOSEDFN) (LISTGET OPTIONS (QUOTE WHENCLOSEDFN)))) (* ; "wait until established") (WITH.MONITOR (fetch TCB.LOCK of TCB) (RESETLST (RESETSAVE NIL (BQUOTE (AND RESETSTATE (DEL.PROCESS %, TCP.PROCESS)))) (until (NEQ (fetch TCB.STATE of TCB) (QUOTE LISTEN)) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB)))))) (SHOULDNT)) (RETURN (if (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) then TCB else NIL))))
)

(\TCP.FIX.INCOMING.SEGMENT
(LAMBDA (SEGMENT FLAGS) (* ecc "16-May-84 11:56") (PROG NIL (if (AND (BITTEST FLAGS \TCP.CTRL.SYN) (BITTEST FLAGS \TCP.CTRL.FIN)) then (RETURN NIL)) (* calculate the length of the segment data and place it in a fixed position in the header for fast access -- note that the TCP.DATA.LENGTH field isn't a true part of the TCP header; it overlays the IP level checksum which is no longer needed) (replace TCP.DATA.LENGTH of SEGMENT with (\TCP.DATA.LENGTH SEGMENT)) (* return T or NIL depending on whether checksum is correct) (RETURN (OR (NOT \TCP.CHECKSUMS.ON) (\TCP.CHECKSUM.INCOMING SEGMENT)))))
)

(\TCP.DATA.LENGTH
(LAMBDA (SEGMENT) (* ejs%: "21-Jun-85 17:04") (* data length = total segment length - (IP header length + TCP header length)) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of SEGMENT) (IPLUS (UNFOLD (fetch (IP IPHEADERLENGTH) of SEGMENT) BYTESPERCELL) (UNFOLD (fetch TCP.DATA.OFFSET of SEGMENT) BYTESPERCELL))))
)

(\TCP.SYN.OR.FIN
(LAMBDA (FLAGS NOERRORFLG) (* ecc " 1-May-84 17:10") (* SYN and FIN occupy sequence number space so we have to include them in the "length" of the segment) (SELECTC (LOGAND FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.FIN)) (0 0) (\TCP.CTRL.SYN 1) (\TCP.CTRL.FIN 1) (if NOERRORFLG then 0 else (SHOULDNT "both SYN and FIN"))))
)

(\TCP.INPUT
(LAMBDA (SEGMENT TCB) (* ejs%: "20-Jun-85 13:06") (* handle an incoming TCP segment -- pages |65-76| of RFC 793) (PROG ((SEQ (fetch TCP.SEQ of SEGMENT)) (ACK (fetch TCP.ACK of SEGMENT)) (FLAGS (fetch TCP.CTRL of SEGMENT)) UNA QUEUEDFLG) (if (NOT (\TCP.INPUT.INITIAL TCB SEGMENT SEQ ACK FLAGS)) then (\TCP.RELEASE.SEGMENT SEGMENT) (RETURN)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (PROG NIL (* handle unsynchronized states) (if (NOT (\TCP.INPUT.UNSYNC TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (* first check sequence number) (if (NOT (\TCP.CHECK.WINDOW TCB SEGMENT FLAGS)) then (GO DROPIT)) (* second check the RST bit) (if (NOT (\TCP.CHECK.RESET TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (* third check security and precedence) (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (GO DROPIT)) (* fourth check the SYN bit) (if (NOT (\TCP.CHECK.NO.SYN TCB SEGMENT FLAGS)) then (GO DROPIT)) (if (NOT (\TCP.CHECK.OPTIONS TCB SEGMENT FLAGS)) then (GO DROPIT)) (* fifth check the ACK field) (if (NOT (\TCP.CHECK.ACK TCB SEGMENT FLAGS)) then (GO DROPIT)) (if (EQ (fetch TCB.STATE of TCB) (QUOTE SYN.RECEIVED)) then (if (AND (\32BIT.LEQ (fetch TCB.SND.UNA of TCB) ACK) (\32BIT.LEQ ACK (fetch TCB.SND.NXT of TCB))) then (* our SYN has been acked) (\TCP.TRACE.TRANSITION TCB (QUOTE ESTABLISHED)) (replace TCB.STATE of TCB with (QUOTE ESTABLISHED)) (replace TCB.DST.HOST of TCB with (fetch (TCPSEGMENT TCP.SRC.ADDR) of SEGMENT)) (replace TCB.DST.PORT of TCB with (fetch (TCPSEGMENT TCP.SRC.PORT) of SEGMENT)) (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB)) (* continue processing in ESTABLISHED state) else (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST) (GO DROPIT))) (if (NOT (\TCP.HANDLE.ACK TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (SELECTQ (fetch TCB.STATE of TCB) (FIN.WAIT.1 (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.TRACE.TRANSITION TCB (QUOTE FIN.WAIT.2)) (replace TCB.STATE of TCB with (QUOTE FIN.WAIT.2)) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)))) ((ESTABLISHED FIN.WAIT.2 CLOSE.WAIT) NIL) (CLOSING (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.START.TIME.WAIT TCB) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) else (GO DROPIT))) (LAST.ACK (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED)) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) (RETURN) else (GO DROPIT))) (TIME.WAIT (\TCP.SEND.ACK TCB) (GO DROPIT)) (SHOULDNT)) (* sixth check the URG bit) (\TCP.HANDLE.URG TCB SEGMENT SEQ ACK FLAGS) (* seventh process the segment text) (SELECTQ (fetch TCB.STATE of TCB) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (SETQ QUEUEDFLG (\TCP.QUEUE.INPUT TCB SEGMENT SEQ))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT)) (SHOULDNT)) (* eighth check the FIN bit) (\TCP.HANDLE.FIN TCB SEGMENT SEQ ACK FLAGS) (if QUEUEDFLG then (RETURN)) DROPIT (\TCP.RELEASE.SEGMENT SEGMENT)))))
)

(\TCP.INPUT.INITIAL
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 17:27") (* handle segment for non-existent TCB -- page 65 of RFC 793) (PROG NIL (\TCP.TRACE.SEGMENT (QUOTE RECV) SEGMENT) (if (NOT (\TCP.FIX.INCOMING.SEGMENT SEGMENT FLAGS)) then (* bad checksum) (RETURN NIL)) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED))) then (* an incoming segment not containing a RST causes a RST to be sent in response) (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[no such TCP connection]")) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (* send a RST) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (\TCP.SEND.RESET SEGMENT ACK) else (\TCP.SEND.RESET SEGMENT 0 (IPLUS SEQ (fetch TCP.DATA.LENGTH of SEGMENT) (\TCP.SYN.OR.FIN FLAGS))))) (RETURN NIL)) (RETURN T)))
)

(\TCP.INPUT.UNSYNC
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "21-Mar-86 20:03") (* handle segment for TCB in LISTEN or SYN.SENT state -- pages |65-68| of RFC 793) (SELECTQ (fetch TCB.STATE of TCB) (LISTEN (\TCP.INPUT.LISTEN TCB SEGMENT SEQ ACK FLAGS) NIL) (SYN.SENT (\TCP.INPUT.SYN.SENT TCB SEGMENT SEQ ACK FLAGS) (\TCP.CHECK.OPTIONS TCB SEGMENT FLAGS) NIL) T))
)

(\TCP.INPUT.LISTEN
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "22-Jun-85 03:14") (* handle segment for TCB in LISTEN state -- pages |65-66| of RFC 793) (PROG (ISS) (* first check for a RST) (if (BITTEST FLAGS \TCP.CTRL.RST) then (RETURN NIL)) (* second check for an ACK) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (* any acknowledgment is bad if it arrives on a connection still in the LISTEN state) (\TCP.SEND.RESET SEGMENT ACK) (RETURN NIL)) (* third check for a SYN) (if (BITTEST FLAGS \TCP.CTRL.SYN) then (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (RETURN NIL)) (replace TCB.RCV.NXT of TCB with (ADD1 SEQ)) (replace TCB.IRS of TCB with SEQ) (SETQ ISS (\TCP.SELECT.ISS)) (replace TCB.ISS of TCB with ISS) (replace TCB.SND.NXT of TCB with ISS) (replace TCB.SND.UNA of TCB with ISS) (replace TCB.SND.UP of TCB with ISS) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.RECEIVED)) (replace TCB.STATE of TCB with (QUOTE SYN.RECEIVED)) (* fill in foreign socket in case it was only partially specified) (replace TCB.DST.HOST of TCB with (fetch TCP.SRC.ADDR of SEGMENT)) (replace TCB.DST.PORT of TCB with (fetch TCP.SRC.PORT of SEGMENT)) (\TCP.TEMPLATE TCB) (* send a SYN, ACK segment using \TCP.FLUSH because SYN occupies sequence number space) (\TCP.FLUSH (fetch TCB.SND.STREAM of TCB) \TCP.CTRL.SYN) (* NOTE%: we never queue data that arrives in a SYN segment, we just ACK the SYN and require the data to be retransmitted)) (RETURN NIL)))
)

(\TCP.INPUT.SYN.SENT
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:13") (* handle segment for TCB in SYN.SENT state -- pages |66-68| of RFC 793) (PROG NIL (* first check the ACK bit) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (if (OR (\32BIT.LEQ ACK (fetch TCB.ISS of TCB)) (\32BIT.GT ACK (fetch TCB.SND.NXT of TCB))) then (* ACK is unacceptable) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST)) (RETURN NIL))) (* second check the RST bit) (if (BITTEST FLAGS \TCP.CTRL.RST) then (if (BITTEST FLAGS \TCP.CTRL.ACK) then (* if the ACK was acceptable then signal the user) (\TCP.CONNECTION.DROPPED TCB "reset")) (RETURN NIL)) (* third check the security and precedence) (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (RETURN NIL)) (* fourth check the SYN bit) (if (BITTEST FLAGS \TCP.CTRL.SYN) then (replace TCB.RCV.NXT of TCB with (ADD1 SEQ)) (replace TCB.IRS of TCB with SEQ) (if (AND (BITTEST FLAGS \TCP.CTRL.ACK) (\32BIT.GEQ ACK (fetch TCB.SND.UNA of TCB))) then (* new ACK information) (replace TCB.SND.UNA of TCB with ACK)) (replace TCP.CTRL of SEGMENT with (SETQ FLAGS (BITCLEAR FLAGS \TCP.CTRL.SYN))) (if (\32BIT.GT (fetch TCB.SND.UNA of TCB) (fetch TCB.ISS of TCB)) then (* our SYN has been acked) (\TCP.TRACE.TRANSITION TCB (QUOTE ESTABLISHED)) (replace TCB.STATE of TCB with (QUOTE ESTABLISHED)) (* send an ACK segment) (\TCP.SEND.ACK TCB (QUOTE NOW)) (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB)) else (* we can just let our original SYN segment be retransmitted) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.RECEIVED)) (replace TCB.STATE of TCB with (QUOTE SYN.RECEIVED)) (* send an ACK segment) (\TCP.SEND.ACK TCB (QUOTE NOW))) (* NOTE%: we never queue data that arrives in a SYN segment, we just ACK the SYN and require the data to be retransmitted)) (* drop the segment and return) (RETURN NIL)))
)

(\TCP.CHECK.WINDOW
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 16:29") (* check segment length against receive window -- page 69 of RFC 793) (PROG ((LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (SEQ (fetch TCP.SEQ of SEGMENT)) (RCV.NXT (fetch TCB.RCV.NXT of TCB)) (WND (fetch TCB.RCV.WND of TCB)) TOP) (SETQ TOP (IPLUS SEQ LEN (\TCP.SYN.OR.FIN FLAGS))) (if (ZEROP LEN) then (if (ZEROP WND) then (if (\32BIT.EQ SEQ RCV.NXT) then (RETURN T)) else (if (AND (\32BIT.LEQ RCV.NXT SEQ) (\32BIT.LT SEQ (IPLUS RCV.NXT WND))) then (RETURN T))) else (if (NOT (ZEROP WND)) then (if (OR (AND (\32BIT.LEQ RCV.NXT SEQ) (\32BIT.LT SEQ (IPLUS RCV.NXT WND))) (AND (\32BIT.LT RCV.NXT TOP) (\32BIT.LEQ TOP (IPLUS RCV.NXT WND)))) then (RETURN T)))) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (* send an ACK in reply) (\TCP.SEND.ACK TCB (QUOTE NOW))) (RETURN NIL)))
)

(\TCP.CHECK.RESET
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:07") (* check the RST bit -- page 70 of RFC 793) (PROG NIL (if (BITTEST FLAGS \TCP.CTRL.RST) then (SELECTQ (fetch TCB.STATE of TCB) (SYN.RECEIVED (if (EQ (fetch TCB.MODE of TCB) (QUOTE PASSIVE)) then (\TCP.TRACE.TRANSITION TCB (QUOTE LISTEN)) (replace TCB.STATE of TCB with (QUOTE LISTEN)) else (\TCP.CONNECTION.DROPPED TCB "refused")) (\FLUSH.PACKET.QUEUE (fetch TCB.REXMT.QUEUE of TCB)) (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST)) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2 CLOSE.WAIT) (\TCP.CONNECTION.DROPPED TCB "reset")) ((CLOSING LAST.ACK TIME.WAIT) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED))) (SHOULDNT)) (RETURN NIL) else (RETURN T))))
)

(\TCP.CHECK.SECURITY
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:06") (* returns T or NIL depending on whether security and precedence are OK; sends RST if necessary) (* not implemented) T)
)

(\TCP.CHECK.NO.SYN
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:07") (* check the SYN bit -- page 71 of RFC 793) (PROG NIL (CHECK (OR (NOT (BITTEST FLAGS \TCP.CTRL.RST)) (SHOULDNT "RST bit set"))) (if (NOT (BITTEST FLAGS \TCP.CTRL.SYN)) then (RETURN T)) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (\TCP.SEND.CONTROL TCB (fetch TCP.ACK of SEGMENT) NIL \TCP.CTRL.RST) else (\TCP.SEND.CONTROL TCB 0 (IPLUS (fetch TCP.ACK of SEGMENT) (fetch TCP.DATA.LENGTH of SEGMENT) 1) (LOGOR \TCP.CTRL.ACK \TCP.CTRL.RST))) (\TCP.CONNECTION.DROPPED TCB "reset") (RETURN NIL)))
)

(\TCP.CHECK.ACK
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:08") (* check the ACK field -- page 72 of RFC 793) (PROG NIL (CHECK (OR (NOT (BITTEST FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.RST))) (SHOULDNT "SYN or RST bit set"))) (RETURN (BITTEST FLAGS \TCP.CTRL.ACK))))
)

(\TCP.HANDLE.ACK
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "22-Jun-85 00:35") (* ACK processing -- pages |72-73| of RFC 793) (PROG (EVENT) (if (\32BIT.GT ACK (fetch TCB.SND.NXT of TCB)) then (* this segment acks something we haven't sent yet) (\TCP.SEND.ACK TCB (QUOTE NOW)) (RETURN NIL)) (if (AND (fetch TCB.RTFLG of TCB) (\32BIT.GT ACK (fetch TCB.RTSEQ of TCB))) then (* calculate smoothed round trip time) (replace TCB.RTFLG of TCB with NIL) (replace TCB.SRTT of TCB with (FOLDLO (PLUS (ITIMES 7 (fetch TCB.SRTT of TCB)) (CLOCKDIFFERENCE (fetch TCB.RTTIMER of TCB))) 8)) (replace TCB.RTTIMER of TCB with (SETUPTIMER 0 (fetch TCB.RTTIMER of TCB))) (replace TCB.RTO of TCB with (IMIN \TCP.UBOUND (IMAX \TCP.LBOUND (FOLDLO (ITIMES 3 (fetch TCB.SRTT of TCB)) 2))))) (if (\32BIT.GT ACK (fetch TCB.SND.UNA of TCB)) then (* new ACK information) (replace TCB.SND.UNA of TCB with ACK) (SETQ EVENT T)) (if (OR (\32BIT.GT SEQ (fetch TCB.SND.WL1 of TCB)) (AND (\32BIT.EQ SEQ (fetch TCB.SND.WL1 of TCB)) (\32BIT.GEQ ACK (fetch TCB.SND.WL2 of TCB)))) then (* update send window) (replace TCB.SND.WND of TCB with (fetch TCP.WINDOW of SEGMENT)) (replace TCB.SND.WL1 of TCB with SEQ) (replace TCB.SND.WL2 of TCB with ACK) (SETQ EVENT T)) (if EVENT then (NOTIFY.EVENT (fetch TCB.SND.EVENT of TCB))) (RETURN T)))
)

(\TCP.HANDLE.URG
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:10") (* check the URG bit -- pages |73-74| of RFC 793) (PROG (UP) (if (BITTEST FLAGS \TCP.CTRL.URG) then (SELECTQ (fetch TCB.STATE of TCB) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (SETQ UP (IPLUS SEQ (fetch TCP.URG.PTR of SEGMENT))) (if (\32BIT.GT UP (fetch TCB.RCV.UP of TCB)) then (replace TCB.RCV.UP of TCB with UP) (if (\32BIT.GT UP (fetch TCB.RCV.NXT of TCB)) then (* urgent pointer is in advance of the data consumed) (\TCP.SIGNAL.URGENT.DATA TCB)))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT) NIL) (SHOULDNT)))))
)

(\TCP.QUEUE.INPUT
(LAMBDA (TCB SEGMENT SEQ) (* ejs%: "18-Dec-86 17:39") (* Put the segment in its proper position in the input queue according to its sequence number range. Returns T if the segment was queued, NIL if it was a duplicate. Segments are queued by increasing left endpoint of their sequence number range. If the entire sequence number range has been seen or is covered by segments already in the queue, the segment is a duplicate. Otherwise, it covers some gap in the queue, so it is placed in its proper position. Note that a later segment that covers gaps on both sides will also be queued, resulting in duplicates in the queue. Therefore \TCP.GET.SEGMENT must be prepared to skip over duplicates.) (CHECK (OR (NULL (fetch QLINK of SEGMENT)) (SHOULDNT "input segment already queued"))) (CHECK (\TCP.CHECK.INPUT.QUEUE TCB)) (UNINTERRUPTABLY (PROG ((QUEUE (fetch TCB.INPUT.QUEUE of TCB)) (RCV.NXT (fetch TCB.RCV.NXT of TCB)) (LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (FLAGS (fetch TCP.CTRL of SEGMENT)) TOP CURRENT CURSEQ NEXT) (if (EQ 0 LEN) then (* this segment has no data) (GO DROPITANDPROBE)) (SETQ TOP (IPLUS SEQ LEN)) (if (\32BIT.LEQ TOP RCV.NXT) then (* this segment is a duplicate) (GO DROPITANDPROBE)) (SETQ CURRENT (fetch SYSQUEUEHEAD of QUEUE)) (SETQ NEXT (fetch SYSQUEUETAIL of QUEUE)) (if (OR (NULL CURRENT) (\32BIT.GEQ SEQ (fetch TCP.SEQ of NEXT))) then (* the segment goes at the tail of the queue -- we check this first since this is the expected case) (\ENQUEUE QUEUE SEGMENT) elseif (\32BIT.LT SEQ (SETQ CURSEQ (fetch TCP.SEQ of CURRENT))) then (* the segment goes at the head of the queue) (replace QLINK of SEGMENT with CURRENT) (replace SYSQUEUEHEAD of QUEUE with SEGMENT) else (* * Search for this segment's proper position in the queue. The invariant upon entering this loop is%: segment.seq >= current.seq) (do (if (\32BIT.LEQ TOP (IPLUS CURSEQ (fetch TCP.DATA.LENGTH of CURRENT))) then (* * segment.seq <= current.seq + current.length. The packet is totally subsumed by a previously received packet, and thus, is a duplicate and is dropped) (GO DROPITANDPROBE)) (SETQ NEXT (fetch QLINK of CURRENT)) (SETQ CURSEQ (fetch TCP.SEQ of NEXT)) (if (\32BIT.LT SEQ CURSEQ) then (* * current.seq <= segment.seq < next.seq. Insert the segment between current and next) (replace QLINK of SEGMENT with NEXT) (replace QLINK of CURRENT with SEGMENT) (RETURN)) (SETQ CURRENT NEXT))) (* * Note that we have a zero window allocation at this point. When we free up the window (in \TCP.GET.SEGMENT) %, we'll know to send a gratuitous ACK to our partner to let it know the window's once again open.) (replace TCB.RCV.WND of TCB with (IMAX 0 (IDIFFERENCE (fetch TCB.RCV.WND of TCB) LEN))) (replace TCB.LAST.SENT.RCV.WND of TCB with (IMAX 0 (IDIFFERENCE (fetch TCB.LAST.SENT.RCV.WND of TCB) LEN))) (COND ((OR (EQ 0 (fetch TCB.LAST.SENT.RCV.WND of TCB)) (EQ 0 (fetch TCB.RCV.WND of TCB))) (replace TCB.SENT.ZERO of TCB with T))) (while (AND (\32BIT.LEQ SEQ RCV.NXT) (\32BIT.LT RCV.NXT TOP)) do (* advance RCV.NXT) (replace TCB.RCV.NXT of TCB with (SETQ RCV.NXT TOP)) (if (SETQ SEGMENT (fetch QLINK of SEGMENT)) then (SETQ TOP (IPLUS (SETQ SEQ (fetch TCP.SEQ of SEGMENT)) (fetch TCP.DATA.LENGTH of SEGMENT))))) (if (BITTEST FLAGS \TCP.CTRL.PSH) then (\TCP.SEND.ACK TCB (QUOTE NOW)) else (\TCP.SEND.ACK TCB)) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB)) (RETURN T) DROPITANDPROBE (* * Here when we think we should let the other side know immediately about our condition (e.g. a duplicate packet was received)) (\TCP.SEND.ACK TCB (QUOTE NOW)) DROPIT (* * Here when we have nothing to do, but it's not worth informing our TCP partner) (RETURN NIL))))
)

(\TCP.HANDLE.FIN
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "11-Aug-86 22:29") (* check the FIN bit -- pages |75-76| of RFC 793) (PROG (TOP) (if (BITTEST FLAGS \TCP.CTRL.FIN) then (SETQ TOP (IPLUS SEQ (fetch TCP.DATA.LENGTH of SEGMENT))) (* check whether we've received all the data before the FIN) (if (\32BIT.GEQ (fetch TCB.RCV.NXT of TCB) TOP) then (if (\32BIT.EQ (fetch TCB.RCV.NXT of TCB) TOP) then (* advance RCV.NXT over the FIN) (add (fetch TCB.RCV.NXT of TCB) 1)) (SELECTQ (fetch TCB.STATE of TCB) ((SYN.RECEIVED ESTABLISHED) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSE.WAIT)) (replace TCB.STATE of TCB with (QUOTE CLOSE.WAIT))) (FIN.WAIT.1 (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.START.TIME.WAIT TCB) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) else (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSING)) (replace TCB.STATE of TCB with (QUOTE CLOSING)))) (FIN.WAIT.2 (\TCP.START.TIME.WAIT TCB)) ((CLOSE.WAIT CLOSING LAST.ACK) NIL) (TIME.WAIT (\TCP.START.TIME.WAIT TCB)) (SHOULDNT)) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB))) (* acknowledge the FIN) (\TCP.SEND.ACK TCB (QUOTE NOW)))))
)

(\TCP.OUR.FIN.IS.ACKED
(LAMBDA (TCB) (* ecc "16-May-84 12:15") (* check whether our FIN's sequence number (recorded in the TCB.FINSEQ field) has been acknowledged) (\32BIT.GEQ (fetch TCB.SND.UNA of TCB) (OR (fetch TCB.FINSEQ of TCB) (SHOULDNT "FIN not sent"))))
)

(\TCP.SIGNAL.URGENT.DATA
(LAMBDA (TCB) (* ecc " 7-May-84 12:19") (NOTIFY.EVENT (fetch TCB.URGENT.EVENT of TCB)) (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[Urgent TCP data has arrived]" T)))
)

(\TCP.PROCESS
(LAMBDA (TCB) (* ejs%: "11-Aug-86 21:57") (* process to handle retransmission and timeouts for TCP connection) (RESETSAVE NIL (LIST (FUNCTION \TCP.DELETE.TCB) TCB)) (PROCESSPROP (THIS.PROCESS) (QUOTE INFOHOOK) (FUNCTION (LAMBDA NIL (PPTCB TCB)))) (replace TCB.PROCESS of TCB with (THIS.PROCESS)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (bind SEGMENT PACKETQUEUE REXMTQUEUE EVENT (IPSOCKET _ (fetch TCB.IPSOCKET of TCB)) first (SETQ PACKETQUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) (SETQ REXMTQUEUE (fetch TCB.REXMT.QUEUE of TCB)) (SETQ EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)) while (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) do (COND ((AND (fetch TCB.RTFLG of TCB) (fetch TCB.PROBE.TIMER of TCB) (IGREATERP (CLOCKDIFFERENCE (fetch TCB.RTTIMER of TCB)) (fetch TCB.USER.TIMEOUT of TCB))) (* timeout has expired without other end responding) (\TCP.CONNECTION.DROPPED TCB "not responding")) ((AND (EQ (fetch TCB.STATE of TCB) (QUOTE TIME.WAIT)) (TIMEREXPIRED? (fetch TCB.2MSL.TIMER of TCB))) (* 2MSL has expired) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED))) ((\TCP.RETRANSMIT TCB) NIL) ((OR (EQ (fetch TCB.ACKFLG of TCB) (QUOTE NOW)) (AND (EQ (fetch TCB.STATE of TCB) (QUOTE ESTABLISHED)) (fetch TCB.PROBE.TIMER of TCB) (TIMEREXPIRED? (fetch TCB.PROBE.TIMER of TCB))) (AND (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) (\32BIT.GT (fetch TCP.SEQ of (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (fetch TCB.RCV.NXT of TCB)))) (* an ACK needs to be sent either because the protocol routines requested it or because we need to fill a gap in the input queue) (\TCP.SEND.CONTROL TCB (fetch TCB.SND.NXT of TCB) (\TCP.ACK# TCB) \TCP.CTRL.ACK)) ((AND (\32BIT.GT (fetch TCB.SND.NXT of TCB) (IPLUS (fetch TCB.SND.WL1 of TCB) (fetch TCB.SND.WND of TCB))) (fetch TCB.PROBE.TIMER of TCB) (TIMEREXPIRED? (fetch TCB.PROBE.TIMER of TCB))) (* a probe needs to be sent to open the window) (\TCP.SEND.CONTROL TCB (IPLUS (fetch TCB.SND.NXT of TCB) (fetch TCB.SND.WND of TCB)) (\TCP.ACK# TCB) \TCP.CTRL.ACK))) (COND ((SETQ SEGMENT (\DEQUEUE PACKETQUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1) (\TCP.INPUT SEGMENT TCB)) (T (COND ((EQ (COND ((OR (fetch TCB.OUTPUT.HELD of TCB) (fetch SYSQUEUEHEAD of REXMTQUEUE) (\32BIT.GT (fetch TCB.SND.NXT of TCB) (IPLUS (fetch TCB.SND.WL1 of TCB) (fetch TCB.SND.WND of TCB)))) (* Something on the retransmit queue. Be agressive.) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) EVENT (fetch TCB.RTO of TCB))) (T (* Nothing to do. Be lazy) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) EVENT (fetch TCB.PROBE.TIMER of TCB) (NOT (NULL (fetch TCB.PROBE.TIMER of TCB)))))) EVENT) (COND ((SETQ SEGMENT (\DEQUEUE PACKETQUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1) (\TCP.INPUT SEGMENT TCB))))))))))
)

(\TCP.TEMPLATE
(LAMBDA (TCB OPTIONS) (* ejs%: "21-Jun-85 16:40") (* set up segment for sending control information and pseudo-header for checksumming) (LET ((SEGMENT (fetch TCB.TEMPLATE of TCB))) (if SEGMENT then (replace TCP.DST.ADDR of SEGMENT with (fetch TCB.DST.HOST of TCB)) (replace TCP.DST.PORT of SEGMENT with (fetch TCB.DST.PORT of TCB)) else (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCB.SRC.PORT of TCB) (fetch TCB.DST.HOST of TCB) (fetch TCB.DST.PORT of TCB)))) (if OPTIONS then (\TCP.SETUP.SEGMENT.OPTIONS SEGMENT OPTIONS)) (replace TCB.TEMPLATE of TCB with SEGMENT) (if (NULL (fetch TCB.PH of TCB)) then (replace TCB.PH of TCB with (create TCP.PSEUDOHEADER))) SEGMENT))
)

(\TCP.SETUP.SEGMENT.OPTIONS
(LAMBDA (SEGMENT OPTIONS) (* ejs%: "28-Jul-86 13:31") (* * Add options to a freshly setup segment. OPTIONS is in PLIST format) (LET ((OPTIONSBASE (fetch TCP.OPTIONS of SEGMENT)) (OPTIONSOFFSET 0) DIDPLACEOPTION) (COND ((IGREATERP (fetch (IP IPTOTALLENGTH) of SEGMENT) (CONSTANT (IPLUS \TCP.HEADER.LENGTH \IPOVLEN))) (ERROR "Tried to add options to a segment with TCP data already in place" SEGMENT))) (for OPTIONVALUETAIL on OPTIONS by (CDDR OPTIONVALUETAIL) do (SELECTQ (CAR OPTIONVALUETAIL) (MAXSEG (LET ((VALUE (CADR OPTIONVALUETAIL))) (COND ((SMALLP VALUE) (\PUTBASEBYTE OPTIONSBASE OPTIONSOFFSET \TCPOPT.MAXSEG) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) 4) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) (LOGAND (MASK.1'S 0 BITSPERBYTE) (LRSH VALUE BITSPERBYTE))) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) (LOGAND VALUE (MASK.1'S 0 BITSPERBYTE))) (SETQ DIDPLACEOPTION T))))) NIL)) (COND (DIDPLACEOPTION (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) \TCPOPT.END))) (until (EQ 0 (IMOD OPTIONSOFFSET 4)) do (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) \TCPOPT.END)) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) OPTIONSOFFSET) (add (fetch TCP.DATA.OFFSET of SEGMENT) (FOLDHI OPTIONSOFFSET BYTESPERCELL))))
)

(\TCP.SEND.CONTROL
(LAMBDA (TCB SEQ ACK FLAGS) (* ejs%: "18-Dec-86 17:29") (* send a control segment with the specified sequence number and ACK information) (PROG ((SEGMENT (OR (fetch TCB.TEMPLATE of TCB) (\TCP.NEW.TEMPLATE TCB)))) (if (NULL FLAGS) then (SETQ FLAGS 0)) (CHECK (OR (NOT (BITTEST FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.FIN))) (SHOULDNT "SYN or FIN"))) (while (fetch EPTRANSMITTING of SEGMENT) do (BLOCK)) (replace TCP.SEQ of SEGMENT with SEQ) (if ACK then (replace TCP.ACK of SEGMENT with ACK) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK)) else (replace TCP.ACK of SEGMENT with 0)) (replace TCP.CTRL of SEGMENT with FLAGS) (replace TCB.SENT.ZERO of TCB with (EQ 0 (replace TCP.WINDOW of SEGMENT with (replace TCB.LAST.SENT.RCV.WND of TCB with (fetch TCB.RCV.WND of TCB))))) (\TCP.SEND.SEGMENT TCB SEGMENT FLAGS) (\TCP.NEW.TEMPLATE TCB)))
)

(\TCP.SEND.ACK
(LAMBDA (TCB WHEN) (* ejs%: "17-Dec-86 16:43") (* set TCB.ACKFLG to tell the \TCP.PROCESS that an ACK needs to be sent -- NOW means send the ack immediately, LATER means delay in the hope that it can be piggybacked on an outgoing data segment) (COND ((EQ WHEN (QUOTE NOW)) (\TCP.SEND.CONTROL TCB (fetch TCB.SND.NXT of TCB) (\TCP.ACK# TCB) \TCP.CTRL.ACK)) (T (replace TCB.ACKFLG of TCB with (OR WHEN (QUOTE LATER))))))
)

(\TCP.SEND.RESET
(LAMBDA (ORIG SEQ ACK FLAGS) (* ejs%: " 7-Jun-85 12:58") (* like \TCP.SEND.CONTROL but always sends RST and can be used without a TCB) (PROG (SEGMENT) (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCP.DST.PORT of ORIG) (fetch TCP.SRC.ADDR of ORIG) (fetch TCP.SRC.PORT of ORIG))) (replace TCP.SEQ of SEGMENT with SEQ) (if ACK then (replace TCP.ACK of SEGMENT with ACK) (OR FLAGS (SETQ FLAGS (LOGOR \TCP.CTRL.RST \TCP.CTRL.ACK))) else (replace TCP.ACK of SEGMENT with 0) (OR FLAGS (SETQ FLAGS \TCP.CTRL.RST))) (replace TCP.CTRL of SEGMENT with FLAGS) (replace TCP.WINDOW of SEGMENT with 0) (replace EPREQUEUE of SEGMENT with (QUOTE FREE)) (\TCP.SEND.SEGMENT NIL SEGMENT FLAGS)))
)

(\TCP.FIX.OUTGOING.SEGMENT
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "18-Dec-86 17:29") (* fill in control bits, ACK and window information, and start round trip timer) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (replace TCP.ACK of SEGMENT with (fetch TCB.RCV.NXT of TCB)) else (replace TCP.ACK of SEGMENT with 0)) (replace TCP.CTRL of SEGMENT with FLAGS) (* set control bits) (replace TCP.WINDOW of SEGMENT with (replace TCB.LAST.SENT.RCV.WND of TCB with (fetch TCB.RCV.WND of TCB))) (if (NULL (fetch TCB.RTFLG of TCB)) then (* time round trip response to this segment) (replace TCB.RTFLG of TCB with T) (replace TCB.RTSEQ of TCB with (fetch TCP.SEQ of SEGMENT)) (replace TCB.RTTIMER of TCB with (SETUPTIMER 0 (fetch TCB.RTTIMER of TCB)))))
)

(\TCP.SEND.DATA
(LAMBDA (TCB SEGMENT LENGTH FLAGS) (* wjy "13-Dec-85 14:30") (* * This function is used to send a TCP data segment for the first time. Subsequent retransmissions are done directly through \TCP.SEND.SEGMENT) (* * NOTE%: This function MUST be called with the TCB.LOCK already locked!) (PROG (SEQ TOP) (CHECK (OR (EQ LENGTH (\TCP.DATA.LENGTH SEGMENT)) (SHOULDNT "bad segment length"))) (CHECK (OR (ILEQ LENGTH (fetch TCB.MAXSEG of TCB)) (SHOULDNT "segment > max segment size"))) (if (NEQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) then (* ACK in all synchronized states) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK))) (SETQ SEQ (fetch TCB.SND.NXT of TCB)) (* assign sequence number) (if (fetch TCB.ACKFLG of TCB) then (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK))) (SETQ TOP (IPLUS SEQ LENGTH (\TCP.SYN.OR.FIN FLAGS))) (CHECK (OR (\32BIT.GEQ TOP (fetch TCB.SND.NXT of TCB)) (SHOULDNT "bad sequence numbers"))) (replace TCP.SEQ of SEGMENT with SEQ) (if (BITTEST FLAGS \TCP.CTRL.URG) then (replace TCB.SND.UP of TCB with TOP)) (if (\32BIT.GT (fetch TCB.SND.UP of TCB) SEQ) then (* there's urgent data to send) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.URG)) (replace TCP.URG.PTR of SEGMENT with (IDIFFERENCE (fetch TCB.SND.UP of TCB) SEQ)) else (* no urgent data) (* drag the urgent pointer along at the left edge of the window) (replace TCB.SND.UP of TCB with (fetch TCB.SND.UNA of TCB))) (if (BITTEST FLAGS \TCP.CTRL.FIN) then (* remember the sequence number of the FIN so we can tell when it's been acked) (CHECK (OR (EQ (fetch TCB.STATE of TCB) (QUOTE FIN.WAIT.1)) (EQ (fetch TCB.STATE of TCB) (QUOTE LAST.ACK)) (SHOULDNT "bad state for FIN"))) (replace TCB.FINSEQ of TCB with TOP)) (replace TCB.SND.NXT of TCB with TOP) (do (* try to send segment) (SELECTQ (fetch TCB.STATE of TCB) (LISTEN (ERROR "TCP connection not established")) ((SYN.SENT SYN.RECEIVED ESTABLISHED FIN.WAIT.1 CLOSE.WAIT LAST.ACK) (if (OR (ZEROP LENGTH) (ZEROP (fetch TCB.SND.WL1 of TCB)) (\32BIT.LEQ TOP (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB))) (\32BIT.GT (fetch TCB.SND.UP of TCB) (fetch TCB.SND.UNA of TCB))) then (* go ahead and send it) (CHECK (OR (ZEROP LENGTH) (ZEROP (fetch TCB.SND.WL1 of TCB)) (\32BIT.LEQ TOP (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB))))) (replace TCB.OUTPUT.HELD of TCB with NIL) (* advance SND.NXT) (\TCP.FIX.OUTGOING.SEGMENT TCB SEGMENT FLAGS) (replace EPREQUEUE of SEGMENT with (fetch TCB.REXMT.QUEUE of TCB)) (replace EPUSERFIELD of SEGMENT with (CLOCK0 (CREATECELL \FIXP))) (\TCP.SEND.SEGMENT TCB SEGMENT FLAGS) (RETURN) else (* block until we can send it) (replace TCB.OUTPUT.HELD of TCB with T) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.SND.EVENT of TCB)))) ((FIN.WAIT.2 CLOSING TIME.WAIT) (ERROR "TCP connection closing")) (CLOSED (ERROR "TCP connection closed")) (SHOULDNT)))))
)

(\TCP.SEND.SEGMENT
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "28-Dec-84 18:06") (* common routine to transmit a TCP segment) (\TCP.CHECKSUM.OUTGOING TCB SEGMENT) (\TCP.TRACE.SEGMENT (QUOTE SEND) SEGMENT) (if TCB then (if (BITTEST FLAGS \TCP.CTRL.ACK) then (replace TCB.ACKFLG of TCB with NIL)) (\TCP.START.PROBE.TIMER TCB)) (\IP.TRANSMIT SEGMENT))
)

(\TCP.NEW.TEMPLATE
(LAMBDA (TCB) (* ejs%: "29-Dec-84 13:05") (replace TCB.TEMPLATE of TCB with NIL) (\TCP.TEMPLATE TCB)))

(\TCP.START.PROBE.TIMER
(LAMBDA (TCB) (* ejs%: "12-Aug-86 10:35") (replace TCB.PROBE.TIMER of TCB with (COND ((AND (fetch TCB.NO.IDLE.PROBING of TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE ESTABLISHED))) NIL) (T (COND ((NULL (fetch TCB.PROBE.TIMER of TCB)) (LET ((IPSOCKET (fetch TCB.IPSOCKET of TCB))) (COND (IPSOCKET (NOTIFY.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET))))))) (SETUPTIMER (ITIMES 4 (fetch TCB.RTO of TCB)) (fetch TCB.PROBE.TIMER of TCB))))))
)

(\TCP.RETRANSMIT
(LAMBDA (TCB) (* ejs%: " 3-Jun-85 07:58") (* find the first unacknowledged segment and retransmit it) (PROG ((QUEUE (fetch TCB.REXMT.QUEUE of TCB)) (UNA (fetch TCB.SND.UNA of TCB)) CURRENT CURSEQ NEXT PREV REST FIRSTSEG MINSEQ FLAGS) (UNINTERRUPTABLY (* detach the list of segments to be retransmitted so we don't interfere with the driver) (SETQ NEXT (fetch SYSQUEUEHEAD of QUEUE)) (replace SYSQUEUEHEAD of QUEUE with NIL) (replace SYSQUEUETAIL of QUEUE with NIL)) (while (SETQ CURRENT NEXT) do (SETQ NEXT (fetch QLINK of CURRENT)) (replace QLINK of CURRENT with NIL) (if (\32BIT.LEQ (IPLUS (SETQ CURSEQ (fetch TCP.SEQ of CURRENT)) (\TCP.DATA.LENGTH CURRENT) (\TCP.SYN.OR.FIN (fetch TCP.CTRL of CURRENT))) UNA) then (* this segment has already been acked) (\TCP.RELEASE.SEGMENT CURRENT) elseif (NULL FIRSTSEG) then (* this is the first unacked segment we've encountered) (SETQ FIRSTSEG CURRENT) (SETQ MINSEQ CURSEQ) elseif (\32BIT.LT CURSEQ MINSEQ) then (* this is the lowest sequence number seen so so far; put the previous contender back on the REST queue) (replace QLINK of FIRSTSEG with REST) (SETQ REST FIRSTSEG) (SETQ FIRSTSEG CURRENT) (SETQ MINSEQ CURSEQ) else (* this is an unacked segment but later than one we've already seen; just add it to the REST queue) (replace QLINK of CURRENT with REST) (SETQ REST CURRENT))) (UNINTERRUPTABLY (* set the retransmit queue to be the REST queue we've accumulated) (if (SETQ CURRENT REST) then (* find tail of REST queue) (while (SETQ NEXT (fetch QLINK of CURRENT)) do (SETQ CURRENT NEXT))) (replace SYSQUEUEHEAD of QUEUE with REST) (replace SYSQUEUETAIL of QUEUE with CURRENT)) (if FIRSTSEG then (if (IGEQ (CLOCKDIFFERENCE (fetch EPUSERFIELD of FIRSTSEG)) (fetch TCB.RTO of TCB)) then (SETQ FLAGS (fetch TCP.CTRL of FIRSTSEG)) (\TCP.FIX.OUTGOING.SEGMENT TCB FIRSTSEG FLAGS) (replace EPREQUEUE of FIRSTSEG with (fetch TCB.REXMT.QUEUE of TCB)) (CLOCK0 (fetch EPUSERFIELD of FIRSTSEG)) (\TCP.SEND.SEGMENT TCB FIRSTSEG FLAGS) (RETURN T) else (\ENQUEUE (fetch TCB.REXMT.QUEUE of TCB) FIRSTSEG) (RETURN NIL)) else (RETURN NIL))))
)

(\TCP.START.TIME.WAIT
(LAMBDA (TCB) (* ecc "16-Apr-84 17:58") (* start 2MSL timer) (replace TCB.2MSL.TIMER of TCB with (SETUPTIMER (ITIMES 2 \TCP.MSL) (fetch TCB.2MSL.TIMER of TCB))) (\TCP.TRACE.TRANSITION TCB (QUOTE TIME.WAIT)) (replace TCB.STATE of TCB with (QUOTE TIME.WAIT)))
)

(\TCP.CONNECTION.DROPPED
(LAMBDA (TCB MSG) (* ejs%: "29-Jan-85 16:06") (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[TCP connection " (OR MSG "dropped") "]" T)) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED)) (AND (OPENP (fetch TCB.RCV.STREAM of TCB) (QUOTE INPUT)) (CLOSEF (fetch TCB.RCV.STREAM of TCB))) (AND (OPENP (fetch TCB.SND.STREAM of TCB) (QUOTE OUTPUT)) (CLOSEF (fetch TCB.SND.STREAM of TCB))) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB)))
)

(\TCP.CHECK.OPTIONS
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "21-Mar-86 20:04") (* * Do TCP header options processing) (COND ((IGREATERP (fetch (TCPSEGMENT TCP.DATA.OFFSET) of SEGMENT) \TCP.MIN.DATA.OFFSET) (\TCP.PROCESS.OPTIONS TCB SEGMENT FLAGS)) (T T)))
)

(\TCP.PROCESS.OPTIONS
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "20-Jun-85 16:08") (* * Process the options in a TCP header) (bind (OPTIONBASE _ (fetch (TCPSEGMENT TCP.OPTIONS) of SEGMENT)) (OPTIONOFFSET _ 0) OPTION eachtime (SETQ OPTION (\GETBASEBYTE OPTIONBASE OPTIONOFFSET)) until (EQ OPTION \TCPOPT.END) do (SELECTC OPTION (\TCPOPT.END (HELP "Unexpected \TCPOPT.END processing TCP options")) (\TCPOPT.NOP (add OPTIONOFFSET 1)) (\TCPOPT.MAXSEG (COND ((BITTEST FLAGS \TCP.CTRL.SYN) (replace TCB.MAXSEG of TCB with (IMIN \TCP.DEFAULT.MAXSEG (LOGOR (LLSH (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 2)) BITSPERBYTE) (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 3))))))) (add OPTIONOFFSET (\GETBASEBYTE OPTIONBASE (ADD1 OPTIONOFFSET)))) (RETURN))) T)
)
)



(* ;; "support for ICMP messages that affect TCP connections")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.PROTOCOL 1)


(CONSTANTS \ICMP.PROTOCOL)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.32BIT.WORDS 2)


(CONSTANTS \ICMP.32BIT.WORDS)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.DESTINATION.UNREACHABLE 3)

(RPAQQ \ICMP.SOURCE.QUENCH 4)


(CONSTANTS \ICMP.DESTINATION.UNREACHABLE \ICMP.SOURCE.QUENCH)
)
)
(DEFINEQ

(\TCP.HANDLE.ICMP
(LAMBDA (ICMP SEGMENT) (* ejs%: " 3-Jun-85 07:41") (* handle ICMP messages) (PROG (MSG TCB) (if (NEQ (fetch (ICMP ICMPTYPE) of ICMP) \ICMP.DESTINATION.UNREACHABLE) then (RETURN)) (SETQ MSG (SELECTQ (fetch (ICMP ICMPCODE) of ICMP) (0 "net unreachable") (1 "host unreachable") (2 "protocol unreachable") (3 "port unreachable") (4 "fragmentation needed and DF set") (5 "source route failed") "destination unreachable (unknown code)")) (SETQ TCB (\TCP.LOOKUP.TCB (fetch TCP.DST.ADDR of SEGMENT) (fetch TCP.DST.PORT of SEGMENT) (fetch TCP.SRC.PORT of SEGMENT))) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED))) then (RETURN)) (\RELEASE.ETHERPACKET ICMP) (\TCP.CONNECTION.DROPPED TCB MSG)))
)
)



(* ;; "TCP stream routines")

(DEFINEQ

(TCP.OPEN
(LAMBDA (DST.HOST DST.PORT SRC.PORT MODE ACCESS NOERRORFLG OPTIONS) (* ejs%: "21-Mar-86 17:38") (PROG (TCB DST.HOST.NUMBER) (SELECTQ ACCESS (INPUT) (APPEND) (OUTPUT (SETQ ACCESS (QUOTE APPEND))) (LISPERROR "ILLEGAL ARG" ACCESS)) (COND ((ATOM DST.HOST) (COND ((AND (NOT (SETQ DST.HOST.NUMBER (DODIP.HOSTP DST.HOST))) (EQ MODE (QUOTE ACTIVE))) (ERROR "Unknown TCP/IP host: " DST.HOST)))) ((FIXP DST.HOST) (SETQ DST.HOST.NUMBER DST.HOST)) (T (ERROR "Illegal TCP/IP host: " DST.HOST))) (SETQ TCB (\TCP.CONNECTION DST.HOST.NUMBER DST.PORT SRC.PORT MODE OPTIONS)) (RETURN (if (NULL TCB) then (if NOERRORFLG then NIL else (ERROR "TCP connection failed")) else (SELECTQ ACCESS (INPUT (fetch TCB.RCV.STREAM of TCB)) (APPEND (fetch TCB.SND.STREAM of TCB)) (SHOULDNT))))))
)

(TCP.OTHER.STREAM
(LAMBDA (STREAM) (* ecc "14-May-84 16:52") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (NOT (type? TCP.CONTROL.BLOCK TCB)) then (ERROR "no TCP control block")) (RETURN (SELECTQ (fetch (TCPSTREAM ACCESS) of STREAM) (INPUT (fetch TCB.SND.STREAM of TCB)) (APPEND (fetch TCB.RCV.STREAM of TCB)) (SHOULDNT)))))
)

(\TCP.BOUTS
(LAMBDA (STREAM BASE OFF NBYTES) (* ejs%: "27-May-86 15:09") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (RETURN (\BUFFERED.BOUTS (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of TCB) BASE OFF NBYTES))))
)

(\TCP.OTHER.BIN
(LAMBDA (STREAM) (* ejs%: "27-May-86 14:40") (\BIN (TCP.OTHER.STREAM STREAM))))

(\TCP.OTHER.BOUT
(LAMBDA (STREAM BYTE) (* ejs%: "27-May-86 14:19") (BOUT (TCP.OTHER.STREAM STREAM) BYTE)))

(\TCP.BIN
(LAMBDA (STREAM) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (RETURN (\GETBASEBYTE (fetch CPPTR of STREAM) (PROG1 (fetch COFFSET of STREAM) (add (fetch COFFSET of STREAM) 1)))) elseif (NULL (\TCP.GET.SEGMENT STREAM)) then (RETURN (STREAMOP (QUOTE ENDOFSTREAMOP) STREAM STREAM)))))
)

(\TCP.BACKFILEPTR
(LAMBDA (STREAM) (* ejs%: "15-Sep-85 23:25") (COND ((AND (fetch CPPTR of STREAM) (IGEQ (fetch COFFSET of STREAM) (fetch (TCPSTREAM ORIGINAL.COFFSET) of STREAM))) (add (fetch COFFSET of STREAM) -1)) (T (\IS.NOT.RANDACCESSP STREAM))))
)

(\TCP.GETNEXTBUFFER
(LAMBDA (STREAM WHATFOR NOERRORFLG) (* ejs%: "27-May-86 14:45") (BLOCK) (SELECTQ WHATFOR (READ (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.RCV.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (SETQ STREAM (TCP.OTHER.STREAM STREAM)))) (\TCP.GET.SEGMENT STREAM NOERRORFLG)) (WRITE (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (SETQ STREAM (TCP.OTHER.STREAM STREAM)))) (\TCP.FLUSH STREAM) (\TCP.FILL.IN.SEGMENT STREAM)) (SHOULDNT)))
)

(\TCP.GET.SEGMENT
(LAMBDA (STREAM NOERRORFLG) (* ejs%: "18-Dec-86 17:33") (* * Get the next segment from the input stream. Return T if successful; otherwise, an error code. Call the user-specified error handler to get a code, if necessary) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM)) SEGMENT SEQ LEN OLDSEGMENT OLDSEQ OLDLEN OLDTOP SUCCESS OFFSET LAST.BYTE) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB)))) then (ERROR "not TCP input stream")) (WITH.MONITOR (fetch TCB.LOCK of TCB) (SETQ OLDSEGMENT (fetch TCB.RCV.SEGMENT of TCB)) (CHECK (OR (NULL OLDSEGMENT) (EQ (fetch TCP.DATA.LENGTH of OLDSEGMENT) (fetch CBUFSIZE of STREAM)) (SHOULDNT "inconsistent stream buffer size"))) (UNINTERRUPTABLY (COND ((fetch CPPTR of STREAM) (SETQ LAST.BYTE (\GETBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM))))) (replace TCB.RCV.SEGMENT of TCB with NIL) (replace CPPTR of STREAM with NIL) (replace CBUFSIZE of STREAM with 0) (replace COFFSET of STREAM with 0)) (if OLDSEGMENT then (* remember sequence number range of previous segment so we can adjust for overlap) (SETQ OLDTOP (IPLUS (SETQ OLDSEQ (fetch TCP.SEQ of OLDSEGMENT)) (SETQ OLDLEN (fetch TCP.DATA.LENGTH of OLDSEGMENT)))) (replace TCB.RCV.WND of TCB with (IMIN \TCP.DEFAULT.RECEIVE.WINDOW (IPLUS (fetch TCB.RCV.WND of TCB) OLDLEN))) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) OLDLEN) (\TCP.RELEASE.SEGMENT OLDSEGMENT) (SETQ OLDSEGMENT T)) (* look at first segment in input queue to see if it overlaps the sequence number range we're expecting; there may be duplicates that must be skipped over) (do ((CHECK (\TCP.CHECK.INPUT.QUEUE TCB)) (COND ((AND (SETQ SEGMENT (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (\32BIT.LT (SETQ SEQ (fetch TCP.SEQ of SEGMENT)) (fetch TCB.RCV.NXT of TCB))) (* this segment is within the range of contiguous sequence numbers received so far, because its sequence number is less than RCV.NXT) (\DEQUEUE (fetch TCB.INPUT.QUEUE of TCB)) (SETQ LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (COND ((AND OLDSEGMENT (\32BIT.LEQ (IPLUS SEQ LEN) OLDTOP)) (* this segment is a duplicate) (\TCP.RELEASE.SEGMENT SEGMENT)) (T (* this segment overlaps with the range of sequence numbers we're expecting) (CHECK (OR (NOT OLDSEGMENT) (\32BIT.LEQ SEQ OLDTOP) (SHOULDNT "gap in input queue"))) (UNINTERRUPTABLY (replace CPPTR of STREAM with (fetch TCP.CONTENTS of SEGMENT)) (* eliminate overlap) (SETQ OFFSET (replace (TCPSTREAM ORIGINAL.COFFSET) of STREAM with (replace COFFSET of STREAM with (COND (OLDSEGMENT (IDIFFERENCE OLDLEN (IDIFFERENCE SEQ OLDSEQ))) (T 0))))) (COND (LAST.BYTE (\PUTBASEBYTE (fetch CPPTR of STREAM) (SUB1 OFFSET) LAST.BYTE))) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) (IMINUS OFFSET)) (replace CBUFSIZE of STREAM with LEN) (replace TCB.RCV.SEGMENT of TCB with SEGMENT)) (SETQ SUCCESS T) (RETURN)))) (T (SELECTQ (fetch TCB.STATE of TCB) ((LISTEN SYN.SENT SYN.RECEIVED) (* wait until established) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB))) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (* wait for next segment) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.RCV.EVENT of TCB)) (SELECTQ (fetch TCB.STATE of TCB) ((CLOSED CLOSING LAST.ACK) (RELEASE.MONITORLOCK (fetch TCB.LOCK of TCB)) (COND (NOERRORFLG (RETURN NIL)) (T (RETURN (SETQ SUCCESS (\EOF.ACTION STREAM)))))) NIL)) ((CLOSED CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT) (* return NIL to punt to ENDOFSTREAMOP in \TCP.BIN) (RELEASE.MONITORLOCK (fetch TCB.LOCK of TCB)) (COND (NOERRORFLG (RETURN NIL)) (T (RETURN (SETQ SUCCESS (\EOF.ACTION STREAM)))))) (SHOULDNT))))))) (if (fetch TCB.SENT.ZERO of TCB) then (\TCP.SEND.ACK TCB (QUOTE NOW)) (BLOCK)) (RETURN SUCCESS)))
)

(\TCP.PEEKBIN
(LAMBDA (STREAM NOERRORFLG) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (RETURN (\GETBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM))) elseif (NULL (\TCP.GET.SEGMENT STREAM)) then (RETURN (if NOERRORFLG then NIL else (STREAMOP (QUOTE ENDOFSTREAMOP) STREAM STREAM))))))
)

(\TCP.GETFILEPTR
(LAMBDA (STREAM) (* ejs%: "10-Jun-85 14:07") (IPLUS (fetch (STREAM COFFSET) of STREAM) (fetch (TCPSTREAM BYTECOUNT) of STREAM)))
)

(\TCP.READP
(LAMBDA (STREAM) (* ejs%: " 7-Jun-85 13:39") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB)))) then (ERROR "not TCP input stream") else (RETURN (OR (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) (AND (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) T))))))
)

(\TCP.EOFP
(LAMBDA (STREAM) (* ejs%: "13-Apr-85 16:15") (* check whether EOF has been reached on stream -- may block waiting for next segment) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (NULL TCB) then (ERROR "not TCP stream") elseif (AND (NEQ (QUOTE CLOSED) (fetch TCB.STATE of TCB)) (EQ STREAM (fetch TCB.SND.STREAM of TCB))) then (RETURN T) (* Always at EOF of outgoing stream.) elseif (OR (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) (NOT (NULL (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))))) then (* there is still data left to read) (RETURN NIL) else (RETURN (SELECTQ (fetch TCB.STATE of TCB) (ESTABLISHED NIL) ((LISTEN SYN.SENT SYN.RECEIVED FIN.WAIT.1 FIN.WAIT.2) (* can't tell without waiting for next segment) (NULL (\TCP.GET.SEGMENT STREAM T))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT CLOSED) (* no more data can be forthcoming) T) (SHOULDNT))))))
)

(TCP.URGENTP
(LAMBDA (STREAM) (* ecc " 7-May-84 14:27") (* check if current point in receive stream is before receive urgent pointer) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB))) then (ERROR "not TCP input stream")) (RETURN (AND (fetch TCB.RCV.SEGMENT of TCB) (\32BIT.GT (fetch TCB.RCV.UP of TCB) (IPLUS (fetch TCP.SEQ of (fetch TCB.RCV.SEGMENT of TCB)) (fetch COFFSET of STREAM)))))))
)

(TCP.URGENT.EVENT
(LAMBDA (STREAM) (* edited%: "22-May-84 18:10") (* return the urgent data event so that a user process can wait for it) (fetch TCB.URGENT.EVENT of (fetch (TCPSTREAM TCB) of STREAM)))
)

(\TCP.BOUT
(LAMBDA (STREAM CHAR) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (\PUTBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM) CHAR) (add (fetch COFFSET of STREAM) 1) (RETURN) else (\TCP.FLUSH STREAM) (\TCP.FILL.IN.SEGMENT STREAM))))
)

(\TCP.FLUSH
(LAMBDA (STREAM FLAGS) (* ; "Edited  4-Dec-87 12:11 by scp") (* Force out current output segment. If FLAGS is non-nil, send a segment with those flags even if we have to create a new one) (PROG ((TCB (fetch TCB of STREAM)) SEGMENT LENGTH) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.SND.STREAM of TCB)))) then (ERROR "not TCP output stream")) (SETQ LENGTH (fetch COFFSET of STREAM)) (WITH.FAST.MONITOR (fetch TCB.LOCK of TCB) (if (OR (AND (SETQ SEGMENT (fetch TCB.SND.SEGMENT of TCB)) (NOT (ZEROP LENGTH))) (AND FLAGS (SETQ SEGMENT (\TCP.FILL.IN.SEGMENT STREAM (COND ((EQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) (BQUOTE (MAXSEG %, (OR (fetch TCB.OUR.MAXSEG of TCB) \TCP.DEFAULT.MAXSEG)))) ((EQ (fetch TCB.STATE of TCB) (QUOTE SYN.RECEIVED)) (BQUOTE (MAXSEG %, (OR (fetch TCB.OUR.MAXSEG of TCB) \TCP.DEFAULT.MAXSEG))))))))) then (if (NULL FLAGS) then (SETQ FLAGS 0)) (CHECK (OR (NOT (ZEROP LENGTH)) (NOT (ZEROP (\TCP.SYN.OR.FIN FLAGS))) (SHOULDNT "sending empty segment"))) (if (AND (IGREATERP LENGTH 0) (ILESSP LENGTH (fetch TCB.OUR.MAXSEG of TCB))) then (* PSH this segment to make sure it gets through to the remote process) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.PSH))) (UNINTERRUPTABLY (replace TCB.SND.SEGMENT of TCB with NIL) (replace CBUFSIZE of STREAM with 0) (replace COFFSET of STREAM with 0) (replace CPPTR of STREAM with NIL) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) LENGTH)) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) LENGTH) (\TCP.SEND.DATA TCB SEGMENT LENGTH FLAGS)))))
)

(\TCP.FORCEOUTPUT
(LAMBDA (STREAM WAITFLG) (* ejs%: "27-May-86 14:36") (* just call \TCP.FLUSH with no flags -- to implement WAITFLG we should wait for SND.UNA to overtake the current SND.NXT) (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (\TCP.FLUSH (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM)))) (T (\TCP.FLUSH STREAM))))
)

(TCP.URGENT.MARK
(LAMBDA (STREAM) (* ecc " 7-May-84 14:17") (* mark the current point in the output stream as the end of urgent data) (\TCP.FLUSH STREAM \TCP.CTRL.URG))
)

(\TCP.FILL.IN.SEGMENT
(LAMBDA (STREAM OPTIONS) (* ejs%: "22-Jun-85 03:18") (* * set up a new segment to be filled by the output stream. OPTIONS, if supplied, is in PLIST format) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM)) SEGMENT) (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCB.SRC.PORT of TCB) (fetch TCB.DST.HOST of TCB) (fetch TCB.DST.PORT of TCB))) (COND (OPTIONS (\TCP.SETUP.SEGMENT.OPTIONS SEGMENT OPTIONS))) (UNINTERRUPTABLY (replace TCB.SND.SEGMENT of TCB with SEGMENT) (replace CPPTR of STREAM with (fetch TCP.CONTENTS of SEGMENT)) (replace COFFSET of STREAM with 0) (replace CBUFSIZE of STREAM with (fetch TCB.MAXSEG of TCB)) (replace CBUFMAXSIZE of STREAM with (fetch TCB.MAXSEG of TCB))) (RETURN SEGMENT)))
)

(\TCP.CLOSE
(LAMBDA (STREAM) (* ejs%: "29-Jan-85 17:19") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (FMEMB (fetch TCB.STATE of TCB) (QUOTE (CLOSED TIME.WAIT)))) then (RETURN)) (if (NOT (fetch TCB.CLOSEDFLG of TCB)) then (TCP.CLOSE.SENDER (fetch TCB.SND.STREAM of TCB))) (if (EQ STREAM (fetch TCB.RCV.STREAM of TCB)) then (while (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) do (* gobble remaining segments from remote end) (\TCP.GET.SEGMENT STREAM)))))
)

(\TCP.RESETCLOSE
(LAMBDA (STREAM) (* ejs%: "27-May-86 11:55") (\TCP.CLOSE STREAM)))

(TCP.CLOSE.SENDER
(LAMBDA (STREAM) (* ecc " 7-May-84 13:44") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (fetch TCB.CLOSEDFLG of TCB)) then (RETURN)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (replace TCB.CLOSEDFLG of TCB with T) (SELECTQ (fetch TCB.STATE of TCB) ((LISTEN SYN.SENT) (\TCP.CONNECTION.DROPPED TCB "closed")) ((SYN.RECEIVED ESTABLISHED) (\TCP.TRACE.TRANSITION TCB (QUOTE FIN.WAIT.1)) (replace TCB.STATE of TCB with (QUOTE FIN.WAIT.1)) (\TCP.FLUSH STREAM \TCP.CTRL.FIN)) (CLOSE.WAIT (\TCP.TRACE.TRANSITION TCB (QUOTE LAST.ACK)) (replace TCB.STATE of TCB with (QUOTE LAST.ACK)) (* There is an inconsistency in the spec about this transition%: the description of the CLOSE operation says to go to the CLOSING state, while the diagram shows a transition to the LAST.ACK state. Since the LAST.ACK state avoids the 2MSL wait, we use it.) (\TCP.FLUSH STREAM \TCP.CTRL.FIN)) NIL) (while (NOT (OR (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (\TCP.OUR.FIN.IS.ACKED TCB))) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.FINACKED.EVENT of TCB))))))
)

(TCP.DESTADDRESS
(LAMBDA (STREAM) (* ejs%: "27-May-86 11:53") (\IP.ADDRESS.TO.STRING (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of (fetch (TCPSTREAM TCB) of STREAM))))
)

(TCP.STOP
(LAMBDA NIL (* ejs%: "28-Dec-84 18:02") (MAPC \TCP.CONTROL.BLOCKS (FUNCTION \TCP.DELETE.TCB)) (SETQ \TCP.CONTROL.BLOCKS NIL) (\IP.DELETE.PROTOCOL \TCP.PROTOCOL))
)
)



(* ;; "well-known ports for network standard functions")


(RPAQQ \TCP.ASSIGNED.PORTS 
       (\TCP.ECHO.PORT \TCP.SINK.PORT \TCP.SYSTAT.PORT \TCP.DAYTIME.PORT \TCP.NETSTAT.PORT 
              \TCP.FAUCET.PORT \TCP.FTP.PORT \TCP.TELNET.PORT \TCP.SMTP.PORT \TCP.TIME.PORT 
              \TCP.NAME.PORT \TCP.WHOIS.PORT \TCP.NAMESERVER.PORT \TCP.FINGER.PORT \TCP.TTYLINK.PORT
              \TCP.SUPDUP.PORT \TCP.HOSTNAMES.PORT \TCP.UNIXEXEC.PORT \TCP.UNIXLOGIN.PORT 
              \TCP.UNIXSHELL.PORT))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.ECHO.PORT 7)

(RPAQQ \TCP.SINK.PORT 9)

(RPAQQ \TCP.SYSTAT.PORT 11)

(RPAQQ \TCP.DAYTIME.PORT 13)

(RPAQQ \TCP.NETSTAT.PORT 15)

(RPAQQ \TCP.FAUCET.PORT 19)

(RPAQQ \TCP.FTP.PORT 21)

(RPAQQ \TCP.TELNET.PORT 23)

(RPAQQ \TCP.SMTP.PORT 25)

(RPAQQ \TCP.TIME.PORT 37)

(RPAQQ \TCP.NAME.PORT 42)

(RPAQQ \TCP.WHOIS.PORT 43)

(RPAQQ \TCP.NAMESERVER.PORT 53)

(RPAQQ \TCP.FINGER.PORT 79)

(RPAQQ \TCP.TTYLINK.PORT 87)

(RPAQQ \TCP.SUPDUP.PORT 95)

(RPAQQ \TCP.HOSTNAMES.PORT 101)

(RPAQQ \TCP.UNIXEXEC.PORT 512)

(RPAQQ \TCP.UNIXLOGIN.PORT 513)

(RPAQQ \TCP.UNIXSHELL.PORT 514)


(CONSTANTS \TCP.ECHO.PORT \TCP.SINK.PORT \TCP.SYSTAT.PORT \TCP.DAYTIME.PORT \TCP.NETSTAT.PORT 
       \TCP.FAUCET.PORT \TCP.FTP.PORT \TCP.TELNET.PORT \TCP.SMTP.PORT \TCP.TIME.PORT \TCP.NAME.PORT 
       \TCP.WHOIS.PORT \TCP.NAMESERVER.PORT \TCP.FINGER.PORT \TCP.TTYLINK.PORT \TCP.SUPDUP.PORT 
       \TCP.HOSTNAMES.PORT \TCP.UNIXEXEC.PORT \TCP.UNIXLOGIN.PORT \TCP.UNIXSHELL.PORT)
)



(* ;; "Stub for debugging")


(RPAQ? \TCP.DEBUGGABLE )

(RPAQ? TCPTRACEFLG )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG)
)
(DEFINEQ

(PPTCB
(LAMBDA (TCB FILE) (* ejs%: " 5-Feb-85 16:47") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE)) (COND (\TCP.DEBUGGABLE (printout FILE "TCP connection from " %# (\IP.PRINT.ADDRESS (\LOCAL.IP.ADDRESS) FILE) ":" (fetch TCB.SRC.PORT of TCB) " to " %# (\IP.PRINT.ADDRESS (fetch TCB.DST.HOST of TCB) FILE) ":" (fetch TCB.DST.PORT of TCB) " " (fetch TCB.STATE of TCB) T) (printout FILE " iss " (fetch TCB.ISS of TCB) " window " (fetch TCB.SND.UNA of TCB) ".." (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB)) " next " (fetch TCB.SND.NXT of TCB)) (if (fetch TCB.FINSEQ of TCB) then (printout FILE " fin " (fetch TCB.FINSEQ of TCB))) (printout FILE " rto " (fetch TCB.RTO of TCB) T) (printout FILE " irs " (fetch TCB.IRS of TCB) " next " (fetch TCB.RCV.NXT of TCB) " window " (fetch TCB.RCV.NXT of TCB) ".." (IPLUS (fetch TCB.RCV.NXT of TCB) (fetch TCB.RCV.WND of TCB)) T) (\TCP.PRINT.SEGMENT.QUEUE "retransmit queue" (fetch TCB.REXMT.QUEUE of TCB) FILE) (\TCP.PRINT.SEGMENT.QUEUE "input queue" (fetch TCB.INPUT.QUEUE of TCB) FILE))))
)

(\TCP.TRACE.SEGMENT
(LAMBDA (CALLER SEGMENT) (* ejs%: " 5-Feb-85 16:50") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG)) (if (AND \TCP.DEBUGGABLE (MEMB CALLER TCPTRACEFLG)) then (printout TCPTRACEFILE .TAB0 0 %# (\TCP.PRINT.ELAPSED.TIME TCPTRACEFILE) CALLER ": " %# (TCP.PRINT.SEGMENT SEGMENT TCPTRACEFILE NIL (MEMB (QUOTE CONTENTS) TCPTRACEFLG)))))
)

(\TCP.TRACE.TRANSITION
(LAMBDA (TCB NEWSTATE) (* ejs%: " 5-Feb-85 16:51") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE)) (if (AND \TCP.DEBUGGABLE (MEMB (QUOTE TRANSITION) TCPTRACEFLG) (NEQ (fetch TCB.STATE of TCB) NEWSTATE)) then (printout TCPTRACEFILE .TAB0 0 %# (\TCP.PRINT.ELAPSED.TIME TCPTRACEFILE) (fetch TCB.SRC.PORT of TCB) "/" (fetch TCB.DST.PORT of TCB) ": " (fetch TCB.STATE of TCB) " ---> " NEWSTATE)))
)
)



(* ;; "TCP initialization")

(DEFINEQ

(\TCP.INIT
(LAMBDA NIL (* ; "Edited 11-Aug-88 14:32 by atm") (COND ((NULL \TCP.DEVICE) (SETQ \TCP.DEVICE (create FDEV FDBINABLE _ T FDBOUTABLE _ T BUFFERED _ T CLOSEFILE _ (FUNCTION \TCP.CLOSE) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM) OPENP _ (FUNCTION \GENERIC.OPENP) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION \BUFFERED.BOUT) BLOCKIN _ (FUNCTION \BUFFERED.BINS) BLOCKOUT _ (FUNCTION \TCP.BOUTS) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) READP _ (FUNCTION \TCP.READP) FORCEOUTPUT _ (FUNCTION \TCP.FORCEOUTPUT) GETNEXTBUFFER _ (FUNCTION \TCP.GETNEXTBUFFER) BACKFILEPTR _ (FUNCTION \TCP.BACKFILEPTR) GETFILEPTR _ (FUNCTION \TCP.GETFILEPTR) EOFP _ (FUNCTION \TCP.EOFP) DEVICENAME _ (QUOTE TCP) EVENTFN _ (FUNCTION NILL))) (\DEFINEDEVICE (QUOTE TCP) \TCP.DEVICE))) (SETQ \TCP.LOCK (CREATE.MONITORLOCK)) (COND ((NULL \TCP.PSEUDOHEADER) (SETQ \TCP.PSEUDOHEADER (create TCP.PSEUDOHEADER)))) (OR \IPFLG (\IPINIT)) (\IP.ADD.PROTOCOL \TCP.PROTOCOL (FUNCTION \TCP.PORTCOMPARE) (FUNCTION \TCP.NOSOCKETFN) NIL (FUNCTION \TCP.HANDLE.ICMP)) (SETQ \TCP.MASTER.SOCKET (\IP.FIND.PROTOCOL \TCP.PROTOCOL)))
)
)

(\TCP.INIT)
(PUTPROPS TCP COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1901 1900 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (8342 9364 (SET.IP.ADDRESS 8352 . 8622) (STRING.TO.IP.ADDRESS 8624 . 8865) (
IP.ADDRESS.TO.STRING 8867 . 9091) (\LOCAL.IP.ADDRESS 9093 . 9362)) (14232 14439 (\TCP.SELECT.ISS 14242
 . 14437)) (28588 34348 (\TCP.CREATE.TCB 28598 . 29684) (\TCP.SELECT.PORT 29686 . 29968) (
\TCP.LOOKUP.TCB 29970 . 30867) (\TCP.DELETE.TCB 30869 . 32537) (\TCP.NOSOCKETFN 32539 . 33367) (
\TCP.PORTCOMPARE 33369 . 34346)) (36215 38810 (\COMPUTE.CHECKSUM 36225 . 36891) (
\TCP.CHECKSUM.INCOMING 36893 . 37989) (\TCP.CHECKSUM.OUTGOING 37991 . 38808)) (39315 77802 (\TCP.ACK# 
39325 . 39782) (\TCP.PACKET.FILTER 39784 . 40055) (\TCP.SETUP.SEGMENT 40057 . 40587) (
\TCP.RELEASE.SEGMENT 40589 . 40843) (\TCP.CONNECTION 40845 . 44136) (\TCP.FIX.INCOMING.SEGMENT 44138
 . 44766) (\TCP.DATA.LENGTH 44768 . 45096) (\TCP.SYN.OR.FIN 45098 . 45438) (\TCP.INPUT 45440 . 48309) 
(\TCP.INPUT.INITIAL 48311 . 49094) (\TCP.INPUT.UNSYNC 49096 . 49466) (\TCP.INPUT.LISTEN 49468 . 50911)
 (\TCP.INPUT.SYN.SENT 50913 . 52778) (\TCP.CHECK.WINDOW 52780 . 53628) (\TCP.CHECK.RESET 53630 . 54398
) (\TCP.CHECK.SECURITY 54400 . 54600) (\TCP.CHECK.NO.SYN 54602 . 55166) (\TCP.CHECK.ACK 55168 . 55443)
 (\TCP.HANDLE.ACK 55445 . 56750) (\TCP.HANDLE.URG 56752 . 57345) (\TCP.QUEUE.INPUT 57347 . 61011) (
\TCP.HANDLE.FIN 61013 . 62109) (\TCP.OUR.FIN.IS.ACKED 62111 . 62378) (\TCP.SIGNAL.URGENT.DATA 62380 . 
62586) (\TCP.PROCESS 62588 . 65394) (\TCP.TEMPLATE 65396 . 66104) (\TCP.SETUP.SEGMENT.OPTIONS 66106 . 
67362) (\TCP.SEND.CONTROL 67364 . 68215) (\TCP.SEND.ACK 68217 . 68655) (\TCP.SEND.RESET 68657 . 69371)
 (\TCP.FIX.OUTGOING.SEGMENT 69373 . 70111) (\TCP.SEND.DATA 70113 . 72955) (\TCP.SEND.SEGMENT 72957 . 
73305) (\TCP.NEW.TEMPLATE 73307 . 73432) (\TCP.START.PROBE.TIMER 73434 . 73897) (\TCP.RETRANSMIT 73899
 . 75994) (\TCP.START.TIME.WAIT 75996 . 76281) (\TCP.CONNECTION.DROPPED 76283 . 76787) (
\TCP.CHECK.OPTIONS 76789 . 77047) (\TCP.PROCESS.OPTIONS 77049 . 77800)) (78261 78997 (\TCP.HANDLE.ICMP
 78271 . 78995)) (79035 93181 (TCP.OPEN 79045 . 79822) (TCP.OTHER.STREAM 79824 . 80161) (\TCP.BOUTS 
80163 . 80384) (\TCP.OTHER.BIN 80386 . 80485) (\TCP.OTHER.BOUT 80487 . 80597) (\TCP.BIN 80599 . 80952)
 (\TCP.BACKFILEPTR 80954 . 81210) (\TCP.GETNEXTBUFFER 81212 . 81725) (\TCP.GET.SEGMENT 81727 . 85444) 
(\TCP.PEEKBIN 85446 . 85802) (\TCP.GETFILEPTR 85804 . 85955) (\TCP.READP 85957 . 86354) (\TCP.EOFP 
86356 . 87244) (TCP.URGENTP 87246 . 87703) (TCP.URGENT.EVENT 87705 . 87911) (\TCP.BOUT 87913 . 88223) 
(\TCP.FLUSH 88225 . 89779) (\TCP.FORCEOUTPUT 89781 . 90199) (TCP.URGENT.MARK 90201 . 90375) (
\TCP.FILL.IN.SEGMENT 90377 . 91122) (\TCP.CLOSE 91124 . 91604) (\TCP.RESETCLOSE 91606 . 91693) (
TCP.CLOSE.SENDER 91695 . 92828) (TCP.DESTADDRESS 92830 . 93000) (TCP.STOP 93002 . 93179)) (94939 96765
 (PPTCB 94949 . 95990) (\TCP.TRACE.SEGMENT 95992 . 96350) (\TCP.TRACE.TRANSITION 96352 . 96763)) (
96802 97966 (\TCP.INIT 96812 . 97964)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPCHAT b/obsolete/tcp/TCPCHAT
new file mode 100644
index 00000000..0c4735fc
--- /dev/null
+++ b/obsolete/tcp/TCPCHAT
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 16:10:42" {DSK}<usr>local>lde>lispcore>library>TCPCHAT.;3 11300  

      changes to%:  (FILES TCP)
                    (VARS TCPCHATCOMS)

      previous date%: "15-Feb-90 13:09:03" {DSK}<usr>local>lde>lispcore>library>TCPCHAT.;2)


(* ; "
Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPCHATCOMS)

(RPAQQ TCPCHATCOMS
       [(FNS TCPCHAT.BIN TCPCHAT.HOST.FILTER TCPCHAT.NEGOTIATE TCPCHAT.OPEN TCPCHAT.OPTION.COMMAND 
             TCPCHAT.OPTION.INPUT TCPCHAT.OPTION.OUTPUT TCPCHAT.OPTION.TRACE TCPCHAT.TERMINAL.TYPE)
        (VARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS)
        (INITVARS (TCPCHAT.TRACEFLG)
               (TCPCHAT.TRACEFILE))
        (FILES (SYSLOAD)
               TCP CHAT)
        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES CHATDECLS)
               (COMS (CONSTANTS * TELNET.COMMANDS)
                     (CONSTANTS * TELNET.MARKS))
               (RECORDS TELNET.OPTION TELNET.OPTIONSTATE)
               (GLOBALVARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS TELNET.MARKS))
        (DECLARE%: DONTEVAL@LOAD DOCOPY 

               (* ;; "Tell Chat we exist ")

               (ADDVARS (CHAT.PROTOCOLTYPES (TCP . TCPCHAT.HOST.FILTER))
                      (CHAT.PROTOCOL.ABBREVS (N . TCP)
                             (T . TCP])
(DEFINEQ

(TCPCHAT.BIN
(LAMBDA (STREAM) (* ; "Edited  7-Jul-88 18:03 by atm") (bind CHAR while (AND (EQ (SETQ CHAR (\BUFFERED.BIN STREAM)) TELNET.IAC) (NEQ (SETQ CHAR (\BUFFERED.BIN STREAM)) TELNET.IAC)) do (TCPCHAT.NEGOTIATE CHAR STREAM) finally (RETURN CHAR)))
)

(TCPCHAT.HOST.FILTER
(LAMBDA (HOST) (* ; "Edited 12-Apr-88 17:14 by bvm") (COND ((AND \IPFLG (DODIP.HOSTP HOST)) (LIST HOST (FUNCTION TCPCHAT.OPEN)))))
)

(TCPCHAT.NEGOTIATE
(LAMBDA (COMMAND STREAM) (* ; "Edited  7-Jul-88 18:03 by atm") (TCPCHAT.OPTION.INPUT (TCP.OTHER.STREAM STREAM) COMMAND (\BUFFERED.BIN STREAM)))
)

(TCPCHAT.OPEN
(LAMBDA (HOST) (* ; "Edited 17-Apr-87 10:06 by jrb:") (PROG ((STREAM (TCP.OPEN (DODIP.HOSTP HOST) \TCP.TELNET.PORT NIL (QUOTE ACTIVE) (QUOTE INPUT))) (OSTYPE (OR (AND (GETHASH (U-CASE HOST) \IP.HOSTNAMES) (fetch (HOSTS.TXT.ENTRY HTE.OS.TYPE) of (GETHASH (U-CASE HOST) \IP.HOSTNAMES))) (GETHOSTINFO HOST (QUOTE OSTYPE)))) OUTPUTSTREAM) (COND (STREAM (replace (STREAM BINABLE) of STREAM with NIL) (* ; "Can't run microcoded") (replace (STREAM STRMBINFN) of STREAM with (FUNCTION TCPCHAT.BIN)) (STREAMPROP STREAM (QUOTE SETDISPLAYTYPE) (FUNCTION NILL)) (COND ((EQ OSTYPE (QUOTE INTERLISP)) (RETURN (CONS STREAM (TCP.OTHER.STREAM STREAM))))) (* ; "(STREAMPROP STREAM (QUOTE SETDISPLAYTYPE) (FUNCTION TCPCHAT.TERMINAL.TYPE))") (SETQ OUTPUTSTREAM (TCP.OTHER.STREAM STREAM)) (STREAMPROP OUTPUTSTREAM (QUOTE OPTIONSTATES) (for OPTION in TELNET.OPTIONS collect (create TELNET.OPTIONSTATE OPTION _ (fetch (TELNET.OPTION OPTION) of OPTION)))) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.ECHO) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.SUPPRESS.GOAHEAD) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.WILL TELNET.SUPPRESS.GOAHEAD) (COND ((NEQ OSTYPE (QUOTE UNIX)) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.BINARY) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.WILL TELNET.BINARY))) (RETURN (CONS STREAM OUTPUTSTREAM))))))
)

(TCPCHAT.OPTION.COMMAND
(LAMBDA (OUTPUTSTREAM COMMAND OPTION TRACECAPTION) (* ; "Edited 24-Aug-87 16:58 by scp") (LET ((OPTIONSTATE (FASSOC OPTION (STREAMPROP OUTPUTSTREAM (QUOTE OPTIONSTATES)))) GO.AHEAD.WITH.COMMAND) (COND ((NULL OPTIONSTATE) (SETQ GO.AHEAD.WITH.COMMAND T)) (T (SELECTC COMMAND (TELNET.DO (COND ((NEQ (fetch (TELNET.OPTIONSTATE DOING) of OPTIONSTATE) (QUOTE YES)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE DOING) of OPTIONSTATE with (QUOTE YES))))) (TELNET.WILL (COND ((NEQ (fetch (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE) (QUOTE YES)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE with (QUOTE YES))))) (TELNET.DONT (COND ((NEQ (fetch (TELNET.OPTIONSTATE DOING) of OPTIONSTATE) (QUOTE NO)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE DOING) of OPTIONSTATE with (QUOTE NO))))) (TELNET.WONT (COND ((NEQ (fetch (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE) (QUOTE NO)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE with (QUOTE NO))))) NIL))) (COND (GO.AHEAD.WITH.COMMAND (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM COMMAND) (BOUT OUTPUTSTREAM OPTION) (FORCEOUTPUT OUTPUTSTREAM) (TCPCHAT.OPTION.TRACE COMMAND OPTION (OR TRACECAPTION (QUOTE SEND)))))))
)

(TCPCHAT.OPTION.INPUT
(LAMBDA (OUTPUTSTREAM COMMAND OPTION) (* ; "Edited 16-Apr-87 13:30 by jrb:") (LET ((OPTIONRECORD (FASSOC OPTION TELNET.OPTIONS))) (COND (OPTIONRECORD (SELECTC COMMAND (TELNET.DO (TCPCHAT.OPTION.TRACE (QUOTE DO) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.DO) of OPTIONRECORD) OPTION)) (TELNET.DONT (TCPCHAT.OPTION.TRACE (QUOTE DONT) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.DONT) of OPTIONRECORD) OPTION)) (TELNET.WILL (TCPCHAT.OPTION.TRACE (QUOTE WILL) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.WILL) of OPTIONRECORD) OPTION)) (TELNET.WONT (TCPCHAT.OPTION.TRACE (QUOTE WONT) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.WONT) of OPTIONRECORD) OPTION)) (TELNET.SB (TCPCHAT.OPTION.TRACE (QUOTE SB) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.SB) of OPTIONRECORD) OPTION)) COMMAND)) (T (TCPCHAT.OPTION.TRACE COMMAND OPTION) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (QUOTE WONT) OPTION)))))
)

(TCPCHAT.OPTION.OUTPUT
(LAMBDA (OUTPUTSTREAM COMMAND OPTION) (* ; "Edited 17-Apr-87 16:34 by jrb:") (LET (CMDNUM) (COND ((NULL COMMAND)) ((SETQ CMDNUM (CDR (FASSOC COMMAND (BQUOTE ((WILL \, TELNET.WILL) (WONT \, TELNET.WONT) (DO \, TELNET.DO) (DONT \, TELNET.DONT)))))) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM CMDNUM OPTION (QUOTE SENDBACK))) (T (APPLY* COMMAND (TCP.OTHER.STREAM OUTPUTSTREAM))))))
)

(TCPCHAT.OPTION.TRACE
(LAMBDA (COMMAND OPTION PREFIX) (* ejs%: "22-Apr-85 16:41") (DECLARE (GLOBALVARS TCPCHAT.TRACEFLG TCPCHAT.TRACEFILE)) (COND (TCPCHAT.TRACEFLG (COND ((SMALLP COMMAND) (SETQ COMMAND (SELECTC COMMAND (TELNET.DO (QUOTE DO)) (TELNET.DONT (QUOTE DONT)) (TELNET.WILL (QUOTE WILL)) (TELNET.WONT (QUOTE WONT)) COMMAND)))) (printout TCPCHAT.TRACEFILE PREFIX ": " COMMAND " ") (PRINTCONSTANT OPTION TELNET.MARKS TCPCHAT.TRACEFILE) (TERPRI TCPCHAT.TRACEFILE))))
)

(TCPCHAT.TERMINAL.TYPE
(LAMBDA (INPUTSTREAM) (* ; "Edited 20-Apr-87 13:42 by jrb:") (LET ((COMMAND)) (SELECTC (\BUFFERED.BIN INPUTSTREAM) (TELNET.SEND (* ; "OK, should be followed by IAC SE") (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS SEND")) (IF (EQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.IAC) THEN (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " IAC")) ELSE (IF TCPCHAT.TRACEFLG THEN (printout " EXPECTED IAC, GOT " COMMAND))) (IF (EQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.SE) THEN (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " SE")) ELSE (IF TCPCHAT.TRACEFLG THEN (printout " EXPECTED SE, GOT " COMMAND))) (IF TCPCHAT.TRACEFLG THEN (TERPRI TCPCHAT.TRACEFILE)) (LET* ((OUTPUTSTREAM (TCP.OTHER.STREAM INPUTSTREAM)) (DISPLAYTYPE (OR (CDR (FASSOC (fetch (CHATDISPLAYTYPE DPYNAME) of (STREAMPROP INPUTSTREAM (QUOTE DISPLAYTYPE))) TCPCHAT.TELNET.TTY.TYPES)) (CDR (FASSOC (fetch (CHATDISPLAYTYPE DPYNAME) of (STREAMPROP OUTPUTSTREAM (QUOTE DISPLAYTYPE))) TCPCHAT.TELNET.TTY.TYPES))))) (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM TELNET.SB) (BOUT OUTPUTSTREAM TELNET.TERMINAL.TYPE) (BOUT OUTPUTSTREAM TELNET.IS) (PRIN1 DISPLAYTYPE OUTPUTSTREAM) (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM TELNET.SE) (FORCEOUTPUT OUTPUTSTREAM) (COND (TCPCHAT.TRACEFLG (printout TCPCHAT.TRACEFILE "SEND(BACK) IAC SB TERMINAL-TYPE IS " DISPLAYTYPE " IAC SE" T))))) (TELNET.IS (* ; "We told them we couldn't handle this - or would have had they asked...") (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS IS, which is an error: rest of command is:" T)) (WHILE (NEQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.SE) DO (IF TCPCHAT.TRACEFLG THEN (PRIN1 (CHARACTER COMMAND) TCPCHAT.TRACEFILE))) (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " SE" T))) (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS " COMMAND ", which is an error" T)))))
)
)

(RPAQQ TCPCHAT.TELNET.TTY.TYPES ((DM2500 . DATAMEDIA-2500)
                                     (VT100 . DEC-VT100)))

(RPAQQ TELNET.OPTIONS
       ((94 WONT WONT DONT DONT)
        (0 WILL WONT NIL DONT)
        (1 WONT WONT DO DO)
        (3 WILL WILL NIL NIL)
        (5 WONT WONT DONT DONT)
        (6 WILL NIL NIL NIL)
        (24 WILL NIL DONT NIL TCPCHAT.TERMINAL.TYPE)))

(RPAQ? TCPCHAT.TRACEFLG )

(RPAQ? TCPCHAT.TRACEFILE )

(FILESLOAD (SYSLOAD)
       TCP CHAT)
(DECLARE%: EVAL@COMPILE DONTCOPY 

(FILESLOAD CHATDECLS)


(RPAQQ TELNET.COMMANDS ((TELNET.SE 240)
                            (TELNET.SB 250)
                            (TELNET.WILL 251)
                            (TELNET.WONT 252)
                            (TELNET.DO 253)
                            (TELNET.DONT 254)
                            (TELNET.IAC 255)
                            (TELNET.SEND 1)
                            (TELNET.IS 0)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ TELNET.SE 240)

(RPAQQ TELNET.SB 250)

(RPAQQ TELNET.WILL 251)

(RPAQQ TELNET.WONT 252)

(RPAQQ TELNET.DO 253)

(RPAQQ TELNET.DONT 254)

(RPAQQ TELNET.IAC 255)

(RPAQQ TELNET.SEND 1)

(RPAQQ TELNET.IS 0)


(CONSTANTS (TELNET.SE 240)
       (TELNET.SB 250)
       (TELNET.WILL 251)
       (TELNET.WONT 252)
       (TELNET.DO 253)
       (TELNET.DONT 254)
       (TELNET.IAC 255)
       (TELNET.SEND 1)
       (TELNET.IS 0))
)

(RPAQQ TELNET.MARKS ((TELNET.BINARY 0)
                         (TELNET.ECHO 1)
                         (TELNET.SUPPRESS.GOAHEAD 3)
                         (TELNET.STATUS 5)
                         (TELNET.TIMING.MARK 6)
                         (TELNET.TERMINAL.TYPE 24)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ TELNET.BINARY 0)

(RPAQQ TELNET.ECHO 1)

(RPAQQ TELNET.SUPPRESS.GOAHEAD 3)

(RPAQQ TELNET.STATUS 5)

(RPAQQ TELNET.TIMING.MARK 6)

(RPAQQ TELNET.TERMINAL.TYPE 24)


(CONSTANTS (TELNET.BINARY 0)
       (TELNET.ECHO 1)
       (TELNET.SUPPRESS.GOAHEAD 3)
       (TELNET.STATUS 5)
       (TELNET.TIMING.MARK 6)
       (TELNET.TERMINAL.TYPE 24))
)

(DECLARE%: EVAL@COMPILE

(RECORD TELNET.OPTION (OPTION ON.DO ON.DONT ON.WILL ON.WONT ON.SB))

(RECORD TELNET.OPTIONSTATE (OPTION WILLING DOING))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS TELNET.MARKS)
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(ADDTOVAR CHAT.PROTOCOLTYPES (TCP . TCPCHAT.HOST.FILTER))

(ADDTOVAR CHAT.PROTOCOL.ABBREVS (N . TCP)
                                    (T . TCP))
)
(PUTPROPS TCPCHAT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1430 8610 (TCPCHAT.BIN 1440 . 1698) (TCPCHAT.HOST.FILTER 1700 . 1857) (
TCPCHAT.NEGOTIATE 1859 . 2027) (TCPCHAT.OPEN 2029 . 3387) (TCPCHAT.OPTION.COMMAND 3389 . 4679) (
TCPCHAT.OPTION.INPUT 4681 . 5785) (TCPCHAT.OPTION.OUTPUT 5787 . 6188) (TCPCHAT.OPTION.TRACE 6190 . 
6667) (TCPCHAT.TERMINAL.TYPE 6669 . 8608)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPCONFIG b/obsolete/tcp/TCPCONFIG
new file mode 100644
index 00000000..257f8dd5
--- /dev/null
+++ b/obsolete/tcp/TCPCONFIG
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP")
(FILECREATED "12-Jun-90 16:11:50" {DSK}<usr>local>lde>lispcore>library>TCPCONFIG.;2 18742  

      changes to%:  (VARS TCPCONFIGCOMS)

      previous date%: "18-Apr-88 21:05:32" {DSK}<usr>local>lde>lispcore>library>TCPCONFIG.;1)


(* ; "
Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPCONFIGCOMS)

(RPAQQ TCPCONFIGCOMS
       ((PROP MAKEFILE-ENVIRONMENT TCPCONFIG)
        (DECLARE%: EVAL@COMPILE DONTCOPY (COMS (RECORDS IPINIT))
               (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS 
                      \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST))
        (COMS (* TCP configuration module)
              (EXPORT (RECORDS IPINIT))
              (INITVARS (\IP.DEFAULT.CONFIGURATION (create IPINIT))
                     (\IPFLG NIL))
              (FILES TCPLLIP)
              (FNS TCP.CONFIGURE TCP.LIMITCHARS \TCPCONFIG.RESETFN \TCPCONFIG.QUITFN 
                   TCP.ALPHA.LIMITCHARS \TCPCONFIG.APPLYFN))))

(PUTPROPS TCPCONFIG MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP"))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK 
                          DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS 
       \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST)
)
)



(* TCP configuration module)

(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK 
                          DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER))
)

(* "END EXPORTED DEFINITIONS")


(RPAQ? \IP.DEFAULT.CONFIGURATION (create IPINIT))

(RPAQ? \IPFLG NIL)

(FILESLOAD TCPLLIP)
(DEFINEQ

(TCP.CONFIGURE
  [LAMBDA NIL
    (DECLARE (GLOBALVARS \IP.DEFAULT.CONFIGURATION)) (* ; "Edited 18-Mar-88 15:41 by bvm")
    (LET* ((CONFIG (OR (AND (INFILEP '{DSK}IP.INIT)
                            (\IP.READ.INIT.FILE '{DSK}IP.INIT))
                       \IP.DEFAULT.CONFIGURATION
                       (create IPINIT)))
           (TCP.FREEMENU
            (FREEMENU `((PROPS FONT (GACHA 12 BOLD))
                        ((PROPS BOX 2)
                         (LABEL " " TYPE DISPLAY)
                         (LABEL "Apply!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.APPLYFN)
                         (LABEL "     " TYPE DISPLAY)
                         (LABEL "Reset!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.RESETFN)
                         (LABEL "     " TYPE DISPLAY)
                         (LABEL "Quit!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.QUITFN)
                         (LABEL " " TYPE DISPLAY))
                        ((LABEL "" TYPE DISPLAY))
                        ((LABEL "      Host Name:" TYPE EDITSTART MESSAGE 
                                "Enter the name of this host" LINKS (EDIT HOST.NAME))
                         (LABEL ,(OR (fetch (IPINIT HOSTNAME) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID HOST.NAME LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL "   Host Address:" TYPE EDITSTART MESSAGE 
                                "Enter the IP address of this host. Format: 13.0.10.5" LINKS
                                (EDIT ADDRESS))
                         (LABEL ,(OR (CAR (fetch (IPINIT LOCAL.ADDRESSES) of CONFIG))
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID ADDRESS LIMITCHARS TCP.LIMITCHARS))
                        ((LABEL "Network Address:" TYPE EDITSTART MESSAGE 
     "Enter the IP address of the local network.  Format: 13.0.0.0  Leave the host address fields 0." 
                                LINKS (EDIT NETWORK.ADDRESS))
                         (LABEL ,(OR (CAAR (fetch (IPINIT LOCAL.NETWORKS) of CONFIG))
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID NETWORK.ADDRESS LIMITCHARS TCP.LIMITCHARS))
                        ((LABEL "    Subnet mask:" TYPE EDITSTART MESSAGE "Enter the subnet mask.  Format: 13.255.252.0  If the bitwise-AND of this address and any destination IP address is not equal to the bitwise-AND of this address and the host's local IP address, the destination IP address will be considered to be on another (sub)network" 
                                LINKS (EDIT SUBNET.MASK))
                         (LABEL ,(OR (CAR (fetch (IPINIT SUBNETMASK) of CONFIG))
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID SUBNET.MASK LIMITCHARS TCP.LIMITCHARS))
                        ((LABEL "Default Gateway:" TYPE EDITSTART MESSAGE 
                      "Enter the IP address of the default gateway for this host.  Format 13.0.10.34" 
                                LINKS (EDIT DEFAULT.GATEWAY))
                         (LABEL ,(OR (fetch (IPINIT DEFAULT.GATEWAY) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID DEFAULT.GATEWAY LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL "   Local Domain:" TYPE EDITSTART MESSAGE 
                                "Enter the name of the Internet domain in which this host resides" 
                                LINKS (EDIT LOCAL.DOMAIN))
                         (LABEL ,(OR (fetch (IPINIT LOCAL.DOMAIN) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID LOCAL.DOMAIN LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL " Domain servers:" TYPE EDITSTART MESSAGE 
              "Enter the IP addresses of the local domain servers.  Format 13.0.10.21 12.0.15.22 ..." 
                                LINKS (EDIT DOMAIN.SERVERS))
                         (LABEL ,(if (fetch (IPINIT DOMAIN.SERVERS) of CONFIG)
                                     then (for ADDRESS in (fetch (IPINIT 
                                                                                       DOMAIN.SERVERS
                                                                                        )
                                                                         of CONFIG)
                                                 bind (STRING _ "")
                                                 do (SETQ STRING (CONCAT STRING ADDRESS " "))
                                                 finally (RETURN (SUBSTRING STRING 1 -2)))
                                   else "") FONT (GACHA 12)
                                TYPE EDIT ID DOMAIN.SERVERS LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL " Hosts.txt file:" TYPE EDITSTART MESSAGE 
 "Enter the name of the Hosts.txt file to be used for translating IP hostnames to IP host addresses." 
                                LINKS (EDIT HOSTS.FILE))
                         (LABEL ,(OR (fetch (IPINIT HTE.FILE) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID HOSTS.FILE LIMITCHARS TCP.ALPHA.LIMITCHARS))) 
                   "TCP Configuration"))
           (REG (WINDOWPROP TCP.FREEMENU 'REGION))
           (WIDTH (fetch (REGION WIDTH) of REG))
           (HEIGHT (fetch (REGION HEIGHT) of REG)))
          (WINDOWPROP TCP.FREEMENU 'MINSIZE (CONS WIDTH HEIGHT))
          (WINDOWPROP TCP.FREEMENU 'MAXSIZE (CONS 65535 HEIGHT))
          (MOVEW TCP.FREEMENU (GETBOXPOSITION WIDTH HEIGHT))
          (OPENW TCP.FREEMENU)
          NIL])

(TCP.LIMITCHARS
  [LAMBDA (ITEM WINDOW CHARACTER)                        (* ; "Edited 20-Jan-88 15:37 by Snow")
          
          (* ;; "allows numbers or periods until a CR then skips to the next item in the menu.")

    (COND
       ((FMEMB CHARACTER '(0 1 2 3 4 5 6 7 8 9 %.))
        T)
       ((EQ (CHARACTER (CHARCODE EOL))
            CHARACTER)
        (FM.SKIPNEXT WINDOW))
       (T NIL])

(\TCPCONFIG.RESETFN
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 18-Jan-88 18:32 by Briggs") (AND (GETPROMPTWINDOW WINDOW) (CLEARW (GETPROMPTWINDOW WINDOW))) (FM.RESETMENU WINDOW))
)

(\TCPCONFIG.QUITFN
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 18-Jan-88 15:40 by Briggs") (FM.ENDEDIT WINDOW) (CLOSEW WINDOW))
)

(TCP.ALPHA.LIMITCHARS
  [LAMBDA (ITEM WINDOW CHAR)                             (* ; "Edited 20-Jan-88 15:32 by Snow")
          
          (* ;; "This function will allow all characters until a CR then call Fm.Skipnext to move on to the next entry in the table.")

    (IF (EQ (CHARACTER (CHARCODE CR))
                CHAR)
        THEN (FM.SKIPNEXT WINDOW)
      ELSE T])

(\TCPCONFIG.APPLYFN
  [LAMBDA (ITEM WINDOW BUTTONS)                          (* ; "Edited 18-Mar-88 18:37 by bvm")
          (* ;; "Before reseting any of the parameters, verify their validity")

    (FM.ENDEDIT WINDOW)
    (PROG ((STATE (FM.GETSTATE WINDOW))
           (FMPROMPTWINDOW (GETPROMPTWINDOW WINDOW 3))
           (CONFIG (create IPINIT
                          LOCAL.NSHOSTNUMBER _ \MY.NSHOSTNUMBER))
           IPADDRESS SCRATCH)
          (* ;; "Before reseting any of the parameters, verify their validity")

          (CLEARW FMPROMPTWINDOW)
          (* ;; "So we don't have to check later...")

          (if (NOT (OR \10MBLOCALNDB \3MBLOCALNDB))
              then (printout FMPROMPTWINDOW "This machine doesn't appear to be on any networks!")
                    (RETURN))
          (* ;; "")
          (* ;; "Host name is required")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'HOST.NAME))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Host name is required!")
                    (FM.EDITITEM (FM.GETITEM 'HOST.NAME NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT HOSTNAME) of CONFIG with SCRATCH)
          (* ;; "")
          (* ;; " Verify host address")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'ADDRESS))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Host address is required!")
                    (FM.EDITITEM (FM.GETITEM 'ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN)
            elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
                           (ZEROP (\IPNETADDRESS IPADDRESS)))
              then (printout FMPROMPTWINDOW "Malformed host address: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT LOCAL.ADDRESSES) of CONFIG with (LIST (\IP.ADDRESS.TO.STRING
                                                                              IPADDRESS)))
          (* ;; "")
          (* ;; "Verify network address.  The list is an alist keyed by network address, and containing the atom 10 or 3 indicating the kind of network.  We assume the host is only on one network.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'NETWORK.ADDRESS))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Network address is required!")
                    (FM.EDITITEM (FM.GETITEM 'NETWORK.ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN)
            elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
                           (ZEROP (\IPNETADDRESS IPADDRESS)))
              then (printout FMPROMPTWINDOW "Malformed network address: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'NETWORK.ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN))
          [replace (IPINIT LOCAL.NETWORKS) of CONFIG
             with (LIST (CONS (\IP.ADDRESS.TO.STRING IPADDRESS)
                                  (if \10MBLOCALNDB
                                      then 10
                                    else 3]
          (* ;; "")
          (* ;; " Verify subnet mask")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'SUBNET.MASK))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Subnet mask is required!")
                    (FM.EDITITEM (FM.GETITEM 'SUBNET.MASK NIL WINDOW)
                           WINDOW)
                    (RETURN)
            elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
                           (ZEROP (\IPNETADDRESS IPADDRESS)))
              then (printout FMPROMPTWINDOW "Malformed subnet mask: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'SUBNET.MASK NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT SUBNETMASK) of CONFIG with (LIST (\IP.ADDRESS.TO.STRING 
                                                                               IPADDRESS)))
          (* ;; "")
          (* ;; "Verify default gateway, may be empty if none.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'DEFAULT.GATEWAY))
          (if (STRING-EQUAL SCRATCH "")
              then (SETQ IPADDRESS NIL)
            elseif (NOT (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
              then (printout FMPROMPTWINDOW "Malformed default gateway address: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'DEFAULT.GATEWAY NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT DEFAULT.GATEWAY) of CONFIG with (AND IPADDRESS (
                                                                                \IP.ADDRESS.TO.STRING
                                                                                       IPADDRESS)))
          (* ;; "")
          (* ;; "Local domain.  May be empty.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'LOCAL.DOMAIN))
          (if (STRING-EQUAL SCRATCH "")
              then (SETQ SCRATCH NIL))
          (replace (IPINIT LOCAL.DOMAIN) of CONFIG with SCRATCH)
          (* ;; "")
          (* ;; "Verify domain server address(es) are well formed.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'DOMAIN.SERVERS))
          (if (STRING-EQUAL SCRATCH "")
              then (SETQ IPADDRESS NIL)
            else [SETQ IPADDRESS (bind (END _ 0)
                                            (BITTABLE _ (MAKEBITTABLE (LIST (CHARCODE SPACE))
                                                               T))
                                            (START _ NIL)
                                        eachtime [SETQ START (STRPOSL BITTABLE SCRATCH
                                                                        (ADD1 (OR END 65534]
                                              (SETQ END (STRPOS " " SCRATCH START))
                                        until (NULL START)
                                        collect (\IP.READ.STRING.ADDRESS (SUBSTRING SCRATCH
                                                                                    (OR START 1)
                                                                                    END]
                  (if (FMEMB NIL IPADDRESS)
                      then (printout FMPROMPTWINDOW "Malformed domain server addresses: " SCRATCH
                                      )
                            (FM.EDITITEM (FM.GETITEM 'DOMAIN.SERVERS NIL WINDOW)
                                   WINDOW)
                            (RETURN)))
          [replace (IPINIT DOMAIN.SERVERS) of CONFIG with
                                                             (AND IPADDRESS
                                                                  (for ADDR in IPADDRESS
                                                                     collect (
                                                                                \IP.ADDRESS.TO.STRING
                                                                                  ADDR]
          (* ;; "")
          (* ;; "Hosts.txt file (may not yet exist)")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'HOSTS.FILE))
          (if (if (NOT (STRING-EQUAL SCRATCH ""))
                    elseif (NOT *IP-DEFAULT-HOSTS-FILE*)
                      then                               (* ; 
                               "If there's a site default, we can leave this empty for flexibility")
                            (FM.CHANGESTATE (FM.GETITEM 'HOSTS.FILE NIL WINDOW)
                                   (SETQ SCRATCH "{DSK}HOSTS.TXT")
                                   WINDOW)
                            T)
              then (replace (IPINIT HTE.FILE) of CONFIG with SCRATCH))
          (* ;; "")
          (* ;; "write the information back on the IP.INIT file")
          (* ;; "")

          (printout FMPROMPTWINDOW "Writing {dsk}ip.init... ")
          [LET ((*UPPER-CASE-FILE-NAMES* NIL))
               (CL:WITH-OPEN-FILE (STREAM '{DSK}IP.INIT :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
                      (PRIN2 CONFIG STREAM (FIND-READTABLE "INTERLISP"]
          (printout FMPROMPTWINDOW "done.")
          (* ;; "")
          (* ;; "See if they want to restart TCP with the new configuration.")
          (* ;; "")

          (COND
             ((AND \IPFLG (MOUSECONFIRM "Restart TCP with the new values?" NIL FMPROMPTWINDOW T))
                                                             (* ; 
                                                       "tcp is running and they want it restarted.")
              (PRINTOUT FMPROMPTWINDOW T "Restarting...")
              (STOPIP)
              (SETQ \IP.DEFAULT.CONFIGURATION NIL)
              (\IPINIT)
          (* ;; "let the user know we are done.")

              (PRINTOUT FMPROMPTWINDOW "done."])
)
(PUTPROPS TCPCONFIG COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2032 18633 (TCP.CONFIGURE 2042 . 7956) (TCP.LIMITCHARS 7958 . 8375) (\TCPCONFIG.RESETFN
 8377 . 8561) (\TCPCONFIG.QUITFN 8563 . 8695) (TCP.ALPHA.LIMITCHARS 8697 . 9098) (\TCPCONFIG.APPLYFN 
9100 . 18631)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPDEBUG b/obsolete/tcp/TCPDEBUG
new file mode 100644
index 00000000..1b0b73dd
--- /dev/null
+++ b/obsolete/tcp/TCPDEBUG
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-Aug-90 17:10:14" {DSK}<LISPFILES>TCP>TCPDEBUG.;2 27328  

      changes to%:  (VARS TCPDEBUGCOMS)

      previous date%: "15-Feb-89 13:41:39" {DSK}<LISPFILES>TCP>TCPDEBUG.;1)


(* ; "
Copyright (c) 1985, 1986, 1987, 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPDEBUGCOMS)

(RPAQQ TCPDEBUGCOMS ((COMS 
                               (* ;; "standard TCP small servers")

                               (FNS TCP.SINK.SERVER TCP.TELNET.SERVER \TCP.SINK.PROCESS 
                                    TCP.ECHO.SERVER \TCP.ECHO.PROCESS))
                         (COMS 
                               (* ;; "TCP tracing and debugging info")

                               (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                                       TCP)
                                      (CONSTANTS LIGHTGRAYSHADE))
                               (GLOBALVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME 
                                      \TCP.DEBUGGABLE)
                               (INITVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME 
                                      NETTRACETITLEREG)
                               (VARS (\TCP.DEBUGGABLE T))
                               (BITMAPS NETTRACEICON NETTRACEMASK)
                               (FILES (SYSLOAD)
                                      TCP)
                               (FNS TCP.PRINT.SEGMENT \TCP.PRINT.OPTIONS \TCP.PRINT.ELAPSED.TIME 
                                    \TCP.PRINT.SEGMENT.QUEUE TCPTRACE \TCPTRACEMENU.ITEMFN 
                                    \TCPTRACEMENU.DISPLAYFN TCP.DRIBBLE))
                         (COMS 
                               (* ;; "miscellaneous TCP debugging")

                               (GLOBALVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT 
                                      \TCP.MASTER.SOCKET)
                               (INITVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT)
                               (FNS TCP.DEBUG TCP.WATCHER DUMMY\IP\Transmit\Packet 
                                    \TCP.CHECK.INPUT.QUEUE TCP.FAUCET TCP.ECHOTEST TCP.QUIET.ECHOTEST
                                    TCP.SINKTEST GENERATE.RANDOM.CHARS COPYBYTESTREAM 
                                    TCP.COPYTOWINDOW TEST.CHECKSUM))))



(* ;; "standard TCP small servers")

(DEFINEQ

(TCP.SINK.SERVER
  [LAMBDA (PORT)                                             (* ecc "14-May-84 16:32")
    (bind STREAM do (if (SETQ STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT)
                                            'PASSIVE
                                            'INPUT T))
                        then (ADD.PROCESS `(\TCP.SINK.PROCESS %, STREAM) 'NAME "TCP Sink"])

(TCP.TELNET.SERVER
  [LAMBDA NIL                                                (* ejs%: "20-Jun-85 12:38")
    (LET ((INSTREAM (TCP.OPEN NIL NIL \TCP.TELNET.PORT 'PASSIVE 'INPUT))
          OUTSTREAM)
         (COND
            (INSTREAM (SETQ OUTSTREAM (TCP.OTHER.STREAM INSTREAM))
                   (ADD.PROCESS (LIST '\TCP.ECHO.PROCESS (KWOTE INSTREAM)
                                      (KWOTE OUTSTREAM))
                          'NAME "Telnet echo")
                   (ADD.PROCESS '(TCP.TELNET.SERVER))
                   (GENERATE.RANDOM.CHARS OUTSTREAM])

(\TCP.SINK.PROCESS
  [LAMBDA (STREAM)                                           (* ejs%: " 7-Jun-85 13:11")
    (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                         STREAM))
    (replace (STREAM ENDOFSTREAMOP) of STREAM with (FUNCTION NILL))
    (until (EOFP STREAM) do (BIN STREAM])

(TCP.ECHO.SERVER
  [LAMBDA (PORT)                                             (* ecc "14-May-84 16:35")
    (bind STREAM do (if (SETQ STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.ECHO.PORT)
                                            'PASSIVE
                                            'INPUT T))
                        then (ADD.PROCESS `(\TCP.ECHO.PROCESS %, STREAM %, (TCP.OTHER.STREAM STREAM))
                                    'NAME "TCP Echo"])

(\TCP.ECHO.PROCESS
  [LAMBDA (INSTR OUTSTR)                                     (* ejs%: "25-Mar-86 18:07")
    (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                         INSTR))
    (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                         OUTSTR))
    (bind C until (OR (NOT (OPENP INSTR 'INPUT))
                      (EOFP INSTR)) do [COND
                                          [(CAR (NLSETQ (READP INSTR)))
                                           (SETQ C (CAR (NLSETQ (BIN INSTR]
                                          (T (FORCEOUTPUT OUTSTR)
                                             (SETQ C (CAR (NLSETQ (BIN INSTR]
                                       [COND
                                          (C (NLSETQ (BOUT OUTSTR C]
                                       (if (OR (NOT (NLSETQ (READP INSTR)))
                                               (NOT (OPENP INSTR 'INPUT))
                                               (EOFP INSTR))
                                           then (NLSETQ (FORCEOUTPUT OUTSTR])
)



(* ;; "TCP tracing and debugging info")

(DECLARE%: EVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       TCP)

(DECLARE%: EVAL@COMPILE 

(RPAQQ LIGHTGRAYSHADE 1025)


(CONSTANTS LIGHTGRAYSHADE)
)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME \TCP.DEBUGGABLE)
)

(RPAQ? TCPTRACEFLG NIL)

(RPAQ? TCPTRACEFILE NIL)

(RPAQ? TCPTRACEMENU NIL)

(RPAQ? \TCP.ELAPSED.TIME NIL)

(RPAQ? NETTRACETITLEREG NIL)

(RPAQQ \TCP.DEBUGGABLE T)

(RPAQQ NETTRACEICON #*(72 72)AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@G@@@@@@@@@@@@@@@G@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@G@@@@@@@@@@@@@@@G@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@@@@@L@@@@@L@@@@@F@@@@@@@L@@@@@N@@@@@F@@@@@@@L@@@@@K@@@@@GH@@@@@CLCOOOOIH@@@@F@@@@@@@LGOOOOHL@@@@F@@@@@@@LD@@@@@F@@@@F@@@@@@@LD@@@@@C@@@@GOOOOOOOLD@@@@@A@@@@F@@@@@@@LD@@@@@B@@@@F@@@@@@@LD@@@@@D@@@@F@@@@@@@LGOOOOHH@@@@GH@@@@@CL@@@@@I@@@@@F@@@@@@@L@@@@@J@@@@@F@@@@@@@L@@@@@L@@@@@F@@@@@@@L@@@@@H@@@@@GH@@@@@CL@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@D@@@@@@@@F@@@@@@@L@@L@@@@@@@@F@@@@@@@L@AL@@@@@@@@F@@@@@@@L@BL@@@@@@@@GH@@@@@CL@DOOOOOH@@@F@@@@@@@L@HOOOOOH@@@F@@@@@@@LA@@@@@AH@@@F@@@@@@@LB@@@@@AH@@@GOOOOOOOLD@@@@@AH@@@F@@@@@@@LB@@@@@AH@@@F@@@D@@@LA@@@@@AH@@@F@@@D@@@L@HOOOOO@@@@F@@@@@@@L@DL@@@@@@@@F@@@D@@@L@BL@@@@@@@@F@@@D@@@L@AL@@@@@@@@F@@@@@@@L@@H@@@@@@@@F@@@D@@@L@@@@@@@@@@@F@@@D@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@
)

(RPAQQ NETTRACEMASK #*(72 72)AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@L@@@@@GOOOOOOOL@@@@@N@@@@@GOOOOOOOL@@@@@O@@@@@GOOOOOOOLCOOOOOH@@@@GOOOOOOOLGOOOOOL@@@@GOOOOOOOLGOOOOON@@@@GOOOOOOOLGOOOOOO@@@@GOOOOOOOLGOOOOOO@@@@GOOOOOOOLGOOOOON@@@@GOOOOOOOLGOOOOOL@@@@GOOOOOOOLGOOOOOH@@@@GOOOOOOOL@@@@@O@@@@@GOOOOOOOL@@@@@N@@@@@GOOOOOOOL@@@@@L@@@@@GOOOOOOOL@@@@@H@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@D@@@@@@@@GOOOOOOOL@@L@@@@@@@@GOOOOOOOL@AL@@@@@@@@GOOOOOOOL@CL@@@@@@@@GOOOOOOOL@GOOOOOH@@@GOOOOOOOL@OOOOOOH@@@GOOOOOOOLAOOOOOOH@@@GOOOOOOOLCOOOOOOH@@@GOOOOOOOLGOOOOOOH@@@GOOOOOOOLCOOOOOOH@@@GOOOOOOOLAOOOOOOH@@@GOOOOOOOL@OOOOOO@@@@GOOOOOOOL@GL@@@@@@@@GOOOOOOOL@CL@@@@@@@@GOOOOOOOL@AL@@@@@@@@GOOOOOOOL@@H@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@
)

(FILESLOAD (SYSLOAD)
       TCP)
(DEFINEQ

(TCP.PRINT.SEGMENT
  [LAMBDA (SEGMENT FILE NOFROMTOFLG DATAFLG)                 (* ejs%: "20-Jun-85 16:06")
    (PROG ((SEPR "")
           (COMMA ",")
           (SEQ (fetch TCP.SEQ of SEGMENT))
           (LEN (\TCP.DATA.LENGTH SEGMENT))
           (FLAGS (fetch TCP.CTRL of SEGMENT))
           TOP BASE)
          (if (NOT NOFROMTOFLG)
              then (printout FILE "from " %# (\IP.PRINT.ADDRESS (fetch TCP.SRC.ADDR of SEGMENT)
                                                    FILE)
                          ":"
                          (fetch TCP.SRC.PORT of SEGMENT)
                          " to " %# (\IP.PRINT.ADDRESS (fetch TCP.DST.ADDR of SEGMENT)
                                           FILE)
                          ":"
                          (fetch TCP.DST.PORT of SEGMENT)
                          T))
          (printout FILE SEQ)
          [SETQ TOP (SUB1 (IPLUS SEQ LEN (\TCP.SYN.OR.FIN FLAGS T]
          (if (\32BIT.LT SEQ TOP)
              then (printout FILE ".." TOP))
          (printout FILE "/" (fetch TCP.ACK of SEGMENT)
                 " [")
          (if (BITTEST FLAGS \TCP.CTRL.URG)
              then (printout FILE SEPR "URG")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.ACK)
              then (printout FILE SEPR "ACK")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.PSH)
              then (printout FILE SEPR "PSH")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.RST)
              then (printout FILE SEPR "RST")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.SYN)
              then (printout FILE SEPR "SYN")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.FIN)
              then (printout FILE SEPR "FIN")
                   (SETQ SEPR COMMA))
          (printout FILE "] window = " (fetch TCP.WINDOW of SEGMENT)
                 " checksum = "
                 (fetch TCP.CHECKSUM of SEGMENT)
                 " length = " LEN T)
          (if (IGREATERP (fetch TCP.DATA.OFFSET of SEGMENT)
                     \TCP.MIN.DATA.OFFSET)
              then (\TCP.PRINT.OPTIONS SEGMENT FILE))
          (if (AND DATAFLG (NOT (ZEROP LEN)))
              then (printout FILE "Contents:")
                   (SETQ BASE (fetch TCP.CONTENTS of SEGMENT))
                   (for (I _ 0) to (SUB1 LEN) do (PRIN1 (CHARACTER (\GETBASEBYTE BASE I))
                                                        FILE))
                   (TERPRI FILE])

(\TCP.PRINT.OPTIONS
  [LAMBDA (SEGMENT FILE)                                     (* ejs%: "20-Jun-85 13:22")
          
          (* * Process the options in a TCP header)

    (printout FILE "Options: ")
    (bind (OPTIONBASE _ (fetch (TCPSEGMENT TCP.OPTIONS) of SEGMENT))
          (OPTIONOFFSET _ 0)
          OPTION eachtime (SETQ OPTION (\GETBASEBYTE OPTIONBASE OPTIONOFFSET))
       until (EQ OPTION \TCPOPT.END)
       do (SELECTC OPTION
              (\TCPOPT.END (printout FILE "end")
                           (add OPTIONOFFSET 1))
              (\TCPOPT.NOP (printout FILE "nop")
                           (add OPTIONOFFSET 1))
              (\TCPOPT.MAXSEG 
                   [printout FILE "maxseg: " (LOGOR (LLSH (\GETBASEBYTE OPTIONBASE (IPLUS 
                                                                                         OPTIONOFFSET 
                                                                                          2))
                                                          BITSPERBYTE)
                                                    (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 3]
                   (add OPTIONOFFSET (\GETBASEBYTE OPTIONBASE (ADD1 OPTIONOFFSET))))
              (RETURN))
          (printout FILE " "])

(\TCP.PRINT.ELAPSED.TIME
  [LAMBDA (FILE)                                             (* ecc "23-Apr-84 12:32")
    (if (MEMB 'TIME TCPTRACEFLG)
        then (PROG ((NOW (SETUPTIMER 0 NIL 'MILLISECONDS))
                    INTERVAL)
                   (SETQ INTERVAL (IDIFFERENCE NOW (OR \TCP.ELAPSED.TIME NOW)))
                   (SETQ \TCP.ELAPSED.TIME NOW)
                   (printout FILE (IQUOTIENT INTERVAL 1000)
                          "." |.I3..T| (IMOD INTERVAL 1000)
                          " "])

(\TCP.PRINT.SEGMENT.QUEUE
  [LAMBDA (CALLER QUEUE FILE)                                (* ecc "18-Apr-84 14:38")
    (PROG ((SEGMENT (fetch SYSQUEUEHEAD of QUEUE)))
          (printout FILE .TAB0 0 CALLER ":" T)
          (while SEGMENT do (TCP.PRINT.SEGMENT SEGMENT FILE T)
                            (SETQ SEGMENT (fetch QLINK of SEGMENT])

(TCPTRACE
  [LAMBDA NIL                                                (* ; "Edited 15-Apr-87 15:22 by jrb:")
    (PROG (MW)
          (if (WINDOWP TCPTRACEFILE)
              then (TOTOPW TCPTRACEFILE)
                   (RETURN))
          (SETQ TCPTRACEFILE (CREATEW))
          [WINDOWADDPROP TCPTRACEFILE 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
                                                           (if (EQ WINDOW TCPTRACEFILE)
                                                               then (SETQ TCPTRACEFLG NIL)
                                                                    (SETQ TCPTRACEFILE T]
          (DSPFONT (FONTCREATE 'GACHA 8)
                 TCPTRACEFILE)
          (DSPSCROLL T TCPTRACEFILE)
          [if (NOT (type? MENU TCPTRACEMENU))
              then (SETQ TCPTRACEMENU (create MENU
                                             TITLE _ "TCP Trace Window"
                                             ITEMS _ '(("Incoming" RECV "Trace incoming segments")
                                                       ("Time" TIME 
                                                              "Print elapsed time between events")
                                                       ("Transitions" TRANSITION 
                                                              "Trace connection state transitions")
                                                       ("Outgoing" SEND "Trace outgoing segments")
                                                       ("Contents" CONTENTS 
                                                            "Print contents of segments when tracing"
                                                              )
                                                       ("Checksums" CHECKSUM 
                                                              "Trace segments with bad checksums"))
                                             MENUROWS _ 2
                                             CENTERFLG _ T
                                             WHENSELECTEDFN _ (FUNCTION \TCPTRACEMENU.ITEMFN)))
            else (FOR ITEM IN (FETCH (MENU ITEMS) OF TCPTRACEMENU)
                    DO (IF (MEMB (CADR ITEM)
                                 TCPTRACEFLG)
                           THEN (SHADEITEM ITEM TCPTRACEMENU LIGHTGRAYSHADE)
                         ELSE (SHADEITEM ITEM TCPTRACEMENU WHITESHADE]
          (ATTACHMENU TCPTRACEMENU TCPTRACEFILE 'TOP)
          [SETQ MW (CAR (WINDOWPROP TCPTRACEFILE 'ATTACHEDWINDOWS]
          (WINDOWADDPROP MW 'REPAINTFN (FUNCTION \TCPTRACEMENU.DISPLAYFN))
          (WINDOWADDPROP MW 'RESHAPEFN (FUNCTION \TCPTRACEMENU.DISPLAYFN])

(\TCPTRACEMENU.ITEMFN
  [LAMBDA (ITEM MENU MOUSEKEY)                               (* ecc "23-Apr-84 13:37")
    (PROG (FLG)
          (if (NULL ITEM)
              then (RETURN))
          (SETQ FLG (CADR ITEM))
          (if (MEMB FLG TCPTRACEFLG)
              then (SHADEITEM ITEM MENU WHITESHADE)
                   (SETQ TCPTRACEFLG (DREMOVE FLG TCPTRACEFLG))
            else (SHADEITEM ITEM MENU LIGHTGRAYSHADE)
                 (SETQ TCPTRACEFLG (CONS FLG TCPTRACEFLG])

(\TCPTRACEMENU.DISPLAYFN
  [LAMBDA (WINDOW)                                           (* ecc "23-Apr-84 13:49")
    (PROG [(MENU (CAR (WINDOWPROP WINDOW 'MENU]
          (for ITEM in (fetch ITEMS of MENU) when (MEMB (CADR ITEM)
                                                        TCPTRACEFLG)
             do (SHADEITEM ITEM MENU LIGHTGRAYSHADE])

(TCP.DRIBBLE
  [LAMBDA (FORM FILE)                                        (* ecc "18-Apr-84 14:39")
    (if (NULL FILE)
        then (SETQ FILE '{DSK}TCP.Transcript))
    (RESETLST (RESETSAVE TCPTRACEFILE (OPENFILE FILE 'OUTPUT))
           (RESETSAVE TCPTRACEFLG T)
           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                TCPTRACEFILE))
           (PRINT FORM TCPTRACEFILE)
           (TERPRI TCPTRACEFILE)
           (EVAL FORM])
)



(* ;; "miscellaneous TCP debugging")

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT \TCP.MASTER.SOCKET)
)

(RPAQ? \TCP.LOSSAGE NIL)

(RPAQ? \TCP.LOOPBACK.QUEUE NIL)

(RPAQ? \TCP.LOOPBACK.EVENT NIL)
(DEFINEQ

(TCP.DEBUG
  [LAMBDA (ON?)                                              (* edited%: "21-May-84 13:56")
    (if ON?
        then (TCP.STOP)
             (if (NOT (DEFINEDP 'REAL\IP\Transmit\Packet))
                 then (MOVD 'IP\Transmit\Packet 'REAL\IP\Transmit\Packet))
             (MOVD 'DUMMY\IP\Transmit\Packet 'IP\Transmit\Packet)
             (if (NULL \TCP.LOOPBACK.EVENT)
                 then (SETQ \TCP.LOOPBACK.EVENT (CREATE.EVENT)))
             (if (NULL \TCP.LOOPBACK.QUEUE)
                 then (SETQ \TCP.LOOPBACK.QUEUE (create SYSQUEUE)))
             [if (NOT (FIND.PROCESS 'TCP.WATCHER))
                 then (ADD.PROCESS '(TCP.WATCHER]
      else (if (DEFINEDP 'REAL\IP\Transmit\Packet)
               then (MOVD 'REAL\IP\Transmit\Packet 'IP\Transmit\Packet))
           (DEL.PROCESS 'TCP.WATCHER)
           (\TCP.INIT])

(TCP.WATCHER
  [LAMBDA NIL                                                (* ecc " 3-May-84 11:10")
                                                             (* process to handle software loopback 
                                                             of segments)
    (RESETSAVE NIL (LIST (FUNCTION \FLUSH.PACKET.QUEUE)
                         \TCP.LOOPBACK.QUEUE))
    (bind SEGMENT do (SETQ SEGMENT (\DEQUEUE \TCP.LOOPBACK.QUEUE))
                     (if SEGMENT
                         then (\TCP.PACKET.FILTER SEGMENT \TCP.PROTOCOL)
                       else (AWAIT.EVENT \TCP.LOOPBACK.EVENT])

(DUMMY\IP\Transmit\Packet
  [LAMBDA (EPKT)                                             (* ejs%: " 5-Jan-85 16:57")
                                                             (* Software loopback.)
    (PROG ([OK (NOT (AND \TCP.LOSSAGE (EQ (RAND 1 \TCP.LOSSAGE)
                                          1]
           SEGMENT)
          (CHECK (OR (NULL (fetch QLINK of EPKT))
                     (SHOULDNT "transmitting queued segment")))
          (if OK
              then (SETQ SEGMENT (\ALLOCATE.ETHERPACKET))
                   (\BLT (\IPDATABASE SEGMENT)
                         (\IPDATABASE EPKT)
                         (FOLDHI (ADD1 (fetch (IP IPTOTALLENGTH) of EPKT))
                                BYTESPERWORD)))
          (if (EQ (fetch EPREQUEUE of EPKT)
                  'FREE)
              then (\RELEASE.ETHERPACKET EPKT)
            elseif (type? SYSQUEUE (fetch EPREQUEUE of EPKT))
              then (\ENQUEUE (fetch EPREQUEUE of EPKT)
                          EPKT))
          (if OK
              then (\ENQUEUE \TCP.LOOPBACK.QUEUE SEGMENT)
                   (NOTIFY.EVENT \TCP.LOOPBACK.EVENT])

(\TCP.CHECK.INPUT.QUEUE
  [LAMBDA (TCB)                                              (* edited%: "22-May-84 15:32")
                                                             (* perform consistency check on the 
                                                             input queue)
    (PROG ((QUEUE (fetch TCB.INPUT.QUEUE of TCB))
           CURSEG SEQ1 TOP1 NEXTSEG SEQ2 TOP2)
          (SETQ CURSEG (fetch SYSQUEUEHEAD of QUEUE))
      LOOP
          (if (NULL CURSEG)
              then (RETURN T))
          (SETQ SEQ1 (fetch TCP.SEQ of CURSEG))
          (SETQ TOP1 (IPLUS SEQ1 (fetch TCP.DATA.LENGTH of CURSEG)))
          (if (AND (\32BIT.LEQ SEQ1 (fetch TCB.RCV.NXT of TCB))
                   (\32BIT.GT TOP1 (fetch TCB.RCV.NXT of TCB)))
              then (SHOULDNT "incorrect RCV.NXT")
                   (RETURN NIL))
          (SETQ NEXTSEG (fetch QLINK of CURSEG))
          (if (NULL NEXTSEG)
              then (RETURN T))
          (SETQ SEQ2 (fetch TCP.SEQ of NEXTSEG))
          (SETQ TOP2 (IPLUS SEQ2 (fetch TCP.DATA.LENGTH of NEXTSEG)))
          (if (\32BIT.LT SEQ2 SEQ1)
              then (SHOULDNT "input queue out of order")
                   (RETURN NIL))
          (SETQ CURSEG NEXTSEG)
          (GO LOOP])

(TCP.FAUCET
  [LAMBDA (HOST PORT NLINES)                                 (* ejs%: "20-Jun-85 12:20")
    (PROG [(STREAM (if HOST
                       then (TCP.OPEN HOST (OR PORT \TCP.SINK.PORT)
                                   NIL
                                   'ACTIVE
                                   'OUTPUT)
                     else (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT)
                                 'PASSIVE
                                 'OUTPUT]
          (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                                         STREAM))
                 (GENERATE.RANDOM.CHARS STREAM NLINES])

(TCP.ECHOTEST
  [LAMBDA (HOST NLINES)                                      (* ecc "14-May-84 17:07")
    (PROG [(STREAM (TCP.OPEN HOST \TCP.ECHO.PORT NIL 'ACTIVE 'OUTPUT]
          (ADD.PROCESS (BQUOTE (TCP.COPYTOWINDOW %, (TCP.OTHER.STREAM STREAM))
                              'NAME "TCP Echo Tester"))
          (GENERATE.RANDOM.CHARS STREAM NLINES)
          (TCP.CLOSE.SENDER STREAM])

(TCP.QUIET.ECHOTEST
  [LAMBDA (HOST NLINES)                                      (* ecc "25-May-84 13:24")
    (PROG [(STREAM (TCP.OPEN HOST \TCP.ECHO.PORT NIL 'ACTIVE 'OUTPUT]
          (ADD.PROCESS (BQUOTE (\TCP.SINK.PROCESS %, (TCP.OTHER.STREAM STREAM))
                              'NAME "TCP Echo Tester"))
          (GENERATE.RANDOM.CHARS STREAM NLINES)
          (TCP.CLOSE.SENDER STREAM])

(TCP.SINKTEST
  [LAMBDA (PORT VISIBLEFLG)                                  (* ecc "14-May-84 17:28")
    (TCP.COPYTOWINDOW (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT)
                             'PASSIVE
                             'INPUT)
           VISIBLEFLG])

(GENERATE.RANDOM.CHARS
  [LAMBDA (STREAM NLINES)                                    (* ejs%: " 7-Jun-85 12:34")
    (bind (N _ 0) while (NEQ N NLINES) do (add N 1)
                                          (printout STREAM "This is byte number " (GETFILEPTR STREAM)
                                                 "." T)
                                          (BLOCK])

(COPYBYTESTREAM
  [LAMBDA (INSTR OUTSTR VISIBLEFLG)                          (* ejs%: " 7-Jun-85 13:44")
    (if VISIBLEFLG
        then (bind (N _ 1)
                   (C _ NIL) while (OPENP INSTR 'INPUT)
                do (SETQ C (BIN INSTR))
                   (printout OUTSTR N ": " C)
                   (if (AND (ILEQ C 127)
                            (IGEQ C 32))
                       then (printout OUTSTR " (" %# (BOUT OUTSTR C)
                                   ")"))
                   (TERPRI OUTSTR)
                   (add N 1))
      else (bind C while (AND (OPENP INSTR 'INPUT)
                              (NOT (EOFP INSTR))) do (COND
                                                        ((SETQ C (BIN INSTR))
                                                         (BOUT OUTSTR C])

(TCP.COPYTOWINDOW
  [LAMBDA (STREAM VISIBLEFLG)                                (* ejs%: "13-Apr-85 16:01")
    (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                   STREAM))
           (PROG ((WIN (CREATEW NIL "Stream Output")))
                 (DSPSCROLL T WIN)
                 (COPYBYTESTREAM STREAM WIN VISIBLEFLG)
                 (printout WIN .TAB0 0 "[End of stream]"])

(TEST.CHECKSUM
  [LAMBDA (STR STR2)                                         (* ecc "24-Apr-84 13:11")
    (if (NULL STR2)
        then (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE) of STR)
                                       (fetch (STRINGP OFFST) of STR))
                    (fetch (STRINGP LENGTH) of STR))
      else (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE)
                                                                              of STR)
                                                                        (fetch (STRINGP OFFST)
                                                                           of STR))
                                                     (fetch (STRINGP LENGTH) of STR)
                                                     T)
                                     (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE) of STR2)
                                                               (fetch (STRINGP OFFST) of STR2))
                                            (fetch (STRINGP LENGTH) of STR2)
                                            T])
)
(PUTPROPS TCPDEBUG COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2530 5441 (TCP.SINK.SERVER 2540 . 2955) (TCP.TELNET.SERVER 2957 . 3546) (
\TCP.SINK.PROCESS 3548 . 3874) (TCP.ECHO.SERVER 3876 . 4356) (\TCP.ECHO.PROCESS 4358 . 5439)) (8951 
18060 (TCP.PRINT.SEGMENT 8961 . 11702) (\TCP.PRINT.OPTIONS 11704 . 13026) (\TCP.PRINT.ELAPSED.TIME 
13028 . 13561) (\TCP.PRINT.SEGMENT.QUEUE 13563 . 13945) (TCPTRACE 13947 . 16678) (\TCPTRACEMENU.ITEMFN
 16680 . 17190) (\TCPTRACEMENU.DISPLAYFN 17192 . 17578) (TCP.DRIBBLE 17580 . 18058)) (18333 27228 (
TCP.DEBUG 18343 . 19261) (TCP.WATCHER 19263 . 19916) (DUMMY\IP\Transmit\Packet 19918 . 21136) (
\TCP.CHECK.INPUT.QUEUE 21138 . 22505) (TCP.FAUCET 22507 . 23175) (TCP.ECHOTEST 23177 . 23587) (
TCP.QUIET.ECHOTEST 23589 . 24006) (TCP.SINKTEST 24008 . 24288) (GENERATE.RANDOM.CHARS 24290 . 24690) (
COPYBYTESTREAM 24692 . 25563) (TCP.COPYTOWINDOW 25565 . 25990) (TEST.CHECKSUM 25992 . 27226)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPDOMAIN b/obsolete/tcp/TCPDOMAIN
new file mode 100644
index 00000000..1e9b8354
--- /dev/null
+++ b/obsolete/tcp/TCPDOMAIN
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 16:18:18" {DSK}<usr>local>lde>lispcore>library>TCPDOMAIN.;3 66928  

      changes to%:  (VARS TCPDOMAINCOMS)

      previous date%: "28-Feb-89 18:35:51" {DSK}<usr>local>lde>lispcore>library>TCPDOMAIN.;2)


(* ; "
Copyright (c) 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPDOMAINCOMS)

(RPAQQ TCPDOMAINCOMS
       ((COMS 
              (* ;; "TCP/IP Domain resolver implementation.  RFC882, RFC883, RFC973")
)
        (COMS 
              (* ;; "UDP protocol functions")

              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS (\UDPDOMAIN.WDS 6))
                                         (RECORDS DOMAIN.HEADER)))
              (INITVARS (\UDPDOMAIN.IPSOCKET))
              (GLOBALVARS \UDPDOMAIN.IPSOCKET)
              (FILES (SYSLOAD)
                     TCPUDP)
              (FNS \UDPDOM.PROCESS.RESPONSE \UDPDOM.QUERY \UDPDOM.IPSOCKET))
        (COMS 
              (* ;; "Protocol independent functions")

              [DECLARE%: DONTCOPY (EXPORT (CONSTANTS * DOMAIN.OPCODES)
                                         (CONSTANTS * DOMAIN.RCODES)
                                         (CONSTANTS * DOMAIN.RRTYPES)
                                         (CONSTANTS * DOMAIN.CLASSTYPES)
                                         (CONSTANTS (\DOMAIN.PORT 53]
              (INITVARS (\DOMAIN.DEFAULT.SERVER))
              (GLOBALVARS \DOMAIN.DEFAULT.SERVER)
              (FNS \DOMAIN.NAME \DOMAIN.PACK.NAME.LIST \DOMAIN.PARSE.NAME \DOMAIN.RCODE.ERROR 
                   \DOMAIN.PROCESS.REDIRECT \DOMAIN.PROCESS.RESPONSE \DOMAIN.PROCESS.RR 
                   \DOMAIN.READ.ADDRESS \DOMAIN.READ.NAME.FROM.STREAM \DOMAIN.READ.STRING.FROM.STREAM
                   \DOMAIN.SEARCH.FOR.CANONICAL.NAME \DOMAIN.SKIP.NAME.IN.STREAM 
                   \DOMAIN.SKIP.QUESTION \DOMAIN.SKIP.RR))
        (COMS 
              (* ;; "Functions to maintain the domain tree structure")

              (RECORDS DOMAIN.TREE.NODE DOMAIN.SERVER)
              (INITRECORDS DOMAIN.TREE.NODE)
              (FNS USTRINGHASHBITS)
              (INITVARS (\DOMAIN.ROOT (create DOMAIN.TREE.NODE NAME _ ""))
                     (\DOMAIN.NAMESERVERS (HASHARRAY 50 1.2 (FUNCTION USTRINGHASHBITS)
                                                 (FUNCTION STRING-EQUAL)))
                     (\DOMAIN.UNKNOWN.DOMAINS)
                     (\DOMAIN.GC.INTERVAL 600000)
                     (\DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL)))
              (GLOBALVARS \DOMAIN.ROOT \DOMAIN.NAMESERVERS \DOMAIN.UNKNOWN.DOMAINS \DOMAIN.GC.TIMER 
                     \DOMAIN.GC.INTERVAL)
              (FNS \DOMAIN.ADD.NEW.DOMAIN \DOMAIN.ADD.NAMESERVER \DOMAIN.AUGMENT.TREE 
                   \DOMAIN.CHOOSE.BEST.SERVERS \DOMAIN.FIND.DOMAIN.IN.TREE \DOMAIN.INIT 
                   \DOMAIN.INSERT.IN.TREE \DOMAIN.PATH \DOMAIN.SEARCH.RESOURCE.LIST 
                   \DOMAIN.DELETE.NAMESERVER \DOMAIN.AROUND.EXIT \DOMAIN.DELETE.TREE 
                   \DOMAIN.BACKGROUND \DOMAIN.GC.NAMESERVERS \DOMAIN.SORT.BY.SVC.TIME)
              (ADDVARS (BACKGROUNDFNS \DOMAIN.BACKGROUND)))
        (COMS 
              (* ;; "Programmer's interface")

              (INITVARS (DOMAIN.TRACE.FLG)
                     (DOMAIN.TRACE.FILE)
                     (INTERNET.LOCAL.DOMAIN))
              (GLOBALVARS DOMAIN.TRACE.FLG DOMAIN.TRACE.FILE INTERNET.LOCAL.DOMAIN)
              (FNS DOMAIN.INIT DOMAIN.LOOKUP.ADDRESS DOMAIN.LOOKUP.NAMESERVER DOMAIN.LOOKUP.OSTYPE 
                   DOMAIN.LOOKUP DOMAIN.GRAPH DOMAIN.NAME.EQUAL DOMAIN.TRACE 
                   DOMAIN.TRACEWINDOW.BUTTONFN))
        (P (DOMAIN.INIT))))



(* ;; "TCP/IP Domain resolver implementation.  RFC882, RFC883, RFC973")




(* ;; "UDP protocol functions")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \UDPDOMAIN.WDS 6)


(CONSTANTS (\UDPDOMAIN.WDS 6))
)
(DECLARE%: EVAL@COMPILE

(BLOCKRECORD DOMAIN.HEADER ((ID WORD)
                                (RESPONSEFLG FLAG)
                                (OPCODE BITS 4)
                                (AUTHORITYFLG FLAG)
                                (TRUNCATEDFLG FLAG)
                                (WANTRECURSEFLG FLAG)
                                (CANRECURSEFLG FLAG)
                                (NIL BITS 3)
                                (RESPONSECODE BITS 4)
                                (QDCOUNT WORD)
                                (ANCOUNT WORD)
                                (NSCOUNT WORD)
                                (ARCOUNT WORD)))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \UDPDOMAIN.IPSOCKET )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \UDPDOMAIN.IPSOCKET)
)

(FILESLOAD (SYSLOAD)
       TCPUDP)
(DEFINEQ

(\UDPDOM.PROCESS.RESPONSE
  [LAMBDA (DOMAIN.PATH RESPONSE)                         (* ejs%: " 5-Nov-86 13:38")
          
          (* * This function parses a query reponse packet)

    (LET ((RESPONSEBASE (fetch (UDP UDPCONTENTS) of RESPONSE)))
         (COND
            ((NEQ 0 (fetch (DOMAIN.HEADER ANCOUNT) of RESPONSEBASE))
          
          (* * The response packet has the information we requested)

             (PROG1 (\DOMAIN.PROCESS.RESPONSE (\MAKEBASEBYTESTREAM RESPONSEBASE 0
                                                         (IDIFFERENCE (fetch (UDP UDPLENGTH)
                                                                         of RESPONSE)
                                                                \UDPOVLEN)
                                                         'INPUT))
                    (\RELEASE.ETHERPACKET RESPONSE)))
            ((OR (NEQ 0 (fetch (DOMAIN.HEADER NSCOUNT) of RESPONSEBASE))
                 (NEQ 0 (fetch (DOMAIN.HEADER ARCOUNT) of RESPONSEBASE)))
          
          (* * The server we asked didn't know, but did tell us the name of a server 
        which might know)

             (PROG1 (\DOMAIN.PROCESS.REDIRECT (\MAKEBASEBYTESTREAM RESPONSEBASE 0
                                                         (IDIFFERENCE (fetch (UDP UDPLENGTH)
                                                                         of RESPONSE)
                                                                \UDPOVLEN)
                                                         'INPUT))
                    (\RELEASE.ETHERPACKET RESPONSE)))
            (T (\RELEASE.ETHERPACKET RESPONSE)
               'FAILED])

(\UDPDOM.QUERY
  [LAMBDA (DOMAIN TYPE CLASS SERVER)                     (* ejs%: " 5-Nov-86 13:40")
          
          (* * Make a domain query. Argument semantics should be self-evident if you've 
        read RFC882 and RFC883. Returns a list of answers, or atoms to indicate 
        failure--USE.TCP, etc)

    (LET* ((QUERY (\ALLOCATE.ETHERPACKET))
           (ID (RAND 1 65534))
           ANSWER DOMAINBASE)
          
          (* * Do basic QUERY initialization)

          (UDP.SETUP QUERY (OR SERVER \DOMAIN.DEFAULT.SERVER)
                 \DOMAIN.PORT ID (\UDPDOM.IPSOCKET))
          (SETQ DOMAINBASE (fetch (UDP UDPCONTENTS) of QUERY))
          
          (* * Format header section)

          (replace (DOMAIN.HEADER ID) of DOMAINBASE with ID)
          (replace (DOMAIN.HEADER RESPONSEFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER AUTHORITYFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER TRUNCATEDFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER WANTRECURSEFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER CANRECURSEFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER OPCODE) of DOMAINBASE with DOMAIN.QUERY)
          (replace (DOMAIN.HEADER RESPONSECODE) of DOMAINBASE with 0)
          (replace (DOMAIN.HEADER QDCOUNT) of DOMAINBASE with 1)
          (replace (DOMAIN.HEADER ANCOUNT) of DOMAINBASE with 0)
          (replace (DOMAIN.HEADER NSCOUNT) of DOMAINBASE with 0)
          (replace (DOMAIN.HEADER ARCOUNT) of DOMAINBASE with 0)
          (UDP.INCREMENT.LENGTH QUERY (UNFOLD \UDPDOMAIN.WDS BYTESPERWORD))
          
          (* * Add Query)

          [COND
             ((AND (NOT (NULL DOMAIN))
                   (NLISTP DOMAIN))
              (SETQ DOMAIN (\DOMAIN.PARSE.NAME DOMAIN]
          (for NAME in DOMAIN do (UDP.APPEND.BYTE QUERY (NCHARS NAME))
                                            (UDP.APPEND.STRING QUERY (MKSTRING NAME))
             finally (UDP.APPEND.BYTE QUERY 0))
          (UDP.APPEND.WORD QUERY TYPE)
          (UDP.APPEND.WORD QUERY CLASS)
          
          (* * Do the query)

          (bind RESPONSE RESPONSEBASE for I from 1 to \MAXETHERTRIES
             do (COND
                       [(SETQ RESPONSE (UDP.EXCHANGE (\UDPDOM.IPSOCKET)
                                              QUERY 10000))
                        (SETQ RESPONSEBASE (fetch (UDP UDPCONTENTS) of RESPONSE))
                        (COND
                           [(AND (EQ (fetch (DOMAIN.HEADER ID) of RESPONSEBASE)
                                     ID)
                                 (fetch (DOMAIN.HEADER RESPONSEFLG) of RESPONSEBASE))
                            (COND
                               ((AND (fetch (DOMAIN.HEADER TRUNCATEDFLG) of RESPONSEBASE)
                                     (EQ (fetch (DOMAIN.HEADER ANCOUNT) of RESPONSEBASE)
                                         0)
                                     (EQ (fetch (DOMAIN.HEADER NSCOUNT) of RESPONSEBASE)
                                         0)
                                     (EQ (fetch (DOMAIN.HEADER RESPONSECODE) of RESPONSEBASE)
                                         RCODE.OK))
                                (SETQ ANSWER 'USE.TCP)
                                (\RELEASE.ETHERPACKET RESPONSE)
                                (GO $$OUT))
                               ((NEQ (fetch (DOMAIN.HEADER RESPONSECODE) of RESPONSEBASE)
                                     RCODE.OK)
                                (SETQ ANSWER (\DOMAIN.RCODE.ERROR (fetch (DOMAIN.HEADER
                                                                                  RESPONSECODE)
                                                                         of RESPONSEBASE)))
                                (COND
                                   (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                                          (printout DOMAIN.TRACE.FILE "Error on query: " ANSWER)))
                                (\RELEASE.ETHERPACKET RESPONSE)
                                (GO $$OUT))
                               (T (SETQ ANSWER (\UDPDOM.PROCESS.RESPONSE DOMAIN RESPONSE))
                                  (GO $$OUT]
                           (T (\RELEASE.ETHERPACKET RESPONSE]
                       (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                              (printout DOMAIN.TRACE.FILE "Query to " (\IP.ADDRESS.TO.STRING
                                                                       (fetch (IP 
                                                                                 IPDESTINATIONADDRESS
                                                                                      ) of QUERY)
                                                                       )
                                     " timed out."))) finally (\RELEASE.ETHERPACKET QUERY)
                                                            (RETURN ANSWER])

(\UDPDOM.IPSOCKET
  [LAMBDA NIL                                            (* ejs%: "12-Apr-86 20:39")
    [COND
       ((NULL \UDPDOMAIN.IPSOCKET)
        (SETQ \UDPDOMAIN.IPSOCKET (UDP.OPEN.SOCKET)))
       ((NOT (\IP.FIND.SOCKET (fetch (IPSOCKET IPSOCKET) of \UDPDOMAIN.IPSOCKET)
                    (\IP.FIND.PROTOCOL \UDP.PROTOCOL)))
        (SETQ \UDPDOMAIN.IPSOCKET (UDP.OPEN.SOCKET NIL 'ACCEPT]
    \UDPDOMAIN.IPSOCKET])
)



(* ;; "Protocol independent functions")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ DOMAIN.OPCODES ((DOMAIN.QUERY 0)
                           (DOMAIN.IQUERY 1)
                           (DOMAIN.CQUERYM 2)
                           (DOMAIN.CQUERYU 3)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DOMAIN.QUERY 0)

(RPAQQ DOMAIN.IQUERY 1)

(RPAQQ DOMAIN.CQUERYM 2)

(RPAQQ DOMAIN.CQUERYU 3)


(CONSTANTS (DOMAIN.QUERY 0)
       (DOMAIN.IQUERY 1)
       (DOMAIN.CQUERYM 2)
       (DOMAIN.CQUERYU 3))
)

(RPAQQ DOMAIN.RCODES ((RCODE.OK 0)
                          (RCODE.FORMATERROR 1)
                          (RCODE.SERVERFAILED 2)
                          (RCODE.NAMEERROR 3)
                          (RCODE.NOTIMPLEMENTED 4)
                          (RCODE.REFUSED 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ RCODE.OK 0)

(RPAQQ RCODE.FORMATERROR 1)

(RPAQQ RCODE.SERVERFAILED 2)

(RPAQQ RCODE.NAMEERROR 3)

(RPAQQ RCODE.NOTIMPLEMENTED 4)

(RPAQQ RCODE.REFUSED 5)


(CONSTANTS (RCODE.OK 0)
       (RCODE.FORMATERROR 1)
       (RCODE.SERVERFAILED 2)
       (RCODE.NAMEERROR 3)
       (RCODE.NOTIMPLEMENTED 4)
       (RCODE.REFUSED 5))
)

(RPAQQ DOMAIN.RRTYPES
       ((RRTYPE.A 1)
        (RRTYPE.NS 2)
        (RRTYPE.MD 3)
        (RRTYPE.MF 4)
        (RRTYPE.CNAME 5)
        (RRTYPE.SOA 6)
        (RRTYPE.MB 7)
        (RRTYPE.MG 8)
        (RRTYPE.MR 9)
        (RRTYPE.NULL 10)
        (RRTYPE.WKS 11)
        (RRTYPE.PTR 12)
        (RRTYPE.HINFO 13)
        (RRTYPE.MINFO 14)
        (RRTYPE.MX 15)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ RRTYPE.A 1)

(RPAQQ RRTYPE.NS 2)

(RPAQQ RRTYPE.MD 3)

(RPAQQ RRTYPE.MF 4)

(RPAQQ RRTYPE.CNAME 5)

(RPAQQ RRTYPE.SOA 6)

(RPAQQ RRTYPE.MB 7)

(RPAQQ RRTYPE.MG 8)

(RPAQQ RRTYPE.MR 9)

(RPAQQ RRTYPE.NULL 10)

(RPAQQ RRTYPE.WKS 11)

(RPAQQ RRTYPE.PTR 12)

(RPAQQ RRTYPE.HINFO 13)

(RPAQQ RRTYPE.MINFO 14)

(RPAQQ RRTYPE.MX 15)


(CONSTANTS (RRTYPE.A 1)
       (RRTYPE.NS 2)
       (RRTYPE.MD 3)
       (RRTYPE.MF 4)
       (RRTYPE.CNAME 5)
       (RRTYPE.SOA 6)
       (RRTYPE.MB 7)
       (RRTYPE.MG 8)
       (RRTYPE.MR 9)
       (RRTYPE.NULL 10)
       (RRTYPE.WKS 11)
       (RRTYPE.PTR 12)
       (RRTYPE.HINFO 13)
       (RRTYPE.MINFO 14)
       (RRTYPE.MX 15))
)

(RPAQQ DOMAIN.CLASSTYPES ((CLASSTYPE.IN 1)
                              (CLASSTYPE.CSNET 2)
                              (CLASSTYPE.CHAOS 3)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ CLASSTYPE.IN 1)

(RPAQQ CLASSTYPE.CSNET 2)

(RPAQQ CLASSTYPE.CHAOS 3)


(CONSTANTS (CLASSTYPE.IN 1)
       (CLASSTYPE.CSNET 2)
       (CLASSTYPE.CHAOS 3))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \DOMAIN.PORT 53)


(CONSTANTS (\DOMAIN.PORT 53))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \DOMAIN.DEFAULT.SERVER )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \DOMAIN.DEFAULT.SERVER)
)
(DEFINEQ

(\DOMAIN.NAME
  [LAMBDA (DOMAIN.TREE.NODE)                             (* ejs%: "13-Apr-86 15:38")
          
          (* * Generate a list of domain names along the path to the root of the domain 
        tree)

    (COND
       ((NULL (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE))
        NIL)
       (T (LET [(SUFFIX (\DOMAIN.NAME (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of 
                                                                                     DOMAIN.TREE.NODE
                                                 ]
               (COND
                  (SUFFIX (CONCAT (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE)
                                 "." SUFFIX))
                  (T (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE])

(\DOMAIN.PACK.NAME.LIST
  [LAMBDA (LIST)                                         (* ejs%: "12-Apr-86 20:29")
    (COND
       ((LISTP LIST)
        (LET [(DOMAIN.NAME (ALLOCSTRING (IPLUS (SUB1 (LENGTH LIST))
                                               (for NAME in LIST sum (NCHARS NAME]
             [bind (I _ 1) for NAME in LIST do (RPLSTRING DOMAIN.NAME I NAME)
                                                              (add I (NCHARS NAME))
                                                              (COND
                                                                 ((ILESSP I (NCHARS DOMAIN.NAME))
                                                                  (RPLCHARCODE DOMAIN.NAME I
                                                                         (CHARCODE %.))
                                                                  (add I 1]
             DOMAIN.NAME))
       (T (ALLOCSTRING 0])

(\DOMAIN.PARSE.NAME
  [LAMBDA (NAME)                                         (* ejs%: "12-Apr-86 18:11")
          
          (* * This function parses a domain name
        (e.g. SUMEX.STANFORD.EDU)%, and returns a list of domain labels
        (SUMEX STANFORD EDU))

    (bind (SCRATCHSTRING _ (CONSTANT (ALLOCSTRING 63)))
           NAMELIST
           (LENGTH _ 0) for CHAR instring (MKSTRING NAME)
       do (COND
                 [(EQ CHAR (CHARCODE %.))
                  (COND
                     ((NEQ 0 LENGTH)
                      [SETQ NAMELIST (NCONC1 NAMELIST (CONCAT (SUBSTRING SCRATCHSTRING 1 LENGTH]
                      (SETQ LENGTH 0]
                 ((IGREATERP LENGTH 63)
                  (ERROR "Domain name too long" SCRATCHSTRING))
                 (T (RPLCHARCODE SCRATCHSTRING (add LENGTH 1)
                           CHAR))) finally (RETURN (COND
                                                          [(NEQ LENGTH 0)
                                                           (NCONC1 NAMELIST
                                                                  (CONCAT (SUBSTRING SCRATCHSTRING 1 
                                                                                 LENGTH]
                                                          (T NAMELIST])

(\DOMAIN.RCODE.ERROR
  [LAMBDA (CODE)                                         (* ejs%: "12-Apr-86 19:15")
    (SELECTC CODE
        (RCODE.OK 'OK)
        (RCODE.FORMATERROR 
             'FORMAT.ERROR)
        (RCODE.SERVERFAILED 
             'SERVER.FAILED)
        (RCODE.NAMEERROR 
             'NAME.ERROR)
        (RCODE.NOTIMPLEMENTED 
             'NOT.IMPLEMENTED)
        (RCODE.REFUSED 'REFUSED)
        NIL])

(\DOMAIN.PROCESS.REDIRECT
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:04")
          
          (* * Skip past the header and query section to get to the answer section)
          
          (* * Past ID and flags in header)

    (\WIN STREAM)
    (\WIN STREAM)
    (LET ((%#QUESTIONS (\WIN STREAM))
          (%#ANSWERS (\WIN STREAM))
          (%#NSERVERS (\WIN STREAM))
          (%#ADDITIONAL (\WIN STREAM)))
          
          (* * Past questions)

         (for I from 1 to %#QUESTIONS do (\DOMAIN.SKIP.QUESTION STREAM))
          
          (* * Collect answers)

         (for I from 1 to %#ANSWERS collect (\DOMAIN.SKIP.RR STREAM))
          
          (* * Collect rest)

         (APPEND (for I from 1 to %#NSERVERS collect (\DOMAIN.PROCESS.RR STREAM))
                (for I from 1 to %#ADDITIONAL collect (\DOMAIN.PROCESS.RR STREAM])

(\DOMAIN.PROCESS.RESPONSE
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 19:58")
          
          (* * Skip past the header and query section to get to the answer section)
          
          (* * Past ID and flags in header)

    (\WIN STREAM)
    (\WIN STREAM)
    (LET ((%#QUESTIONS (\WIN STREAM))
          (%#ANSWERS (\WIN STREAM)))
          
          (* * Past rest of header)

         (\WIN STREAM)
         (\WIN STREAM)
          
          (* * Past questions)

         (for I from 1 to %#QUESTIONS do (\DOMAIN.SKIP.QUESTION STREAM))
          
          (* * Collect answers)

         (for I from 1 to %#ANSWERS collect (\DOMAIN.PROCESS.RR STREAM])

(\DOMAIN.PROCESS.RR
  [LAMBDA (STREAM)                                       (* ejs%: "13-Apr-86 17:09")
          
          (* * Process a resource record beginning at the current point in the stream)

    (LET ((NAME (\DOMAIN.READ.NAME.FROM.STREAM STREAM))
          (TYPE (\WIN STREAM))
          (CLASS (\WIN STREAM))
          (TTL (\MAKENUMBER (\WIN STREAM)
                      (\WIN STREAM)))
          (RDLEN (\WIN STREAM))
          ANSWER)
         [SETQ ANSWER `(NAME %, NAME TYPE %, TYPE CLASS %, CLASS TTL %, TTL DATA %,
                             (SELECTC TYPE
                                 (RRTYPE.A (\DOMAIN.READ.ADDRESS STREAM CLASS (FOLDLO RDLEN 
                                                                                         BYTESPERCELL
                                                                                         )))
                                 ((LIST RRTYPE.CNAME RRTYPE.NS) 
                                      (\DOMAIN.READ.NAME.FROM.STREAM STREAM))
                                 (RRTYPE.HINFO (CONS (\DOMAIN.READ.STRING.FROM.STREAM STREAM)
                                                     (\DOMAIN.READ.STRING.FROM.STREAM STREAM)))
                                 (PROGN (for I from 1 to RDLEN do (BIN STREAM))
                                        NIL]
         [COND
            (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE (printout DOMAIN.TRACE.FILE 
                                                                  "Answer received: " ANSWER]
         ANSWER])

(\DOMAIN.READ.ADDRESS
  [LAMBDA (STREAM CLASS %#ADDRESSES)                     (* ejs%: "12-Apr-86 20:56")
    (SELECTC CLASS
        (CLASSTYPE.IN [COND
                         ((EQ %#ADDRESSES 0)
                          NIL)
                         [(NEQ %#ADDRESSES 1)
                          (for I from 1 to %#ADDRESSES collect (\MAKENUMBER
                                                                                (\WIN STREAM)
                                                                                (\WIN STREAM]
                         (T (\MAKENUMBER (\WIN STREAM)
                                   (\WIN STREAM])
        NIL])

(\DOMAIN.READ.NAME.FROM.STREAM
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 20:54")
    (bind NAMELEN NAMELST until (EQ 0 (SETQ NAMELEN (BIN STREAM)))
       do [COND
                 [(EQ 3 (LRSH NAMELEN 6))
          
          (* * Process a pointer redirection)

                  (LET ((CONTINUATIONADDR (create WORD
                                                 HIBYTE _ (LOGAND NAMELEN (MASK.1'S 0 6))
                                                 LOBYTE _ (BIN STREAM)))
                        (STREAMPTR (GETFILEPTR STREAM)))
                       (SETFILEPTR STREAM CONTINUATIONADDR)
                       (RETURN (PROG1 (COND
                                         (NAMELST (CONCAT (\DOMAIN.PACK.NAME.LIST (DREVERSE
                                                                                       NAMELST))
                                                         "."
                                                         (\DOMAIN.READ.NAME.FROM.STREAM STREAM)))
                                         (T (\DOMAIN.READ.NAME.FROM.STREAM STREAM)))
                                      (SETFILEPTR STREAM STREAMPTR]
                 (T 
          
          (* * Normal name segment)

                    (LET ((NAME (ALLOCSTRING NAMELEN)))
                         (\BINS STREAM (fetch (STRINGP BASE) of NAME)
                                (fetch (STRINGP OFFST) of NAME)
                                NAMELEN)
                         (push NAMELST NAME] finally (RETURN (\DOMAIN.PACK.NAME.LIST
                                                                      (DREVERSE NAMELST])

(\DOMAIN.READ.STRING.FROM.STREAM
  [LAMBDA (STREAM)                                       (* ejs%: "13-Apr-86 02:33")
    (LET* ((NAMELEN (BIN STREAM))
           (STRING (ALLOCSTRING NAMELEN)))
          (for I from 1 to NAMELEN do (RPLCHARCODE STRING I (BIN STREAM)))
          STRING])

(\DOMAIN.SEARCH.FOR.CANONICAL.NAME
  [LAMBDA (NAME RRLST)                                   (* ejs%: "14-Nov-86 14:44")
    (bind FOUNDIT DATA for RR in RRLST thereis (AND (EQ RRTYPE.CNAME
                                                                        (LISTGET RR 'TYPE))
                                                                    (DOMAIN.NAME.EQUAL
                                                                     (LISTGET RR 'NAME)
                                                                     NAME)
                                                                    (SETQ FOUNDIT T))
       finally (RETURN (AND FOUNDIT (LISTGET RR 'DATA])

(\DOMAIN.SKIP.NAME.IN.STREAM
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:06")
    (bind NAMELEN NAMELST until (EQ 0 (SETQ NAMELEN (BIN STREAM)))
       do (COND
                 ((EQ 3 (LRSH NAMELEN 6))
          
          (* * Process a pointer redirection)

                  (BIN STREAM))
                 (T 
          
          (* * Normal name segment)

                    (for I from 1 to NAMELEN do (BIN STREAM])

(\DOMAIN.SKIP.QUESTION
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:06")
          
          (* * Skip over a question section--composed of compressed name, QTYPE, and 
        QCLASS fields)

    (\DOMAIN.SKIP.NAME.IN.STREAM STREAM)
    (\WIN STREAM)
    (\WIN STREAM])

(\DOMAIN.SKIP.RR
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:10")
          
          (* * Skip a resource record beginning at the current point in the stream)
          
          (* * Name)

    (\DOMAIN.SKIP.NAME.IN.STREAM STREAM)
          
          (* * Type)

    (\WIN STREAM)
          
          (* * Class)

    (\WIN STREAM)
          
          (* * Time to Live)

    (\WIN STREAM)
    (\WIN STREAM)
          
          (* * RDATA Length)

    (for I from 0 to (\WIN STREAM) do (BIN STREAM])
)



(* ;; "Functions to maintain the domain tree structure")

(DECLARE%: EVAL@COMPILE

(DATATYPE DOMAIN.TREE.NODE ((NAME POINTER)               (* The name of this domain)
                                (SUBDOMAINS POINTER)         (* List of domains inferior to this 
                                                           one)
                                (SUPERDOMAIN POINTER)        (* The domain of which this domain 
                                                           is a part)
                                (NAMESERVERS POINTER)        (* The list of designated name 
                                                           servers for this domain)
                                ))

(RECORD DOMAIN.SERVER (NAME ADDRESSES EXPIRATION.DATE FOR.DOMAINS AVG.SVC.TIME)
                          AVG.SVC.TIME _ 0)
)

(/DECLAREDATATYPE 'DOMAIN.TREE.NODE '(POINTER POINTER POINTER POINTER)
       '((DOMAIN.TREE.NODE 0 POINTER)
         (DOMAIN.TREE.NODE 2 POINTER)
         (DOMAIN.TREE.NODE 4 POINTER)
         (DOMAIN.TREE.NODE 6 POINTER))
       '8)

(/DECLAREDATATYPE 'DOMAIN.TREE.NODE '(POINTER POINTER POINTER POINTER)
       '((DOMAIN.TREE.NODE 0 POINTER)
         (DOMAIN.TREE.NODE 2 POINTER)
         (DOMAIN.TREE.NODE 4 POINTER)
         (DOMAIN.TREE.NODE 6 POINTER))
       '8)
(DEFINEQ

(USTRINGHASHBITS
  [LAMBDA (STRING)                                       (* ejs%: " 5-Nov-86 13:20")
    (for C inthinstring (MKSTRING STRING) bind (HASHBITS _ 0)
       do [SETQ HASHBITS (IPLUS16 (ELT UPPERCASEARRAY C)
                                    (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS (LLSH (LOGAND HASHBITS 
                                                                                           4095)
                                                                                    2)))
                                           (LLSH (LOGAND HASHBITS 255)
                                                 8] finally (RETURN HASHBITS])
)

(RPAQ? \DOMAIN.ROOT (create DOMAIN.TREE.NODE NAME _ ""))

(RPAQ? \DOMAIN.NAMESERVERS (HASHARRAY 50 1.2 (FUNCTION USTRINGHASHBITS)
                                      (FUNCTION STRING-EQUAL)))

(RPAQ? \DOMAIN.UNKNOWN.DOMAINS )

(RPAQ? \DOMAIN.GC.INTERVAL 600000)

(RPAQ? \DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \DOMAIN.ROOT \DOMAIN.NAMESERVERS \DOMAIN.UNKNOWN.DOMAINS \DOMAIN.GC.TIMER 
       \DOMAIN.GC.INTERVAL)
)
(DEFINEQ

(\DOMAIN.ADD.NEW.DOMAIN
  [LAMBDA (NODE DOMAIN NAMESERVER ADDRESSES TTL)         (* ejs%: "25-Apr-86 12:25")
          
          (* * Add DOMAIN as a subdomain of NODE, with name service by NAMESERVER, at 
        addresses ADDRESSES, with expiration TTL seconds from now)

    (LET ((SUBDOMAIN (create DOMAIN.TREE.NODE
                            SUPERDOMAIN _ NODE
                            NAME _ DOMAIN)))
         (push (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of NODE)
                SUBDOMAIN)
         [COND
            (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                   (printout DOMAIN.TRACE.FILE "Adding " DOMAIN " as subdomain of " (\DOMAIN.NAME
                                                                                     NODE]
         (COND
            (NAMESERVER                                      (* Add name server information to 
                                                           new subdomain)
                   (COND
                      (DOMAIN.TRACE.FLG (printout DOMAIN.TRACE.FILE " with name server " NAMESERVER))
                      )
                   (\DOMAIN.ADD.NAMESERVER SUBDOMAIN NAMESERVER ADDRESSES TTL])

(\DOMAIN.ADD.NAMESERVER
  [LAMBDA (NODE NAMESERVER ADDRESSES TTL)                (* ejs%: "25-Apr-86 12:34")
          
          (* * Function called to add name server information to a node in the domain 
        tree. If ADDRESSES is NIL, this function will query the internet to resolve 
        the information)

    (COND
       (NAMESERVER (LET [(DOMAIN.SERVER (OR (GETHASH NAMESERVER \DOMAIN.NAMESERVERS)
                                            (PUTHASH NAMESERVER
                                                   (create DOMAIN.SERVER
                                                          NAME _ NAMESERVER
                                                          ADDRESSES _ ADDRESSES
                                                          EXPIRATION.DATE _
                                                          (IPLUS (IDATE)
                                                                 (OR (NUMBERP TTL)
                                                                     3600)))
                                                   \DOMAIN.NAMESERVERS]
                        [COND
                           ([AND (NULL ADDRESSES)
                                 (NULL (SETQ ADDRESSES (fetch (DOMAIN.SERVER ADDRESSES)
                                                          of DOMAIN.SERVER]
                            (SETQ ADDRESSES (replace (DOMAIN.SERVER ADDRESSES) of 
                                                                                        DOMAIN.SERVER
                                               with (OR ADDRESSES (DOMAIN.LOOKUP.ADDRESS
                                                                       NAMESERVER NIL T]
                        (COND
                           [ADDRESSES (COND
                                         ((NOT (for SERVER in (fetch (DOMAIN.TREE.NODE
                                                                                  NAMESERVERS)
                                                                         of NODE)
                                                  thereis (STRING-EQUAL SERVER NAMESERVER)))
                                          [COND
                                             (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                                                    (printout DOMAIN.TRACE.FILE "Adding " NAMESERVER 
                                                           " as new name server for " (\DOMAIN.NAME
                                                                                       NODE]
                                          (push (fetch (DOMAIN.TREE.NODE NAMESERVERS)
                                                       of NODE)
                                                 NAMESERVER)
                                          (push (fetch (DOMAIN.SERVER FOR.DOMAINS)
                                                       of DOMAIN.SERVER)
                                                 NODE]
                           (T (PUTHASH NAMESERVER NIL \DOMAIN.NAMESERVERS])

(\DOMAIN.AUGMENT.TREE
  [LAMBDA (RRLST)                                        (* ejs%: "14-Nov-86 14:30")
          
          (* * RRLST is a list of RRTYPE.NS and/or RRTYPE.A records.
        Build up our model of the internet domain tree by processing the information 
        in RRLST)

    (bind NAMESERVER for RR in RRLST do (COND
                                                           ((EQ (LISTGET RR 'TYPE)
                                                                RRTYPE.NS)
                                                            (SETQ NAMESERVER (LISTGET RR 'DATA))
                                                            (\DOMAIN.INSERT.IN.TREE
                                                             (LISTGET RR 'NAME)
                                                             NAMESERVER
                                                             (\DOMAIN.SEARCH.RESOURCE.LIST RRLST 
                                                                    NAMESERVER RRTYPE.A NIL)
                                                             (LISTGET RR 'TTL])

(\DOMAIN.CHOOSE.BEST.SERVERS
  [LAMBDA (DOMAIN)                                       (* ejs%: " 1-May-86 17:15")
          
          (* * This function chooses the best servers for a query to resolve DOMAIN)

    (LET* [(PATH (COND
                    ((AND (NLISTP DOMAIN)
                          DOMAIN)
                     (DREVERSE (\DOMAIN.PARSE.NAME DOMAIN)))
                    (T DOMAIN)))
           (BEST.CHOICE (bind NEXT (CURRENT _ \DOMAIN.ROOT) for NAME in PATH
                           while [SETQ NEXT (for SUBDOMAIN in (fetch (
                                                                                     DOMAIN.TREE.NODE
                                                                                      SUBDOMAINS)
                                                                             of CURRENT)
                                                   thereis (STRING-EQUAL NAME (fetch
                                                                                   (DOMAIN.TREE.NODE
                                                                                    NAME)
                                                                                     of SUBDOMAIN
                                                                                   ]
                           do (SETQ CURRENT NEXT) finally (RETURN CURRENT]
          [while BEST.CHOICE do (COND
                                           ((fetch (DOMAIN.TREE.NODE NAMESERVERS) of 
                                                                                          BEST.CHOICE
                                                   )
                                            (RETURN))
                                           (T (SETQ BEST.CHOICE (fetch (DOMAIN.TREE.NODE 
                                                                                  SUPERDOMAIN)
                                                                   of BEST.CHOICE]
          [COND
             ((EQ BEST.CHOICE \DOMAIN.ROOT)
          
          (* Here we have a problem. Is the request for a subdomain of ROOT
        (e.g. COM, GOV, EDU, etc)%, or for a local name in our own domain?)

              (COND
                 [(AND (EQLENGTH PATH 1)
                       (for SUBDOMAIN in (fetch (DOMAIN.TREE.NODE SUBDOMAINS)
                                                    of \DOMAIN.ROOT)
                          thereis (STRING-EQUAL (CAR PATH)
                                             (fetch (DOMAIN.TREE.NODE NAME) of SUBDOMAIN]
                 (T 
          
          (* Heuristic%: If the domain doesn't appear to be a subdomain of the root, 
        assume that the local domain server will know it.
        If we're wrong, the local name server will tell us)

                    (SETQ BEST.CHOICE NIL]
          (COND
             [(NULL BEST.CHOICE)
              (COND
                 ((OR (EQLENGTH PATH 1)
                      (NULL (fetch (DOMAIN.TREE.NODE NAMESERVERS) of \DOMAIN.ROOT)))
                  (COND
                     (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                            (printout DOMAIN.TRACE.FILE "Best choice for " DOMAIN 
                                   " is our local server: " \DOMAIN.DEFAULT.SERVER)))
                  (SORT (MKLIST \DOMAIN.DEFAULT.SERVER)
                        (FUNCTION \DOMAIN.SORT.BY.SVC.TIME)))
                 (T (COND
                       (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                              (printout DOMAIN.TRACE.FILE "Best choice for " DOMAIN 
                                     " is the root server")))
                    (SORT (fetch (DOMAIN.TREE.NODE NAMESERVERS) of \DOMAIN.ROOT)
                          (FUNCTION \DOMAIN.SORT.BY.SVC.TIME]
             (T [COND
                   (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                          (printout DOMAIN.TRACE.FILE "Best choice(s) for " DOMAIN ": "
                                 (fetch (DOMAIN.TREE.NODE NAMESERVERS) of BEST.CHOICE]
                (SORT (fetch (DOMAIN.TREE.NODE NAMESERVERS) of BEST.CHOICE)
                      (FUNCTION \DOMAIN.SORT.BY.SVC.TIME])

(\DOMAIN.FIND.DOMAIN.IN.TREE
  [LAMBDA (NAME)                                         (* ejs%: "13-Apr-86 01:25")
    (COND
       ((STREQUAL NAME "")
        \DOMAIN.ROOT)
       (T (LET ([PATH (COND
                         ((LISTP NAME)
                          (REVERSE NAME))
                         (T (DREVERSE (\DOMAIN.PARSE.NAME NAME]
                (CURRENT \DOMAIN.ROOT))
               (bind NEXT for NODE on PATH
                  do (COND
                            ([NOT (SETQ NEXT (for SUBDOMAIN in (fetch (DOMAIN.TREE.NODE
                                                                                   SUBDOMAINS)
                                                                          of CURRENT)
                                                thereis (STRING-EQUAL (CAR NODE)
                                                                   (fetch (DOMAIN.TREE.NODE
                                                                               NAME) of SUBDOMAIN
                                                                          ]
                             (RETURN (CONS CURRENT NODE)))
                            (T (SETQ CURRENT NEXT))) finally (RETURN CURRENT])

(\DOMAIN.INIT
  [LAMBDA (EVENT)                                        (* ejs%: " 1-May-86 15:46")
    (SETQ \DOMAIN.DEFAULT.SERVER
     (bind NAME for SERVER in (fetch (IPINIT DOMAIN.SERVERS) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                 ) as SERVER# from 1
        collect (SETQ NAME (CONCAT "Local-Domain-Server-" SERVER#))
              (PUTHASH NAME (create DOMAIN.SERVER
                                   NAME _ NAME
                                   EXPIRATION.DATE _ MAX.FIXP
                                   ADDRESSES _ (LIST (\IP.READ.STRING.ADDRESS SERVER)))
                     \DOMAIN.NAMESERVERS)
              NAME])

(\DOMAIN.INSERT.IN.TREE
  [LAMBDA (DOMAIN NAMESERVER ADDRESSES TTL)              (* ejs%: "25-Apr-86 12:21")
          
          (* * Given information from an RRTYPE.NS record, add an entry to the domain 
        tree)

    (LET ((PARTIAL.PATH (\DOMAIN.FIND.DOMAIN.IN.TREE DOMAIN)))
         (COND
            ((type? DOMAIN.TREE.NODE PARTIAL.PATH)       (* Found it)
             (\DOMAIN.ADD.NAMESERVER PARTIAL.PATH NAMESERVER ADDRESSES TTL))
            ((EQLENGTH PARTIAL.PATH 2)                       (* Only one away from previous 
                                                           knowledge?)
             (\DOMAIN.ADD.NEW.DOMAIN (CAR PARTIAL.PATH)
                    (CADR PARTIAL.PATH)
                    NAMESERVER ADDRESSES TTL))
            (T 
          
          (* Some number of domains between our deepest knowledge and the desired 
        domain)

               (\DOMAIN.ADD.NEW.DOMAIN (CAR PARTIAL.PATH)
                      (CADR PARTIAL.PATH))
               (\DOMAIN.INSERT.IN.TREE DOMAIN NAMESERVER ADDRESSES TTL])

(\DOMAIN.PATH
  [LAMBDA (DOMAIN.TREE.NODE)                             (* ejs%: "13-Apr-86 14:44")
          
          (* * Generate a list of domain names along the path to the root of the domain 
        tree)

    (COND
       ((NULL (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE))
        NIL)
       (T (CONS (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE)
                (\DOMAIN.PATH (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE])

(\DOMAIN.SEARCH.RESOURCE.LIST
  [LAMBDA (RRLST NAME TYPE OK.TO.RETURN.NAME)            (* ejs%: "14-Nov-86 14:40")
    (LET [(ANSWER (bind DATA for RR in RRLST collect (SETQ DATA (LISTGET RR
                                                                                       'DATA))
                                                               (COND
                                                                  ((AND DATA (EQ TYPE RRTYPE.A)
                                                                        OK.TO.RETURN.NAME)
                                                                   (LISTGET RR 'NAME))
                                                                  (T DATA))
                     when (AND (EQ TYPE (LISTGET RR 'TYPE))
                                   (DOMAIN.NAME.EQUAL (LISTGET RR 'NAME)
                                          NAME]
         (COND
            (ANSWER)
            (T (LET [(CANONICAL.NAME (bind FOUNDIT DATA for RR in RRLST
                                        thereis (AND (EQ RRTYPE.CNAME (LISTGET RR 'TYPE))
                                                         (DOMAIN.NAME.EQUAL (LISTGET RR
                                                                                       'NAME)
                                                                NAME)
                                                         (SETQ FOUNDIT T))
                                        finally (RETURN (AND FOUNDIT (LISTGET RR 'DATA]
                    (COND
                       (CANONICAL.NAME (\DOMAIN.SEARCH.RESOURCE.LIST RRLST CANONICAL.NAME TYPE 
                                              OK.TO.RETURN.NAME])

(\DOMAIN.DELETE.NAMESERVER
  [LAMBDA (NAMESERVER)                                   (* ejs%: "13-Apr-86 18:35")
    (LET ((DOMAIN.SERVER (GETHASH NAMESERVER \DOMAIN.NAMESERVERS)))
         (COND
            (DOMAIN.SERVER [bind NAMESERVERS for DOMAIN in (fetch (DOMAIN.SERVER
                                                                                   FOR.DOMAINS)
                                                                          of DOMAIN.SERVER)
                              do (SETQ NAMESERVERS (fetch (DOMAIN.TREE.NODE NAMESERVERS)
                                                          of DOMAIN))
                                    (bind for NAME in NAMESERVERS
                                       when (STRING-EQUAL NAME NAMESERVER)
                                       do (replace (DOMAIN.TREE.NODE NAMESERVERS)
                                                 of DOMAIN with (DREMOVE NAME NAMESERVERS]
                   (PUTHASH NAMESERVER NIL \DOMAIN.NAMESERVERS])

(\DOMAIN.AROUND.EXIT
  [LAMBDA (EVENT)                                        (* ejs%: "13-Apr-86 18:30")
    (SELECTQ EVENT
        ((NIL AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) 
             (\DOMAIN.DELETE.TREE))
        NIL])

(\DOMAIN.DELETE.TREE
  [LAMBDA NIL                                            (* ejs%: "13-Apr-86 17:39")
          
          (* * Undoes circularity in pointers between levels of the tree)

    (bind (OPEN _ (LIST \DOMAIN.ROOT))
           CLOSED CURRENT while OPEN do (SETQ CURRENT (pop OPEN))
                                               (SETQ OPEN (APPEND (fetch (DOMAIN.TREE.NODE 
                                                                                    SUBDOMAINS)
                                                                     of CURRENT)
                                                                 OPEN))
                                               (replace (DOMAIN.TREE.NODE SUBDOMAINS)
                                                  of CURRENT with NIL)
                                               (replace (DOMAIN.TREE.NODE NAME) of CURRENT
                                                  with NIL)
                                               (replace (DOMAIN.TREE.NODE NAMESERVERS)
                                                  of CURRENT with NIL)
                                               (replace (DOMAIN.TREE.NODE SUPERDOMAIN)
                                                  of CURRENT with NIL))
    [MAPHASH \DOMAIN.NAMESERVERS (FUNCTION (LAMBDA (DOMAIN.SERVER NAME)
                                             (replace (DOMAIN.SERVER FOR.DOMAINS) of 
                                                                                        DOMAIN.SERVER
                                                with NIL]
    (CLRHASH \DOMAIN.NAMESERVERS)
    NIL])

(\DOMAIN.BACKGROUND
  [LAMBDA NIL                                            (* ejs%: "13-Apr-86 18:24")
    (COND
       ((TIMEREXPIRED? \DOMAIN.GC.TIMER)
        (\DOMAIN.GC.NAMESERVERS)
        (SETQ \DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL \DOMAIN.GC.TIMER])

(\DOMAIN.GC.NAMESERVERS
  [LAMBDA NIL                                            (* ; "Edited 11-Feb-89 12:36 by akw:")

         (* * This function maps over the name server hash array, and removes old 
       servers which have timed out)

    (LET ((TIME (IDATE)))
         (DECLARE (SPECVARS TIME))
         [MAPHASH \DOMAIN.NAMESERVERS (FUNCTION (LAMBDA (DOMAIN.SERVER NAME)
                                                  (DECLARE (USEDFREE TIME))
                                                  (COND
                                                     ((MEMBER NAME (fetch (IPINIT DOMAIN.SERVERS)
                                                                      of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                                          ))
                                                      T)
                                                     ((ILESSP (fetch (DOMAIN.SERVER 
                                                                                EXPIRATION.DATE)
                                                                 of DOMAIN.SERVER)
                                                             TIME)
                                                      (COND
                                                         (DOMAIN.TRACE.FLG (FRESHLINE 
                                                                                  DOMAIN.TRACE.FILE)
                                                                (printout DOMAIN.TRACE.FILE 
                                                                       "Name server " NAME 
                                                                       " has expired; deleting...")))
                                                      (\DOMAIN.DELETE.NAMESERVER NAME]
         NIL])

(\DOMAIN.SORT.BY.SVC.TIME
  [LAMBDA (NAME1 NAME2)                                  (* ejs%: "13-Apr-86 18:14")
    (LET ((R1 (GETHASH NAME1 \DOMAIN.NAMESERVERS))
          (R2 (GETHASH NAME2 \DOMAIN.NAMESERVERS)))
         (ILESSP (OR (fetch (DOMAIN.SERVER AVG.SVC.TIME) of R1)
                     0)
                (OR (fetch (DOMAIN.SERVER AVG.SVC.TIME) of R2)
                    0])
)

(ADDTOVAR BACKGROUNDFNS \DOMAIN.BACKGROUND)



(* ;; "Programmer's interface")


(RPAQ? DOMAIN.TRACE.FLG )

(RPAQ? DOMAIN.TRACE.FILE )

(RPAQ? INTERNET.LOCAL.DOMAIN )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DOMAIN.TRACE.FLG DOMAIN.TRACE.FILE INTERNET.LOCAL.DOMAIN)
)
(DEFINEQ

(DOMAIN.INIT
  [LAMBDA NIL                                            (* ; "Edited 15-Feb-88 17:26 by Snow")
          
          (* ;; "Called to initialize the domain service for this host")

    (DECLARE (GLOBALVARS \DOMAIN.DEFAULT.SERVER INTERNET.LOCAL.DOMAIN))
    (if (NOT \IP.DEFAULT.CONFIGURATION)
        then (PROMPTPRINT "Internet domain code is loaded, but disabled.")
      else (LET [(LOCAL.DOMAIN.SERVERS (fetch (IPINIT DOMAIN.SERVERS) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                  ))
                     (LOCAL.DOMAIN (MKSTRING (fetch (IPINIT LOCAL.DOMAIN) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                    ]
                    (COND
                       ((AND LOCAL.DOMAIN.SERVERS LOCAL.DOMAIN)
                        (SETQ \DOMAIN.DEFAULT.SERVER (for ADDR inside LOCAL.DOMAIN.SERVERS
                                                        collect (MKSTRING ADDR)))
                        (SETQ INTERNET.LOCAL.DOMAIN LOCAL.DOMAIN)
                        (for NAMESERVER in LOCAL.DOMAIN.SERVERS
                           do (\DOMAIN.INSERT.IN.TREE LOCAL.DOMAIN (MKSTRING NAMESERVER)
                                         (LIST (DODIP.HOSTP NAMESERVER))
                                         MAX.FIXP)))
                       (T (PROMPTPRINT "Internet domain code is loaded, but disabled."])

(DOMAIN.LOOKUP.ADDRESS
  [LAMBDA (NAME SERVER DONT.GET.OSTYPE)                  (* ; "Edited 15-Feb-89 15:14 by welch")

         (* * Programmer's interface to lookup IP Internet host name using the domain 
       system)

    (bind (OPEN _ (OR (MKLIST SERVER)
                          (\DOMAIN.CHOOSE.BEST.SERVERS NAME)))
           CANONICAL.NAME CLOSED ADDRESSES THIS.SERVER ANSWER OSTYPE (ATOMIC-NAME _
                                                                            (MKATOM (U-CASE NAME)))
       while OPEN do (SETQ THIS.SERVER (pop OPEN))
                            (push CLOSED THIS.SERVER)
                            (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.A THIS.SERVER))
                            (COND
                               ((SETQ ADDRESSES (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME 
                                                       RRTYPE.A))
                                (\DOMAIN.AUGMENT.TREE ANSWER)
                                [SETQ OSTYPE (COND
                                                (DONT.GET.OSTYPE NIL)
                                                (T (DOMAIN.LOOKUP.OSTYPE NAME]
                                (PUTHASH ATOMIC-NAME (create HOSTS.TXT.ENTRY
                                                            HTE.TYPE _ 'HOST
                                                            HTE.ADDRESSES _ ADDRESSES
                                                            HTE.NAMES _ (LIST ATOMIC-NAME)
                                                            HTE.OS.TYPE _ OSTYPE)
                                       \IP.HOSTNAMES)
                                (RETURN ADDRESSES))
                               (ANSWER (COND
                                          ([SETQ CANONICAL.NAME (MKATOM (U-CASE (
                                                                  \DOMAIN.SEARCH.FOR.CANONICAL.NAME
                                                                                 NAME ANSWER]
                                           (SETQ ADDRESSES (DOMAIN.LOOKUP.ADDRESS CANONICAL.NAME
                                                                  SERVER))
                                           (PUTHASH ATOMIC-NAME (GETHASH CANONICAL.NAME \IP.HOSTNAMES
                                                                       )
                                                  \IP.HOSTNAMES)
                                           (RETURN ADDRESSES))
                                          (T (\DOMAIN.AUGMENT.TREE ANSWER)
                                             (SETQ OPEN (APPEND (for NEXT.SERVER
                                                                   in (
                                                                       \DOMAIN.SEARCH.RESOURCE.LIST
                                                                           ANSWER
                                                                           '* RRTYPE.A T)
                                                                   when (NOT (MEMBER NEXT.SERVER
                                                                                        CLOSED))
                                                                   collect NEXT.SERVER)
                                                               OPEN])

(DOMAIN.LOOKUP.NAMESERVER
  [LAMBDA (NAME SERVER)                                  (* ejs%: "25-Apr-86 12:55")
          
          (* * Programmer's interface to lookup IP Internet host name using the domain 
        system)

    (bind (OPEN _ (OR (MKLIST SERVER)
                          (\DOMAIN.CHOOSE.BEST.SERVERS NAME)))
           CLOSED NAMESERVERS THIS.SERVER ANSWER while OPEN
       do (SETQ THIS.SERVER (pop OPEN))
             (push CLOSED THIS.SERVER)
             (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.NS THIS.SERVER))
             (COND
                ((SETQ NAMESERVERS (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME RRTYPE.NS))
                 (\DOMAIN.AUGMENT.TREE ANSWER)
                 (RETURN NAMESERVERS))
                (ANSWER (\DOMAIN.AUGMENT.TREE ANSWER)
                       (SETQ OPEN (APPEND (for NEXT.SERVER in (\DOMAIN.SEARCH.RESOURCE.LIST
                                                                       ANSWER
                                                                       '* RRTYPE.A T)
                                             when (NOT (MEMBER NEXT.SERVER CLOSED)) collect
                                                                                        NEXT.SERVER)
                                         OPEN])

(DOMAIN.LOOKUP.OSTYPE
  [LAMBDA (NAME SERVER)                                  (* ejs%: "14-Nov-86 14:46")
          
          (* * Programmer's interface to lookup IP Internet host name using the domain 
        system)

    (bind (OPEN _ (OR (MKLIST SERVER)
                          (\DOMAIN.CHOOSE.BEST.SERVERS NAME)))
           CANONICAL.NAME CLOSED CPU.OSTYPES THIS.SERVER ANSWER while OPEN
       do (SETQ THIS.SERVER (pop OPEN))
             (push CLOSED THIS.SERVER)
             (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.HINFO THIS.SERVER))
             (COND
                [(SETQ CPU.OSTYPES (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME RRTYPE.HINFO))
                 (\DOMAIN.AUGMENT.TREE ANSWER)
                 (RETURN (MKATOM (U-CASE (CDAR CPU.OSTYPES]
                (ANSWER (COND
                           ((SETQ CANONICAL.NAME (\DOMAIN.SEARCH.FOR.CANONICAL.NAME NAME ANSWER))
                            (RETURN (DOMAIN.LOOKUP.OSTYPE CANONICAL.NAME SERVER)))
                           (T (\DOMAIN.AUGMENT.TREE ANSWER)
                              (SETQ OPEN (APPEND (for NEXT.SERVER
                                                    in (\DOMAIN.SEARCH.RESOURCE.LIST
                                                            ANSWER
                                                            '* RRTYPE.A T)
                                                    when (NOT (MEMBER NEXT.SERVER CLOSED))
                                                    collect NEXT.SERVER)
                                                OPEN])

(DOMAIN.LOOKUP
  [LAMBDA (NAME TYPE SERVER)                             (* ; "Edited 15-Feb-88 17:24 by Snow")

(* ;;; "Programmer's interface to lookup IP Internet host name using the domain system")

    (PROG ((DOMAIN.PATH (\DOMAIN.PARSE.NAME NAME))
           (RETRYCOUNT 0)
           ANSWER ADDRESS TIMINGFLG START.TIME)
          (OR TYPE (SETQ TYPE RRTYPE.A))
          [COND
             [(LISTP SERVER)
              (SETQ ADDRESS (COND
                               [(LISTP (CAR SERVER))         (* ; 
                                                          "Handles a list of DOMAIN.SERVER records")

                                (CAR (fetch (DOMAIN.SERVER ADDRESSES) of (CAR SERVER]
                               (T                            (* ; "Handles a list of addresses")

                                  (CAR SERVER]
             (SERVER                                         (* ; "Handles a single address")

                    (SETQ ADDRESS SERVER))
             (T (SETQ SERVER \DOMAIN.DEFAULT.SERVER)
                (SETQ ADDRESS (CAR SERVER]
          [COND
             ((STRINGP ADDRESS)
              (SETQ ADDRESS (CAR (fetch (DOMAIN.SERVER ADDRESSES) of (SETQ TIMINGFLG
                                                                              (GETHASH ADDRESS 
                                                                                  \DOMAIN.NAMESERVERS
                                                                                     ]
          (COND
             (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                    (PRIN1 "Type " DOMAIN.TRACE.FILE)
                    (PRINTCONSTANT TYPE DOMAIN.RRTYPES DOMAIN.TRACE.FILE)
                    (printout DOMAIN.TRACE.FILE " query to " (COND
                                                                ((NUMBERP SERVER)
                                                                 (\IP.ADDRESS.TO.STRING SERVER))
                                                                (T SERVER))
                           " for " NAME T)))
      LOOP
          (add RETRYCOUNT 1)
          [COND
             (TIMINGFLG (SETQ START.TIME (IDATE]
          [SETQ ANSWER (COND
                          ((NULL ANSWER)
                           (\UDPDOM.QUERY DOMAIN.PATH TYPE CLASSTYPE.IN ADDRESS))
                          ((EQ ANSWER 'USE.TCP)
                           (\TCPDOM.QUERY DOMAIN.PATH TYPE CLASSTYPE.IN ADDRESS]
          [COND
             (TIMINGFLG (replace (DOMAIN.SERVER AVG.SVC.TIME) of TIMINGFLG
                           with (IDIFFERENCE (IDATE)
                                           START.TIME]
          (COND
             ((LITATOM ANSWER)
              (SELECTQ ANSWER
                  (NIL (COND
                          ((LISTP SERVER)
                           (SETQ SERVER (CDR SERVER))
                           [SETQ ADDRESS (CAR (fetch (DOMAIN.SERVER ADDRESSES)
                                                 of (CAR SERVER]
                           (SETQ RETRYCOUNT 0)
                           (GO LOOP))
                          (T (RETURN ANSWER))))
                  (NAME.ERROR (RETURN NIL))
                  (USE.TCP (COND
                              ((EQ RETRYCOUNT 1)
                               (GO LOOP))
                              (T (RETURN NIL))))
                  (RETURN ANSWER)))
             (T (RETURN ANSWER])

(DOMAIN.GRAPH
  [LAMBDA (WINDOW)                                       (* ; "Edited 19-Mar-87 16:58 by FS")

    (LET ((OPENLIST (LIST \DOMAIN.ROOT))
          NODELST)
         (bind NODE while OPENLIST do (SETQ NODE (pop OPENLIST))
                                                 (push NODELST
                                                        (create GRAPHNODE
                                                               NODELABEL _
                                                               (COND
                                                                  ((NULL (fetch (DOMAIN.TREE.NODE
                                                                                     SUPERDOMAIN)
                                                                            of NODE))
                                                                   "*ROOT*")
                                                                  (T (fetch (DOMAIN.TREE.NODE
                                                                                 NAME) of NODE)))
                                                               NODEID _ NODE
                                                               TONODES _ (fetch (DOMAIN.TREE.NODE
                                                                                     SUBDOMAINS)
                                                                            of NODE)))
                                                 (SETQ OPENLIST (APPEND (fetch (DOMAIN.TREE.NODE
                                                                                    SUBDOMAINS)
                                                                           of NODE)
                                                                       OPENLIST)))
         (SHOWGRAPH (LAYOUTGRAPH NODELST (LIST \DOMAIN.ROOT)
                           'HORIZONTAL)
                WINDOW
                (FUNCTION (LAMBDA (NODE W)
                            (COND
                               (NODE (INSPECT (fetch (GRAPHNODE NODEID) of NODE)))
                               (T (DOMAIN.GRAPH W])

(DOMAIN.NAME.EQUAL
  [LAMBDA (NAME1 NAME2)                                  (* ejs%: "13-Apr-86 17:23")
    (COND
       ((OR (EQ NAME1 '*)
            (EQ NAME2 '*))
        T)
       (T (OR (LISTP NAME1)
              (SETQ NAME1 (\DOMAIN.PARSE.NAME NAME1)))
          (OR (LISTP NAME2)
              (SETQ NAME2 (\DOMAIN.PARSE.NAME NAME2)))
          (COND
             ((OR (AND (NULL NAME1)
                       NAME2)
                  (AND (NULL NAME2)
                       NAME1))
              NIL)
             (T (for X in NAME1 as Y in NAME2 always (STRING-EQUAL X Y])

(DOMAIN.TRACE
  [LAMBDA (MODE)                                         (* ejs%: "13-Apr-86 16:12")
    [COND
       ((WINDOWP DOMAIN.TRACE.FILE)
        (OPENW DOMAIN.TRACE.FILE))
       (T (SETQ DOMAIN.TRACE.FILE (CREATEW NIL "Domain Trace File"))
          (DSPSCROLL 'ON DOMAIN.TRACE.FILE)
          (DSPFONT '(GACHA 8) DOMAIN.TRACE.FILE)
          (WINDOWPROP DOMAIN.TRACE.FILE 'BUTTONEVENTFN (FUNCTION DOMAIN.TRACEWINDOW.BUTTONFN))
          (WINDOWPROP DOMAIN.TRACE.FILE 'CLOSEFN (FUNCTION (LAMBDA NIL
                                                             (SETQ DOMAIN.TRACE.FLG NIL)
                                                             (SETQ DOMAIN.TRACE.FILE]
    (SETQ DOMAIN.TRACE.FLG MODE])

(DOMAIN.TRACEWINDOW.BUTTONFN
  [LAMBDA (WINDOW)                                       (* ejs%: "13-Apr-86 15:49")
    (COND
       ((MOUSESTATE (NOT UP))
        (SETQ DOMAIN.TRACE.FLG (SELECTQ DOMAIN.TRACE.FLG
                                   (NIL T)
                                   (T NIL)
                                   NIL))
        (printout WINDOW T "[Tracing " (SELECTQ DOMAIN.TRACE.FLG
                                           (T "on")
                                           "off")
               "]" T])
)

(DOMAIN.INIT)
(PUTPROPS TCPDOMAIN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4891 12420 (\UDPDOM.PROCESS.RESPONSE 4901 . 6651) (\UDPDOM.QUERY 6653 . 11968) (
\UDPDOM.IPSOCKET 11970 . 12418)) (15354 27202 (\DOMAIN.NAME 15364 . 16190) (\DOMAIN.PACK.NAME.LIST 
16192 . 17169) (\DOMAIN.PARSE.NAME 17171 . 18511) (\DOMAIN.RCODE.ERROR 18513 . 18946) (
\DOMAIN.PROCESS.REDIRECT 18948 . 19944) (\DOMAIN.PROCESS.RESPONSE 19946 . 20717) (\DOMAIN.PROCESS.RR 
20719 . 22311) (\DOMAIN.READ.ADDRESS 22313 . 22999) (\DOMAIN.READ.NAME.FROM.STREAM 23001 . 24730) (
\DOMAIN.READ.STRING.FROM.STREAM 24732 . 25048) (\DOMAIN.SEARCH.FOR.CANONICAL.NAME 25050 . 25758) (
\DOMAIN.SKIP.NAME.IN.STREAM 25760 . 26267) (\DOMAIN.SKIP.QUESTION 26269 . 26599) (\DOMAIN.SKIP.RR 
26601 . 27200)) (28554 29256 (USTRINGHASHBITS 28564 . 29254)) (29754 50847 (\DOMAIN.ADD.NEW.DOMAIN 
29764 . 30996) (\DOMAIN.ADD.NAMESERVER 30998 . 34156) (\DOMAIN.AUGMENT.TREE 34158 . 35305) (
\DOMAIN.CHOOSE.BEST.SERVERS 35307 . 39679) (\DOMAIN.FIND.DOMAIN.IN.TREE 39681 . 40954) (\DOMAIN.INIT 
40956 . 41749) (\DOMAIN.INSERT.IN.TREE 41751 . 42869) (\DOMAIN.PATH 42871 . 43387) (
\DOMAIN.SEARCH.RESOURCE.LIST 43389 . 45139) (\DOMAIN.DELETE.NAMESERVER 45141 . 46218) (
\DOMAIN.AROUND.EXIT 46220 . 46475) (\DOMAIN.DELETE.TREE 46477 . 48201) (\DOMAIN.BACKGROUND 48203 . 
48489) (\DOMAIN.GC.NAMESERVERS 48491 . 50427) (\DOMAIN.SORT.BY.SVC.TIME 50429 . 50845)) (51144 66800 (
DOMAIN.INIT 51154 . 52770) (DOMAIN.LOOKUP.ADDRESS 52772 . 56193) (DOMAIN.LOOKUP.NAMESERVER 56195 . 
57556) (DOMAIN.LOOKUP.OSTYPE 57558 . 59197) (DOMAIN.LOOKUP 59199 . 62699) (DOMAIN.GRAPH 62701 . 64901)
 (DOMAIN.NAME.EQUAL 64903 . 65527) (DOMAIN.TRACE 65529 . 66257) (DOMAIN.TRACEWINDOW.BUTTONFN 66259 . 
66798)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPEXPORTS b/obsolete/tcp/TCPEXPORTS
new file mode 100644
index 00000000..f700b47b
--- /dev/null
+++ b/obsolete/tcp/TCPEXPORTS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(LISPXPRIN1 "EXPORTS GATHERED FROM {ERIS}<LispCore>Library>TCP*.; ON 11-Sep-89 16:08:46"  T)
(LISPXTERPRI T)
(RPAQQ \TCP.CTRL.ACK 16)
(RPAQQ \TCP.CTRL.FIN 1)
(RPAQQ \TCP.CTRL.PSH 8)
(RPAQQ \TCP.CTRL.RST 4)
(RPAQQ \TCP.CTRL.SYN 2)
(RPAQQ \TCP.CTRL.URG 32)
(CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG)
(RPAQQ \TCPOPT.END 0)
(RPAQQ \TCPOPT.NOP 1)
(RPAQQ \TCPOPT.MAXSEG 2)
(CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG)
(RPAQQ \TCP.PROTOCOL 6)
(CONSTANTS \TCP.PROTOCOL)
(RPAQQ \TCP.HEADER.LENGTH 20)
(CONSTANTS \TCP.HEADER.LENGTH)
(RPAQQ \TCP.MIN.DATA.OFFSET 5)
(CONSTANTS \TCP.MIN.DATA.OFFSET)
(RPAQQ \TCP.DEFAULT.MAXSEG 536)
(CONSTANTS \TCP.DEFAULT.MAXSEG)
(ACCESSFNS TCPSEGMENT ((TCPHEADER (\IPDATABASE DATUM))) (BLOCKRECORD TCPHEADER ((TCP.SRC.PORT WORD) (
TCP.DST.PORT WORD) (TCP.SEQ FIXP) (TCP.ACK FIXP) (TCP.DATA.OFFSET BITS 4) (TCP.MBZ BITS 6) (TCP.CTRL 
BITS 6) (TCP.WINDOW WORD) (TCP.CHECKSUM WORD) (TCP.URG.PTR WORD))) (ACCESSFNS TCPSEGMENT ((
TCP.DATA.LENGTH (fetch (IP IPHEADERCHECKSUM) of DATUM) (replace (IP IPHEADERCHECKSUM) of DATUM with 
NEWVALUE)) (TCP.SRC.ADDR (fetch (IP IPSOURCEADDRESS) of DATUM) (replace (IP IPSOURCEADDRESS) of DATUM 
with NEWVALUE)) (TCP.DST.ADDR (fetch (IP IPDESTINATIONADDRESS) of DATUM) (replace (IP 
IPDESTINATIONADDRESS) of DATUM with NEWVALUE)) (TCP.HEADER.LENGTH (LLSH (fetch TCP.DATA.OFFSET of 
DATUM) 2)) (TCP.CONTENTS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD (fetch TCP.DATA.OFFSET of DATUM)
 WORDSPERCELL))) (TCP.OPTIONS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD \TCP.MIN.DATA.OFFSET 
WORDSPERCELL))))))
(DATATYPE TCP.CONTROL.BLOCK ((TCB.LOCK POINTER) (* ; "monitor lock for synchronizing access") (
TCB.STATE POINTER) (* ; 
"one of CLOSED LISTEN SYN.SENT SYN.RECEIVED ESTABLISHED FIN.WAIT.1 FIN.WAIT.2 CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT"
) (TCB.SND.STREAM POINTER) (* ; "user's send stream") (TCB.SND.SEGMENT POINTER) (* ; 
"current output packet being filled") (TCB.RCV.STREAM POINTER) (* ; "user's receive stream") (
TCB.RCV.SEGMENT POINTER) (* ; "current input packet being read") (TCB.2MSL.TIMER POINTER) (* ; 
"2*MSL quiet time") (TCB.MAXSEG POINTER) (* ; "maximum segment size") (TCB.CLOSEDFLG POINTER) (* ; 
"T if user has initiated close (no more data to send)") (TCB.FINSEQ POINTER) (* ; 
"one past the sequence number of the FIN we sent") (TCB.ACKFLG POINTER) (* ; 
"when to ACK peer: NOW or LATER") (TCB.TEMPLATE POINTER) (* ; "TCP header template") (TCB.PH POINTER) 
(* ; "TCP pseudo-header for checksumming") (TCB.SRC.PORT WORD) (* ; "local port") (TCB.DST.PORT WORD) 
(* ; "remote port") (TCB.DST.HOST FIXP) (* ; "remote host address") (TCB.INPUT.QUEUE POINTER) (* ; 
"queue of received segments to be read") (TCB.REXMT.QUEUE POINTER) (* ; 
"queue of unacked segments to be retransmitted") (TCB.SND.UNA FIXP) (* ; 
"first unacknowledged sequence number") (TCB.SND.NXT FIXP) (* ; "next sequence number to be sent") (
TCB.SND.UP FIXP) (* ; "send urgent pointer") (TCB.SND.WL1 FIXP) (* ; 
"segment sequence number used for last window update") (TCB.SND.WL2 FIXP) (* ; 
"segment acknowledgment number used for last window update") (TCB.ISS FIXP) (* ; 
"initial send sequence number") (TCB.SND.WND WORD) (* ; "send window") (TCB.RCV.WND WORD) (* ; 
"receive window") (TCB.RCV.NXT FIXP) (* ; "next sequence number expected") (TCB.RCV.UP FIXP) (* ; 
"receive urgent pointer") (TCB.IRS FIXP) (* ; "initial receive sequence number") (TCB.USER.TIMEOUT 
POINTER) (* ; "in milliseconds") (TCB.ESTABLISHED POINTER) (* ; 
"processes waiting for this event are notified when the connection becomes established") (
TCB.SND.EVENT POINTER) (* ; 
"processes waiting for this event are notified when the send window opens up") (TCB.RCV.EVENT POINTER)
 (* ; "processes waiting for this event are notified when data is received") (TCB.URGENT.EVENT POINTER
) (* ; "processes waiting for this event are notified when urgent data is received") (
TCB.FINACKED.EVENT POINTER) (* ; 
"processes waiting for this event are notified when our FIN has been acked") (TCB.MODE POINTER) (* ; 
"ACTIVE or PASSIVE") (TCB.RTFLG POINTER) (* ; "T if round trip time being measured") (TCB.RTSEQ 
POINTER) (* ; "sequence number being timed") (TCB.RTTIMER POINTER) (* ; "round trip timer") (TCB.SRTT 
POINTER) (* ; "smoothed round trip time") (TCB.RTO POINTER) (* ; 
"retransmission timeout based on smoothed round trip time") (TCB.PROBE.TIMER POINTER) (* ; 
"timer for delayed ACKs and window probes") (TCB.IPSOCKET POINTER) (* ; 
"Pointer to open IP socket for this connection") (TCB.PROCESS POINTER) (* ; 
"TCP monitor process for this connection") (TCB.SENT.ZERO FLAG) (* ; 
"Sent a zero allocation last time") (TCB.OUTPUT.HELD FLAG) (* ; "True if output window shut") (
TCB.NO.IDLE.PROBING FLAG) (* ; "True if we don't probe when nothing to output") (NIL BITS 5) (
TCB.OUR.MAXSEG WORD) (TCB.LAST.SENT.RCV.WND WORD) (* ; "The value of the last rcv window we sent")) 
TCB.LOCK _ (CREATE.MONITORLOCK) TCB.STATE _ (QUOTE CLOSED) TCB.RCV.WND _ \TCP.DEFAULT.RECEIVE.WINDOW 
TCB.USER.TIMEOUT _ \TCP.DEFAULT.USER.TIMEOUT TCB.ESTABLISHED _ (CREATE.EVENT) TCB.SND.EVENT _ (
CREATE.EVENT) TCB.RCV.EVENT _ (CREATE.EVENT) TCB.URGENT.EVENT _ (CREATE.EVENT) TCB.FINACKED.EVENT _ (
CREATE.EVENT) TCB.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.OUR.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.SRTT _ 
\TCP.INITIAL.RTO TCB.RTO _ \TCP.INITIAL.RTO)
(ACCESSFNS TCPSTREAM ((TCB (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) 
(BYTECOUNT (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)) (ACCESS (fetch (
STREAM ACCESS) of DATUM) (replace (STREAM ACCESS) of DATUM with NEWVALUE)) (ORIGINAL.COFFSET (fetch (
STREAM FW6) of DATUM) (replace (STREAM FW6) of DATUM with NEWVALUE))) (CREATE (create STREAM DEVICE _ 
\TCP.DEVICE)))
(PUTPROP (QUOTE TCP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:01:28"))

(PUTPROP (QUOTE TCPCHAT) (QUOTE IMPORTDATE) (IDATE " 7-Jul-88 18:21:44"))

(RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK 
DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER))
(PUTPROP (QUOTE TCPCONFIG) (QUOTE IMPORTDATE) (IDATE "18-Apr-88 21:05:32"))

(PUTPROP (QUOTE TCPDEBUG) (QUOTE IMPORTDATE) (IDATE "16-Apr-87 15:16:27"))

(RPAQQ \UDPDOMAIN.WDS 6)
(CONSTANTS (\UDPDOMAIN.WDS 6))
(BLOCKRECORD DOMAIN.HEADER ((ID WORD) (RESPONSEFLG FLAG) (OPCODE BITS 4) (AUTHORITYFLG FLAG) (
TRUNCATEDFLG FLAG) (WANTRECURSEFLG FLAG) (CANRECURSEFLG FLAG) (NIL BITS 3) (RESPONSECODE BITS 4) (
QDCOUNT WORD) (ANCOUNT WORD) (NSCOUNT WORD) (ARCOUNT WORD)))
(RPAQQ DOMAIN.OPCODES ((DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3)))
(RPAQQ DOMAIN.QUERY 0)
(RPAQQ DOMAIN.IQUERY 1)
(RPAQQ DOMAIN.CQUERYM 2)
(RPAQQ DOMAIN.CQUERYU 3)
(CONSTANTS (DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3))
(RPAQQ DOMAIN.RCODES ((RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (
RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5)))
(RPAQQ RCODE.OK 0)
(RPAQQ RCODE.FORMATERROR 1)
(RPAQQ RCODE.SERVERFAILED 2)
(RPAQQ RCODE.NAMEERROR 3)
(RPAQQ RCODE.NOTIMPLEMENTED 4)
(RPAQQ RCODE.REFUSED 5)
(CONSTANTS (RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (
RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5))
(RPAQQ DOMAIN.RRTYPES ((RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (
RRTYPE.SOA 6) (RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 
12) (RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15)))
(RPAQQ RRTYPE.A 1)
(RPAQQ RRTYPE.NS 2)
(RPAQQ RRTYPE.MD 3)
(RPAQQ RRTYPE.MF 4)
(RPAQQ RRTYPE.CNAME 5)
(RPAQQ RRTYPE.SOA 6)
(RPAQQ RRTYPE.MB 7)
(RPAQQ RRTYPE.MG 8)
(RPAQQ RRTYPE.MR 9)
(RPAQQ RRTYPE.NULL 10)
(RPAQQ RRTYPE.WKS 11)
(RPAQQ RRTYPE.PTR 12)
(RPAQQ RRTYPE.HINFO 13)
(RPAQQ RRTYPE.MINFO 14)
(RPAQQ RRTYPE.MX 15)
(CONSTANTS (RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (RRTYPE.SOA 6) (
RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 12) (
RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15))
(RPAQQ DOMAIN.CLASSTYPES ((CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3)))
(RPAQQ CLASSTYPE.IN 1)
(RPAQQ CLASSTYPE.CSNET 2)
(RPAQQ CLASSTYPE.CHAOS 3)
(CONSTANTS (CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3))
(RPAQQ \DOMAIN.PORT 53)
(CONSTANTS (\DOMAIN.PORT 53))
(PUTPROP (QUOTE tcpdomain) (QUOTE IMPORTDATE) (IDATE "15-Feb-88 17:40:22"))

(PUTPROP (QUOTE tcpexports) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:23:47"))

(ACCESSFNS TCPDATASTREAM ((TCPCONTROLDEVICE (fetch (STREAM F3) of DATUM) (replace (STREAM F3) of DATUM
 with NEWVALUE)) (SEENEOS (fetch (STREAM F4) of DATUM) (replace (STREAM F4) of DATUM with NEWVALUE)) (
TCPFTPCON (fetch (STREAM F5) of DATUM) (replace (STREAM F5) of DATUM with NEWVALUE))))
(RECORD TCPFTPCON (TCPIN TCPOUT DATASTREAM BUSY? IDLETIMER GENERATEFILESDIRECTORY))
(PUTPROP (QUOTE TCPFTP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:22:47"))

(PUTPROP (QUOTE tcpftpsrv) (QUOTE IMPORTDATE) (IDATE "24-Aug-87 18:26:25"))

(PUTPROP (QUOTE TCPHTE) (QUOTE IMPORTDATE) (IDATE "24-May-88 17:06:10"))

(ACCESSFNS AR ((ARBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD ARBASE ((
ARHARDWARESPACE WORD) (ARPROTOCOLSPACE WORD) (ARHARDWARELEN BYTE) (ARPROTOCOLLEN BYTE) (AROPCODE WORD)
 (AR1STWORD WORD)) (ACCESSFNS AR1STWORD ((ARCONTENTS (LOCF DATUM))))))
(ACCESSFNS ARETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE ((
ARLCLHDW0 WORD) (ARLCLHDW1 WORD) (ARLCLHDW2 WORD) (ARLCLPTCL FIXP) (ARFRNHDW0 WORD) (ARFRNHDW1 WORD) (
ARFRNHDW2 WORD) (ARFRNPTCL FIXP)) (ACCESSFNS ARLCLHDW0 ((ARSENDERHDW (\LOADNSHOSTNUMBER (LOCF DATUM)) 
(\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)))) (ACCESSFNS ARFRNHDW0 ((ARTARGETHDW (\LOADNSHOSTNUMBER (
LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE))))))
(ACCESSFNS AREXPETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE ((
ARLCLHDW WORD) (ARLCLPTCL FIXP) (ARFRNHDW WORD) (ARFRNPTCL FIXP))))
(DATATYPE ARENTRY ((RECENT FLAG) (SEARCHING FLAG) (IPADDRESS POINTER) (ETHERADDRESS POINTER) (TIMER 
POINTER)) TIMER _ (NCREATE (QUOTE FIXP)))
(RPAQQ \AR.HARDWARE.SPACE.ETHERNET 1)
(RPAQQ \AR.ETHERNET.ADDRESS.LENGTH 6)
(RPAQQ \AR.IP.ADDRESS.LENGTH 4)
(RPAQQ \AR.REQUEST 1)
(RPAQQ \AR.RESPONSE 2)
(RPAQQ \AR.ETHER.PACKET.LENGTH 28)
(CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1) (\AR.ETHERNET.ADDRESS.LENGTH 6) (\AR.IP.ADDRESS.LENGTH 4) (
\AR.REQUEST 1) (\AR.RESPONSE 2) (\AR.ETHER.PACKET.LENGTH 28))
(PUTPROP (QUOTE TCPLLAR) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 15:50:14"))

(ACCESSFNS ICMPADMASK ((ICMPADMASKBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD 
ICMPADMASKBASE ((ICMPADMASKID WORD) (ICMPADMASKSEQNO WORD) (ICMPADMASKADMASK FIXP))))
(ACCESSFNS ICMP ((ICMPBASE (\IPDATABASE DATUM))) (BLOCKRECORD ICMPBASE ((ICMPTYPE BYTE) (ICMPCODE BYTE
) (ICMPCHECKSUM WORD) (ICMPDATASTART WORD))) (ACCESSFNS ICMP ((ICMPCONTENTS (LOCF (fetch (ICMP 
ICMPDATASTART) of DATUM))))))
(ACCESSFNS ICMPECHO ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE ((
ICMPECHOID WORD) (ICMPECHOSEQNO WORD) (ICMPECHODATA BYTE))))
(ACCESSFNS ICMPDESTUN ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE 
((NIL FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPDESTUN ((ICMPIPHEADER (LOCF (fetch (ICMPDESTUN 
ICMPIPSTART) of DATUM))))))
(ACCESSFNS ICMPREDIRECT ((ICMPREDIRECTBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD 
ICMPREDIRECTBASE ((ICMPGATEWAY FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPREDIRECT ((ICMPIPHEADER (LOCF
 (fetch (ICMPREDIRECT ICMPIPSTART) of DATUM))))))
(RPAQQ ICMPTYPES ((\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (
\ICMP.REDIRECT 5) (\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (
\ICMP.TIMESTAMP 13) (\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (
\ICMP.ADDRESS.MASK.REQUEST 17) (\ICMP.ADDRESS.MASK.REPLY 18)))
(RPAQQ \ICMP.ECHO.REPLY 0)
(RPAQQ \ICMP.DEST.UNREACHABLE 3)
(RPAQQ \ICMP.SOURCE.QUENCH 4)
(RPAQQ \ICMP.REDIRECT 5)
(RPAQQ \ICMP.ECHO 8)
(RPAQQ \ICMP.TIME.EXCEEDED 11)
(RPAQQ \ICMP.PARAMETER.PROBLEM 12)
(RPAQQ \ICMP.TIMESTAMP 13)
(RPAQQ \ICMP.TIMESTAMP.REPLY 14)
(RPAQQ \ICMP.INFO.REQUEST 15)
(RPAQQ \ICMP.INFO.REPLY 16)
(RPAQQ \ICMP.ADDRESS.MASK.REQUEST 17)
(RPAQQ \ICMP.ADDRESS.MASK.REPLY 18)
(CONSTANTS (\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (\ICMP.REDIRECT 5) 
(\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (\ICMP.TIMESTAMP 13) (
\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (\ICMP.ADDRESS.MASK.REQUEST 17
) (\ICMP.ADDRESS.MASK.REPLY 18))
(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (
\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5
)))
(RPAQQ \ICMP.NET.UNREACHABLE 0)
(RPAQQ \ICMP.HOST.UNREACHABLE 1)
(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)
(RPAQQ \ICMP.PORT.UNREACHABLE 3)
(RPAQQ \ICMP.CANT.FRAGMENT 4)
(RPAQQ \ICMP.SOURCE.ROUTE 5)
(CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (
\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))
(RPAQQ ICMPREDIRECTS ((\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (
\ICMP.REDIRECT.SVC.AND.HOST 3)))
(RPAQQ \ICMP.REDIRECT.NET 0)
(RPAQQ \ICMP.REDIRECT.HOST 1)
(RPAQQ \ICMP.REDIRECT.SVC.AND.NET 2)
(RPAQQ \ICMP.REDIRECT.SVC.AND.HOST 3)
(CONSTANTS (\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (
\ICMP.REDIRECT.SVC.AND.HOST 3))
(RPAQQ ICMPTIMEXS ((\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1)))
(RPAQQ \ICMP.TRANSIT.TIME.EXCEEDED 0)
(RPAQQ \ICMP.FRAGMENT.TIME.EXCEEDED 1)
(CONSTANTS (\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1))
(RPAQQ \ICMPOVLEN 4)
(CONSTANTS \ICMPOVLEN)
(RPAQQ \ICMP.PROTOCOL 1)
(CONSTANTS \ICMP.PROTOCOL)
(PUTPROPS ICMPLENGTH MACRO (LAMBDA (ICMP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of ICMP) (LLSH (fetch
 (IP IPHEADERLENGTH) of ICMP) 2))))
(PUTPROP (QUOTE TCPLLICMP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 16:28:51"))

(ACCESSFNS IP ((IPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD IPBASE ((IPVERSION 
BITS 4) (* ; "Protocol version") (IPHEADERLENGTH BITS 4) (* ; "Head length, in cells") (IPSERVICE BYTE
) (* ; "Service type") (IPTOTALLENGTH WORD) (* ; "Packet length, in bytes") (IPID WORD) (* ; 
"Packet id") (NIL BITS 1) (IPDONTFRAGMENT FLAG) (* ; "Don't fragment me") (IPMOREFRAGMENTS FLAG) (* ; 
"Last fragment") (IPFRAGMENTOFFSET BITS 13) (* ; "Fragment position") (IPTIMETOLIVE BYTE) (* ; 
"Hop limiter") (IPPROTOCOL BYTE) (* ; "Client protocol") (IPHEADERCHECKSUM WORD) (* ; 
"Header-only checksum") (IPSOURCEADDRESS FIXP) (IPDESTINATIONADDRESS FIXP) (IPOPTIONSSTART BYTE) (* ; 
"Options or data start here")) (ACCESSFNS IPSERVICE ((IPSERVICEBASE (LOCF DATUM))) (BLOCKRECORD 
IPSERVICEBASE ((IPPRECEDENCE BITS 3) (IPDELAY FLAG) (IPTHROUGHPUT FLAG) (IPRELIABILITY FLAG) (NIL BITS
 2)))) (* ; 
"Replace is not supported on any of the following because there is ambiguity about the address class."
) (ACCESSFNS IPDESTINATIONADDRESS ((IPDESTBASE (LOCF DATUM))) (ACCESSFNS IPDESTBASE ((IPDESTINATIONNET
 (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) (
(EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (* ; 
"Class C or error") (fetch (IPADDRESS CLASSCNET) of DATUM)))) (IPDESTINATIONHOST (COND ((EQ 
\IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSAHOST) of DATUM)) ((EQ 
\IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBHOST) of DATUM)) (T (* ; 
"Class C or error") (fetch (IPADDRESS CLASSCHOST) of DATUM))))))) (ACCESSFNS IPSOURCEADDRESS ((
IPSOURCEBASE (LOCF DATUM))) (ACCESSFNS IPSOURCEBASE ((IPSOURCENET (COND ((EQ \IP.CLASS.A (fetch (
IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) ((EQ \IP.CLASS.B (fetch (
IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (fetch (IPADDRESS CLASSCNET) 
of DATUM)))) (IPSOURCEHOST (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (
IPADDRESS CLASSAHOST) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (
IPADDRESS CLASSBHOST) of DATUM)) (T (fetch (IPADDRESS CLASSCHOST) of DATUM)))))))) (TYPE? (type? 
ETHERPACKET DATUM)))
(DATATYPE IPSOCKET ((PROTOCOL BYTE) (IPSLINK POINTER) (* ; "Other sockets of this protocol type") (NIL
 BYTE) (IPSQUEUE POINTER) (* ; "Queue of packets for this protocol") (IPSQUEUELENGTH WORD) (* ; 
"Count of packets of input queue") (IPSQUEUEALLOC WORD) (* ; "Max count allowed") (
IPSDESTSOCKETCOMPAREFN POINTER) (* ; "Call this to compare dest protocol socket to this socket") (
IPSOCKET POINTER) (* ; "This socket") (IPSINPUTFN POINTER) (* ; "Call to hand packet to protocol") (
IPSEVENT POINTER) (* ; "Notify me when a packet arrives") (IPSNOSOCKETFN POINTER) (* ; 
"Call this when no socket found") (IPSICMPFN POINTER) (* ; 
"Call this when an ICMP packet is received on this protocol")) IPSQUEUE _ (create SYSQUEUE) 
IPSQUEUEALLOC _ \IP.MAX.EPKTS.ON.QUEUE IPSEVENT _ (CREATE.EVENT) IPSINPUTFN _ (FUNCTION 
\IP.DEFAULT.INPUTFN) IPSICMPFN _ (FUNCTION \RELEASE.ETHERPACKET))
(BLOCKRECORD IPADDRESS ((ADDRESS FIXP)) (* ;; "Class A nets: high bit is 0") (BLOCKRECORD IPADDRESS ((
CLASSA BITS 1) (CLASSANET BITS 7) (CLASSAHOST BITS 24))) (* ;; "Class B nets: high 2 bits are 10") (
BLOCKRECORD IPADDRESS ((CLASSB BITS 2))) (BLOCKRECORD IPADDRESS ((CLASSBNET BITS 16) (CLASSBHOST BITS 
16))) (* ;; "Class C nets: high 3 bits are 110") (BLOCKRECORD IPADDRESS ((CLASSC BITS 3))) (
BLOCKRECORD IPADDRESS ((CLASSCNETB1 BITS 8) (CLASSCNETB2 BITS 8) (CLASSCNETB3 BITS 8) (CLASSCHOST BITS
 8))) (* ; "I wish I could say just net bits 24, host bits 8, but BLOCKRECORD barfs") (BLOCKRECORD 
IPADDRESS ((CLASSCNETHI BITS 16))) (ACCESSFNS IPADDRESS ((CLASSCNET (\MAKENUMBER (FETCH CLASSCNETB1 OF
 DATUM) (LOGOR (LLSH (FETCH CLASSCNETB2 OF DATUM) 8) (FETCH CLASSCNETB3 OF DATUM))) (PROGN (REPLACE 
CLASSCNETHI OF DATUM WITH (LRSH NEWVALUE 8)) (REPLACE CLASSCNETB3 OF DATUM WITH (LOGAND NEWVALUE 255))
 DATUM)))))
(RPAQQ \IPOVLEN 20)
(RPAQQ \MAX.IPDATALENGTH 556)
(RPAQQ \IP.PROTOCOLVERSION 4)
(RPAQQ \IP.MAX.EPKTS.ON.QUEUE 16)
(RPAQQ \IP.DEFAULT.TIME.TO.LIVE 120)
(RPAQQ \IP.WAKEUP.INTERVAL 15000)
(CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE 
\IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL)
(RPAQQ IPPACKETTYPES ((\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052)))
(RPAQQ \EPT.IP 2048)
(RPAQQ \EPT.AR 2054)
(RPAQQ \EET.IP 513)
(RPAQQ \EPT.CHAOS 2052)
(CONSTANTS (\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052))
(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (
\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5
)))
(RPAQQ \ICMP.NET.UNREACHABLE 0)
(RPAQQ \ICMP.HOST.UNREACHABLE 1)
(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)
(RPAQQ \ICMP.PORT.UNREACHABLE 3)
(RPAQQ \ICMP.CANT.FRAGMENT 4)
(RPAQQ \ICMP.SOURCE.ROUTE 5)
(CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (
\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))
(PUTPROPS \IPDATABASE MACRO (LAMBDA (IP) (* ; 
"Returns the LOCF of the start of the data in the packet") (\ADDBASE (fetch (IP IPBASE) of IP) (UNFOLD
 (fetch (IP IPHEADERLENGTH) of IP) 2))))
(PUTPROPS \IPDATALENGTH MACRO (LAMBDA (IP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of IP) (LLSH (fetch 
(IP IPHEADERLENGTH) of IP) 2))))
(RPAQQ IPADDRESSTYPES ((\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (
BYTE 8 24)) (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30))
 (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (
\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (
BYTE 8 0))))
(RPAQQ \IP.CLASS.A 0)
(RPAQ \IP.CLASS.A.BYTESPEC (BYTE 1 31))
(RPAQ \IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))
(RPAQ \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))
(RPAQQ \IP.CLASS.B 2)
(RPAQ \IP.CLASS.B.BYTESPEC (BYTE 2 30))
(RPAQ \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))
(RPAQ \IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))
(RPAQQ \IP.CLASS.C 6)
(RPAQ \IP.CLASS.C.BYTESPEC (BYTE 3 29))
(RPAQ \IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))
(RPAQ \IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))
(CONSTANTS (\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) (
\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30)) (
\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (
\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (
BYTE 8 0)))
(RPAQQ IPPROTOCOLTYPES ((\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17)))
(RPAQQ \ICMP.PROTOCOL 1)
(RPAQQ \TCP.PROTOCOL 6)
(RPAQQ \UDP.PROTOCOL 17)
(CONSTANTS (\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17))
(RECORD AssemblyRecord (Packet FirstHole Fragments Timeout) Packet _ (\ALLOCATE.ETHERPACKET) FirstHole
 _ 0)
(RECORD FragmentRecord (Start Length LastFragment))
(RECORD FragmentID (AssemblyRecord SourceAddress ID Protocol . DestinationAddress))
(RPAQQ IPOPTIONTYPES ((IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4
) (IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9)))
(RPAQQ IPOPT.END 0)
(RPAQQ IPOPT.NOP 1)
(RPAQQ IPOPT.SECURITY 2)
(RPAQQ IPOPT.LSRR 3)
(RPAQQ IPOPT.TIMESTAMP 4)
(RPAQQ IPOPT.RECRT 7)
(RPAQQ IPOPT.STREAMID 8)
(RPAQQ IPOPT.SSSR 9)
(CONSTANTS (IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4) (
IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9))
(RPAQ IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0))
(CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)))
(PUTPROPS \IP.GET.BYTE DMACRO (LAMBDA (IP BYTE INHEADER) (* ;; 
"Retrieve a byte from an IP packet.  If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\GETBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE)))
(PUTPROPS \IP.GET.CELL DMACRO (LAMBDA (IP CELL INHEADER) (* ;; 
"Retrieve a cell from an IP packet.  If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion.  CELL is the offset, in 16-bit units"
) (\GETBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL)))
(PUTPROPS \IP.GET.STRING DMACRO (LAMBDA (IP BYTEOFFSET NCHARS INHEADER) (* ;; 
"Retrieve a string from an IP packet.  If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\GETBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET NCHARS))
)
(PUTPROPS \IP.GET.WORD DMACRO (LAMBDA (IP WORD INHEADER) (* ;; 
"Retrieve a word from an IP packet.  If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\GETBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD)))
(PUTPROPS \IP.PUT.BYTE DMACRO (LAMBDA (IP BYTE VALUE INHEADER) (* ;; 
"Store a byte in an IP packet.  If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\PUTBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE VALUE)))
(PUTPROPS \IP.PUT.CELL DMACRO (LAMBDA (IP CELL VALUE INHEADER) (* ;; 
"Store a cell in an IP packet.  If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion.  CELL is the offset, in 16-bit units"
) (\PUTBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL VALUE)))
(PUTPROPS \IP.PUT.STRING DMACRO (LAMBDA (IP BYTEOFFSET STRING INHEADER) (* ;; 
"Store a string ib an IP packet.  If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\PUTBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET STRING))
)
(PUTPROPS \IP.PUT.WORD DMACRO (LAMBDA (IP WORD VALUE INHEADER) (* ;; 
"Store a word in an IP packet.  If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\PUTBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD VALUE)))
(PUTPROP (QUOTE TCPLLIP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:24:32"))

(PUTPROP (QUOTE TCPNAMES) (QUOTE IMPORTDATE) (IDATE " 2-Jun-88 20:58:40"))

(RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST))
(ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM))) (BLOCKRECORD TFTPBASE ((OPCODE WORD) (
BLOCK# WORD))) (ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS) of DATUM) (FOLDHI 
\TFTPOVLEN BYTESPERWORD))))) (BLOCKRECORD TFTPBASE ((NIL WORD) (ERRORCODE WORD))))
(ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with 
NEWVALUE)) (LASTPACKETIN (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE))))
(RPAQQ \TFTPOVLEN 4)
(RPAQQ \TFTP.SOCKET 69)
(CONSTANTS (\TFTPOVLEN 4) (\TFTP.SOCKET 69))
(RPAQQ TFTPOPCODES ((\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5)))
(RPAQQ \TFTP.RRQ 1)
(RPAQQ \TFTP.WRQ 2)
(RPAQQ \TFTP.DATA 3)
(RPAQQ \TFTP.ACK 4)
(RPAQQ \TFTP.ERROR 5)
(CONSTANTS (\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5))
(PUTPROP (QUOTE TCPTFTP) (QUOTE IMPORTDATE) (IDATE " 1-Jul-87 10:54:35"))

(ACCESSFNS UDP ((UDPBASE (\IPDATABASE DATUM))) (BLOCKRECORD UDPBASE ((UDPSOURCEPORT WORD) (UDPDESTPORT
 WORD) (UDPLENGTH WORD) (UDPCHECKSUM WORD))) (ACCESSFNS UDP ((UDPCONTENTS (\ADDBASE (\IPDATABASE DATUM
) (FOLDHI \UDPOVLEN BYTESPERWORD))))))
(RPAQQ \UDPOVLEN 8)
(CONSTANTS (\UDPOVLEN 8))
(PUTPROP (QUOTE TCPUDP) (QUOTE IMPORTDATE) (IDATE " 6-Jan-89 16:37:41"))

(PUTPROP (QUOTE TCPEXPORTS) (QUOTE FILEDATES) (QUOTE (("11-Sep-89 16:22:57" . "{ERIS}<LispCore>Library>TCPEXPORTS.;8"))))

STOP

\ No newline at end of file
diff --git a/obsolete/tcp/TCPFTP b/obsolete/tcp/TCPFTP
new file mode 100644
index 00000000..519099e2
--- /dev/null
+++ b/obsolete/tcp/TCPFTP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 16:23:19" {DSK}<usr>local>lde>lispcore>library>TCPFTP.;3 50122  

      changes to%:  (VARS TCPFTPCOMS)

      previous date%: "20-Jun-89 19:47:44" {DSK}<usr>local>lde>lispcore>library>TCPFTP.;2)


(* ; "
Copyright (c) 1985, 1986, 1900, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPFTPCOMS)

(RPAQQ TCPFTPCOMS
       [[COMS 
              (* ;; "FNS from Larry's Interlisp-10 LISPUSERS package")

              (FNS ARPACMD FTPHELP CMDREADCODE CMDREAD DISCARDLINE GETLINE \TCPFTP.INPUT TELNET.EOL)
              (INITVARS (\TCPFTP.ARPACMD.LOCK (CREATE.MONITORLOCK "ARPACMD Lock")))
              (GLOBALVARS \TCPFTP.ARPACMD.LOCK)
              (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                                   (NLAML)
                                                                                   (LAMA FTPHELP]
        (COMS 
              (* ;; "FNS for the Interlisp-D streams facility")

              (FNS \TCPFTP.CONTROL.CLOSED \TCPFTP.GET.OSTYPE \TCPFTP.EVENTFN \TCPFTP.HOSTNAMEP 
                   \GET.TCPFTP.CONNECTION \TCPFTP.OPEN.CONNECTION \TCPFTP.ASSURE.CLEANUP 
                   \TCPFTP.CLEANUP \TCPFTP.RELEASE.CONNECTION \TCPFTP.LOGIN \TCPFTP.DELETEFILE 
                   \TCPFTP.DIRECTORYNAMEP \TCPFTP.ENDOFSTREAMOP \TCPFTP.GENERATEFILES 
                   \TCPFTP.GENERATENEXTFILE \TCPFTP.GETFILENAME \TCPFTP.GETFILEINFO 
                   \TCPFTP.SETFILEINFO \TCPFTP.RENAMEFILE \TCPFTP.CONNECT \TCPFTP.OPENFILE 
                   \TCPFTP.CLOSE \TCPFTP.FLUSH \TCPFTP.INIT SET.TCP.EOL.CONVENTION)
              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS TCPDATASTREAM TCPFTPCON)))
              (ADDVARS (TCPFTP.DEFAULT.FILETYPES (NIL . TEXT)
                              (DFASL . BINARY)
                              (dfasl . BINARY)
                              (LCOM . BINARY)
                              (lcom . BINARY)
                              (DCOM . BINARY)
                              (dcom . BINARY)
                              (LISP . TEXT)
                              (lisp . TEXT)
                              (LSP . TEXT)
                              (lsp . TEXT)
                              (RST . BINARY)
                              (rst . BINARY)
                              (BIN . BINARY)
                              (bin . BINARY)))
              (INITVARS (TCP.DEFAULTFILETYPE 'BINARY)
                     (TCP.USE.STANDARD.EOL T)
                     (\TCPFTP.DEVICES)
                     (\TCPFTP.CLEANUP.PROCESS))
              (GLOBALVARS \TCPFTP.DEVICES \TCPFTP.CLEANUP.PROCESS TCP.DEFAULTFILETYPE 
                     TCP.USE.STANDARD.EOL))
        (COMS 
              (* ;; "Data connection handling")

              (FNS \TCP.BYE \TCPFTP.MAYBE.ABORT \TCPFTP.DATA.CLOSED \TCPFTP.OPEN.DATA.CONNECTION 
                   \TCPFTP.PORT.STRING \TCPFTP.SPAWN.DATACONNECTION \TCPFTP.READ.UNTIL.EOF 
                   \TCPFTP.TRANSFER.COMPLETE \TCPFTP.WAIT.FOR.DATACONNECTION 
                   \TCPFTP.DELETE.CONNECTION)
              (INITVARS (\TCPFTP.DATACONNECTION.LOCK (CREATE.MONITORLOCK 
                                                            "TCPFTP Data Connection Lock"))
                     (\TCPFTP.CONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Connection Lock"))
                     (\TCPFTP.IDLE.TIMEOUT (TIMES 10 60 1000)))
              (GLOBALVARS \TCPFTP.DATACONNECTION.LOCK \TCPFTP.CONNECTION.LOCK \TCPFTP.IDLE.TIMEOUT))
        (FILES (SYSLOAD)
               TCPNAMES TCP)
        (P (\TCPFTP.INIT))
        (VARS TCPFTP.DEFAULT.FILETYPES)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])



(* ;; "FNS from Larry's Interlisp-10 LISPUSERS package")

(DEFINEQ

(ARPACMD
(LAMBDA (TCPFTPCON CMD ARG WANT DISCARD WANTARG) (* ejs%: "15-Nov-86 15:09") (* lmm "16-OCT-78 02:57") (DECLARE (GLOBALVARS \TCPFTP.ARPACMD.LOCK)) (WITH.MONITOR \TCPFTP.ARPACMD.LOCK (LET ((INC (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (OUTC (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (RESETLST (RESETSAVE NIL (BQUOTE (COND (RESETSTATE (AND (OPENP %, INC (QUOTE INPUT)) (CLOSEF %, INC)) (AND (OPENP %, OUTC (QUOTE OUTPUT)) (CLOSEF %, OUTC)))))) (PROG NIL (COND (CMD (COND (FTPDEBUGFLG (printout FTPDEBUGLOG CMD) (COND (ARG (printout FTPDEBUGLOG " " ARG))))) (PRIN3 CMD OUTC) (COND (ARG (PRIN3 " " OUTC) (PRIN3 ARG OUTC))) (TELNET.EOL OUTC) (FORCEOUTPUT OUTC) (* flush) (COND (FTPDEBUGFLG (TERPRI FTPDEBUGLOG))))) LP (COND (FTPDEBUGFLG (printout FTPDEBUGLOG "< "))) (SETQ CMD (\TCPFTP.INPUT INC)) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG CMD " "))) (COND ((EQMEMB CMD WANTARG) (AND (EQ (BIN INC) (CHARCODE -)) (FTPHELP CMD)) (RETURN CMD))) (COND ((EQ (BIN INC) (CHARCODE -)) (do (DISCARDLINE INC) repeatuntil (EQ (\TCPFTP.INPUT INC) CMD)))) (COND ((EQMEMB CMD WANT) (DISCARDLINE INC) (RETURN CMD)) ((EQMEMB CMD DISCARD) (DISCARDLINE INC) (GO LP))) (SELECTQ (AND (FIXP CMD) (IQUOTIENT CMD 100)) ((2 3) (FTPHELP CMD)) ((4 5) (ERROR (GETLINE INC T))) NIL) (DISCARDLINE INC) (GO LP))))))
)

(FTPHELP
(LAMBDA (ARG) (* ejs%: "29-Jan-85 17:02") (ERROR ARG " unrecognized response from remote FTP server"))
)

(CMDREADCODE
(LAMBDA (IN) (* lmm "31-MAY-78 00:45") (PACK* (CMDREAD IN) (CMDREAD IN) (CMDREAD IN))))

(CMDREAD
(LAMBDA (IN) (* ejs%: "12-Jan-85 14:28") ((LAMBDA (CH) (COND (FTPDEBUGFLG (BOUT CH FTPDEBUGLOG))) CH) (BIN IN)))
)

(DISCARDLINE
(LAMBDA (IN) (* ejs%: " 3-Feb-86 16:16") (* lmm "31-MAY-78 00:45") (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) (COND (FTPDEBUGFLG (\BACKFILEPTR IN) (bind CH until (FMEMB (SETQ CH (BIN IN)) (CONSTANT (LIST (CHARCODE LF) (CHARCODE NULL)))) do (BOUT FTPDEBUGLOG CH) finally (TERPRI FTPDEBUGLOG))) (T (until (FMEMB (BIN IN) (CONSTANT (LIST (CHARCODE LF) (CHARCODE NULL))))))))
)

(GETLINE
(LAMBDA (IN FLG) (* ejs%: "12-Jan-85 14:40") (* lmm "31-MAY-78 00:46") (bind CH (STRING _ (ALLOCSTRING 80)) for POS from 1 while (NEQ (SETQ CH (BIN IN)) (CHARCODE LF)) do (COND ((LEQ POS 80) (RPLCHARCODE STRING POS CH))) finally (RETURN (SUBSTRING STRING 1 (SUB1 POS)))))
)

(\TCPFTP.INPUT
(LAMBDA (STREAM) (* ; "Edited 17-Nov-88 15:16 by cdl") (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) (LET (CCODE (RESULT 0)) (to 3 do (SETQ CCODE (BIN STREAM)) (if (AND (GEQ CCODE (CHARCODE 0)) (LEQ CCODE (CHARCODE 9))) then (SETQ RESULT (PLUS (TIMES RESULT 10) (DIFFERENCE CCODE (CHARCODE 0))))) repeatuntil (OR (EQ CCODE (CHARCODE SPACE)) (EQ CCODE (CHARCODE -)) (EQ CCODE 0)) finally (if (EQ CCODE (CHARCODE -)) then (if FTPDEBUGFLG then (printout FTPDEBUGLOG T "< " RESULT)) (DISCARDLINE STREAM) (\TCPFTP.INPUT STREAM))) RESULT))
)

(TELNET.EOL
(LAMBDA (STREAM) (* ejs%: " 5-Jan-85 18:44") (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF)) (FORCEOUTPUT STREAM))
)
)

(RPAQ? \TCPFTP.ARPACMD.LOCK (CREATE.MONITORLOCK "ARPACMD Lock"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCPFTP.ARPACMD.LOCK)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FTPHELP)
)



(* ;; "FNS for the Interlisp-D streams facility")

(DEFINEQ

(\TCPFTP.CONTROL.CLOSED
(LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "28-Jul-86 14:30") (LET* ((DEVICE (fetch (STREAM DEVICE) of INSTREAM)) (TCPFTPCON (for CONN in (fetch (FDEV DEVICEINFO) of DEVICE) thereis (EQ (fetch (TCPFTPCON TCPIN) of CONN) INSTREAM)))) (COND (TCPFTPCON (replace (STREAM ACCESS) of INSTREAM with (replace (STREAM ACCESS) of OUTSTREAM with NIL)) (replace (FDEV DEVICEINFO) of DEVICE with (DREMOVE TCPFTPCON (fetch (FDEV DEVICEINFO) of DEVICE)))))))
)

(\TCPFTP.GET.OSTYPE
  [LAMBDA (DEVICE)                                       (* ; "Edited 12-May-89 14:10 by welch")
    (LET* ((HOST (fetch (FDEV DEVICENAME) of DEVICE))
           ENTRY)
          (GETHOSTINFO HOST 'OSTYPE])

(\TCPFTP.EVENTFN
(LAMBDA (FDEV FLG) (* ejs%: "23-Apr-85 18:56") (* * Called when a major event happens) (SELECTQ FLG ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS) (bind TCPIN TCPOUT DATASTREAM for TCPFTPCON in (fetch (FDEV DEVICEINFO) of FDEV) do (SETQ TCPIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SETQ TCPOUT (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (SETQ DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) (COND ((OPENP TCPIN (QUOTE INPUT)) (CLOSEF TCPIN))) (COND ((OPENP TCPOUT (QUOTE OUTPUT)) (CLOSEF TCPOUT))) (COND ((OPENP DATASTREAM) (CLOSEF DATASTREAM))))) NIL))
)

(\TCPFTP.HOSTNAMEP
  [LAMBDA (HOST DEVICE)                                  (* ejs%: "24-Mar-86 14:36")
    (DECLARE (GLOBALVARS \TCP.DEVICE \TCPFTP.DEVICES))
    (PROG ((SERVER (OR (DODIP.HOSTP HOST)
                       (\IP.READ.STRING.ADDRESS HOST)))
           FULLHOSTNAME FILINGNAME)
          (RETURN (COND
                     ((NOT SERVER)
                      NIL)
                     ((\GETDEVICEFROMNAME (SETQ FULLHOSTNAME (MKATOM (U-CASE HOST)))
                             T T))
                     (T (SETQ FILINGNAME (PACK* HOST " Filing"))
                        (\DEFINEDEVICE FULLHOSTNAME (SETQ DEVICE
                                                     (create FDEV
                                                        using \TCP.DEVICE DEVICENAME _ 
                                                              FULLHOSTNAME OPENFILE _
                                                              (FUNCTION \TCPFTP.OPENFILE)
                                                              RENAMEFILE _ (FUNCTION 
                                                                            \TCPFTP.RENAMEFILE)
                                                              REOPENFILE _ (FUNCTION NILL)
                                                              GETFILEINFO _ (FUNCTION 
                                                                             \TCPFTP.GETFILEINFO)
                                                              SETFILEINFO _ (FUNCTION 
                                                                             \TCPFTP.SETFILEINFO)
                                                              GETEOFPTR _ (FUNCTION \TCPFTP.GETEOFPTR
                                                                           )
                                                              DELETEFILE _ (FUNCTION 
                                                                            \TCPFTP.DELETEFILE)
                                                              HOSTNAMEP _ (FUNCTION NILL)
                                                              GETFILENAME _ (FUNCTION 
                                                                             \TCPFTP.GETFILENAME)
                                                              DIRECTORYNAMEP _ (FUNCTION 
                                                                               \TCPFTP.DIRECTORYNAMEP
                                                                                )
                                                              GENERATEFILES _ (FUNCTION 
                                                                               \TCPFTP.GENERATEFILES)
                                                              EVENTFN _ (FUNCTION NILL)
                                                              DEVICEINFO _ NIL)))
                        (push \TCPFTP.DEVICES DEVICE)
                        DEVICE])

(\GET.TCPFTP.CONNECTION
(LAMBDA (DEVICE) (* ejs%: " 4-Jun-85 17:54") (LET ((CONNECTIONS (fetch (FDEV DEVICEINFO) of DEVICE)) TCPFTPCON INSTREAM OUTSTREAM) (WITH.MONITOR \TCPFTP.CONNECTION.LOCK (COND ((SETQ TCPFTPCON (for TCPFTPCON in CONNECTIONS thereis (NULL (fetch (TCPFTPCON BUSY?) of TCPFTPCON)))) (COND ((AND (SETQ INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SETQ OUTSTREAM (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (OPENP INSTREAM (QUOTE INPUT)) (OPENP OUTSTREAM (QUOTE OUTPUT)) (NOT (EOFP INSTREAM))) (while (READP INSTREAM) do (BIN INSTREAM)) (replace (TCPFTPCON BUSY?) of TCPFTPCON with T) TCPFTPCON) (T (\TCPFTP.DELETE.CONNECTION TCPFTPCON DEVICE) (\TCPFTP.OPEN.CONNECTION DEVICE)))) (T (\TCPFTP.OPEN.CONNECTION DEVICE))))))
)

(\TCPFTP.OPEN.CONNECTION
(LAMBDA (DEVICE) (* ; "Edited 24-Apr-87 16:09 by FS") (LET* ((HOST (DODIP.HOSTP (fetch (FDEV DEVICENAME) of DEVICE))) (TCPFTPCON (create TCPFTPCON BUSY? _ T)) (INSTREAM (TCP.OPEN HOST \TCP.FTP.PORT NIL (QUOTE ACTIVE) (QUOTE INPUT) NIL (QUOTE (WHENCLOSEDFN \TCPFTP.CONTROL.CLOSED)))) (OUTSTREAM (COND (INSTREAM (TCP.OTHER.STREAM INSTREAM))))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (CON DEV) (COND (RESETSTATE (COND ((AND (EQ (\TCPFTP.GET.OSTYPE DEV) (QUOTE UNIX)) (READP (fetch (TCPFTPCON TCPIN) of CON))) (\TCPFTP.INPUT (fetch (TCPFTPCON TCPIN) of CON)))) (ARPACMD CON "QUIT" NIL (QUOTE (221 500))) (\TCPFTP.DELETE.CONNECTION CON DEV))))) TCPFTPCON DEVICE)) (COND (INSTREAM (replace (STREAM ENDOFSTREAMOP) of INSTREAM with (FUNCTION (LAMBDA (STREAM) (ZERO)))) (replace (STREAM DEVICE) of INSTREAM with DEVICE) (replace (STREAM DEVICE) of OUTSTREAM with DEVICE) (replace (TCPFTPCON TCPIN) of TCPFTPCON with INSTREAM) (replace (TCPFTPCON TCPOUT) of TCPFTPCON with OUTSTREAM) (SELECTQ (\TCPFTP.INPUT INSTREAM) (220 (COND (FTPDEBUGFLG (printout FTPDEBUGLOG T "< 220 ") (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))) (\TCPFTP.LOGIN DEVICE TCPFTPCON) (push (fetch (FDEV DEVICEINFO) of DEVICE) TCPFTPCON) TCPFTPCON) (PROGN (\TCPFTP.DELETE.CONNECTION TCPFTPCON DEVICE) NIL)))))))
)

(\TCPFTP.ASSURE.CLEANUP
(LAMBDA NIL (* ejs%: "27-Apr-85 14:08") (* * Spawn a cleanup function if necessary) (COND ((AND (PROCESSP \TCPFTP.CLEANUP.PROCESS) (NOT (PROCESS.FINISHEDP \TCPFTP.CLEANUP.PROCESS)))) (T (SETQ \TCPFTP.CLEANUP.PROCESS (ADD.PROCESS (QUOTE (\TCPFTP.CLEANUP)) (QUOTE RESTARTABLE) (QUOTE NO))))))
)

(\TCPFTP.CLEANUP
(LAMBDA NIL (* ejs%: "28-Jul-86 12:26") (DECLARE (GLOBALVARS \TCPFTP.IDLE.TIMEOUT \TCPFTP.DEVICES \TCPFTP.CONNECTION.LOCK)) (LET ((INTERVAL (QUOTIENT \TCPFTP.IDLE.TIMEOUT 4)) CONNECTIONSP) (repeatwhile (NOT (ZEROP CONNECTIONSP)) do (SETQ CONNECTIONSP 0) (for DEVICE in \TCPFTP.DEVICES do (for CONNECTION in (APPEND (fetch (FDEV DEVICEINFO) of DEVICE)) do (add CONNECTIONSP 1) (WITH.MONITOR \TCPFTP.CONNECTION.LOCK (NLSETQ (COND ((AND (NULL (fetch (TCPFTPCON BUSY?) of CONNECTION)) (TIMEREXPIRED? (fetch (TCPFTPCON IDLETIMER) of CONNECTION))) (CLOSEF? (fetch (TCPFTPCON TCPIN) of CONNECTION)) (CLOSEF? (fetch (TCPFTPCON TCPOUT) of CONNECTION)) (COND ((fetch (TCPFTPCON DATASTREAM) of CONNECTION) (CLOSEF? (fetch (TCPFTPCON DATASTREAM) of CONNECTION)))) (add CONNECTIONSP -1) (\TCPFTP.DELETE.CONNECTION CONNECTION DEVICE T)) ((OR (NOT (OPENP (fetch (TCPFTPCON TCPIN) of CONNECTION) (QUOTE INPUT))) (NEQ (QUOTE ESTABLISHED) (fetch (TCP.CONTROL.BLOCK TCB.STATE) of (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of CONNECTION))))) (add CONNECTIONSP -1) (\TCPFTP.DELETE.CONNECTION CONNECTION DEVICE))))) (BLOCK))) (COND ((NOT (ZEROP CONNECTIONSP)) (BLOCK INTERVAL))))))
)

(\TCPFTP.RELEASE.CONNECTION
(LAMBDA (TCPFTPCON) (* jmh "11-Oct-85 13:43") (COND (TCPFTPCON (replace (TCPFTPCON BUSY?) of TCPFTPCON with NIL) (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL) (replace (TCPFTPCON IDLETIMER) of TCPFTPCON with (SETUPTIMER \TCPFTP.IDLE.TIMEOUT)) (\TCPFTP.ASSURE.CLEANUP))))
)

(\TCPFTP.LOGIN
(LAMBDA (DEVICE TCPFTPCON) (* ; "Edited 24-Apr-87 16:17 by FS") (* * Log us in) (PROG ((OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) (HOST (fetch (FDEV DEVICENAME) of DEVICE)) (LOGINRETRYCOUNT 0) INFO) RETRY (SETQ INFO (\INTERNAL/GETPASSWORD HOST)) (* * Loop through this label if the server rejected the our name) (COND ((OR (NULL INFO) (EQ 0 (NCHARS (CAR INFO))) (EQ 0 (NCHARS (CDR INFO)))) (* Need to login. Can't send Unix hosts a string of no chars as name or password!) (LOGIN HOST) (GO RETRY))) RETRY1 (* * Loop through this label if the server rejected something else) (SELECTQ (ARPACMD TCPFTPCON "USER" (COND ((AND (EQ OSTYPE (QUOTE UNIX)) (EQ (CAR INFO) (U-CASE (CAR INFO))) (EQ LOGINRETRYCOUNT 0)) (L-CASE (CAR INFO))) (T (CAR INFO))) (QUOTE (202 230 331 332 500 503 530))) ((230 202) (* We're logged in) (RETURN T)) (331 (* Needs a password) (SELECTQ (ARPACMD TCPFTPCON "PASS" (\DECRYPT.PWD (CDR INFO)) (QUOTE (230 331 332 530))) (230 (RETURN T)) (332 (SELECTQ (ARPACMD TCPFTPCON "ACCT" (PROMPTFORWORD (CONCAT "Account for logging into " HOST)) (QUOTE (230 202 530))) (230 (RETURN T)) (GO RETRY1))) ((331 530) (LOGIN HOST) (add LOGINRETRYCOUNT 1) (GO RETRY)) (FTPHELP))) (332 (SELECTQ (ARPACMD TCPFTPCON "ACCT" (PROMPTFORWORD (CONCAT "Account for logging into " HOST)) (QUOTE (230 202 530))) (230 (RETURN T)) (GO RETRY1))) (503 (COND ((EQ OSTYPE (QUOTE UNIX)) (* ;; "Well, the sequence of events to get here was probably that the D-machine sent an illegal name/password pair, such that the name was not a registered user on the Unix machine.  There's a bug in the Unix FTP server which causes it to send a 530 error--illegal user name--immediately after it sent a 331 to prompt us for the password.  This is blatantly in violation of the FTP specification, which states that only 100 class errors can have multiple responses.  Now we're out of sync with the server, and need somehow to reinitialize our state") (\PEEKBIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (\TCPFTP.INPUT (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))) (GO RETRY1)) ((500 530) (* No such user?) (LOGIN HOST) (add LOGINRETRYCOUNT 1) (GO RETRY)) (FTPHELP))))
)

(\TCPFTP.DELETEFILE
(LAMBDA (NAME DEVICE) (* ejs%: " 7-Apr-86 11:52") (* * FTP delete request) (LET* ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE)) (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) (CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "DELE" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) NAME) OSTYPE) (QUOTE (200 226 250 450 550))))))) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) (SELECTQ CODE ((250 226 200) NAME) NIL)))
)

(\TCPFTP.DIRECTORYNAMEP
(LAMBDA (HOST/DIR DEVICE) (* ejs%: "27-Apr-85 14:04") (LET ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (TCPFTPCON) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) (COND (RESETSTATE (AND (OPENP (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (CLOSEF (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) (replace (TCPFTPCON TCPIN) of TCPFTPCON with NIL) (AND (OPENP (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (CLOSEF (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (replace (TCPFTPCON TCPOUT) of TCPFTPCON with NIL))))) TCPFTPCON)) (\TCPFTP.CONNECT DEVICE TCPFTPCON (FILENAMEFIELD HOST/DIR (QUOTE DIRECTORY))))))
)

(\TCPFTP.ENDOFSTREAMOP
(LAMBDA (STREAM SILENTLY) (* ejs%: " 3-Feb-85 17:01") (\TCPFTP.TRANSFER.COMPLETE STREAM) (OR SILENTLY (\EOSERROR STREAM)))
)

(\TCPFTP.GENERATEFILES
  [LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS)          (* ; "Edited 12-May-89 14:00 by welch")

         (* * FTP directory request)

    (LET* ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))
           (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE))
           DATASTREAMEVENT DATASTREAM CODE)
          (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON 'INPUT))
          (BLOCK)
          [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "NLST"
                                         [COND
                                            [(EQ OSTYPE 'UNIX)
                                             (COND
                                                ((AND (EQ (FILENAMEFIELD PATTERN 'VERSION)
                                                          '*)
                                                      (EQ (FILENAMEFIELD PATTERN 'EXTENSION)
                                                          '*)
                                                      (EQ (FILENAMEFIELD PATTERN 'NAME)
                                                          '*))
                                                 (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                         'HOST NIL 'VERSION NIL
                                                                         'EXTENSION NIL 'NAME "*"
                                                                         'BODY PATTERN)
                                                        'UNIX))
                                                ((EQ (FILENAMEFIELD PATTERN 'VERSION)
                                                     '*)
                                                 (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                         'HOST NIL 'VERSION NIL
                                                                         'BODY PATTERN)
                                                        'UNIX))
                                                (T (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                           'HOST NIL 'BODY PATTERN)
                                                          'UNIX]
                                            (T (COND
                                                  ((EQ OSTYPE 'INTERLISP)
                                                   (PACKFILENAME.STRING 'HOST NIL 'BODY PATTERN))
                                                  (T (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                             'HOST NIL 'BODY PATTERN)
                                                            OSTYPE]
                                         150]
          (SELECTQ CODE
              (150 

         (* * Here we go)

                   (COND
                      ((SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION DEVICE TCPFTPCON 
                                               DATASTREAMEVENT 'INPUT))
                       (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON
                          with (FILENAMEFIELD PATTERN 'DIRECTORY))
                       (create FILEGENOBJ
                              NEXTFILEFN _ (FUNCTION \TCPFTP.GENERATENEXTFILE)
                              FILEINFOFN _ (FUNCTION NILL)
                              GENFILESTATE _ TCPFTPCON))
                      (T (ERROR "Couldn't open data connection to remote TCPFTP server"))))
              (PROGN (DEL.PROCESS (CAR DATASTREAMEVENT))
                     (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                     (\NULLFILEGENERATOR])

(\TCPFTP.GENERATENEXTFILE
  [LAMBDA (TCPFTPCON NAMEONLY)                           (* ; "Edited  8-Mar-89 22:54 by akw:")
    (PROG ((DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))
           [OSTYPE (\TCPFTP.GET.OSTYPE (fetch (STREAM DEVICE) of (fetch (TCPFTPCON
                                                                                         TCPIN)
                                                                                of TCPFTPCON]
           [FILENAMERDTBL (DEFERREDCONSTANT (PROG [(R (COPYREADTABLE 'ORIG]
                                                  (SETBRK NIL NIL R)
                                                  (SETSYNTAX '%% 'OTHER R)
                                                  (SETSEPR '(13 10 31)
                                                         NIL R)
                                                  (RETURN R]
           CODE NAME)
      LOOP
          (RETURN (COND
                     [[AND (OPENP DATASTREAM 'INPUT)
                           (NOT (EOFP DATASTREAM))
                           (SETQ NAME (CAR (NLSETQ (READ DATASTREAM FILENAMERDTBL]
                      (COND
                         ((AND (OR (EQ OSTYPE 'TOPS-20)
                                   (EQ OSTYPE 'TOPS20))
                               (STRPOS "? Not found" NAME NIL NIL NIL NIL UPPERCASEARRAY))
                          (NLSETQ (until (EOFP DATASTREAM) do (READ DATASTREAM FILENAMERDTBL)
                                         ))
                          (AND (OPENP DATASTREAM)
                               (CLOSEF DATASTREAM))
                          (SELECTQ [SETQ CODE (ARPACMD TCPFTPCON NIL NIL '(226 250]
                              ((250 226) 
                                   (AND (OPENP DATASTREAM)
                                        (CLOSEF DATASTREAM))
                                   (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                                   NIL)
                              (FTPHELP CODE)))
                         ((AND (EQ OSTYPE 'UNIX)
                               (STREQUAL ":" (SUBSTRING NAME -1)))
                          (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON
                             with (REPACKFILENAME.STRING (SUBSTRING NAME 1 -2)
                                             'INTERLISP))
                          (GO LOOP))
                         (NAMEONLY (REPACKFILENAME.STRING NAME 'INTERLISP))
                         (T (if (STRPOS "*" (fetch (TCPFTPCON GENERATEFILESDIRECTORY)
                                                   of TCPFTPCON))
                                then (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME)
                                                                       of
                                                                       (fetch (STREAM DEVICE)
                                                                          of (fetch
                                                                                  (TCPFTPCON TCPIN)
                                                                                    of TCPFTPCON)
                                                                              ))
                                                'BODY
                                                (REPACKFILENAME.STRING NAME 'INTERLISP))
                              else (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME)
                                                                     of
                                                                     (fetch (STREAM DEVICE)
                                                                        of (fetch
                                                                                (TCPFTPCON TCPIN)
                                                                                  of TCPFTPCON)))
                                              'DIRECTORY
                                              (fetch (TCPFTPCON GENERATEFILESDIRECTORY)
                                                 of TCPFTPCON)
                                              'BODY
                                              (REPACKFILENAME.STRING NAME 'INTERLISP]
                     (T (AND (OPENP DATASTREAM)
                             (CLOSEF DATASTREAM))
                        (SELECTQ [SETQ CODE (ARPACMD TCPFTPCON NIL NIL '(226 250]
                            ((250 226) 
                                 (AND (OPENP DATASTREAM)
                                      (CLOSEF DATASTREAM))
                                 (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                                 NIL)
                            (FTPHELP CODE])

(\TCPFTP.GETFILENAME
  [LAMBDA (NAME RECOG DEVICE)                            (* ; "Edited 12-May-89 13:35 by welch")

         (* * FTP directory request)

    (COND
       ((EQ RECOG 'NEW)
        NAME)
       (T (PROG ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))
                 (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE))
                 DATASTREAMEVENT DATASTREAM CODE GENERATOR ALLPOSSIBILITIES)
                (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON 'INPUT))
                (BLOCK)
                [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "NLST"
                                               (COND
                                                  ((EQ OSTYPE 'INTERLISP)
                                                   (PACKFILENAME.STRING 'HOST NIL 'BODY NAME))
                                                  (T (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                             'HOST NIL 'BODY NAME)
                                                            OSTYPE)))
                                               150]
                (RETURN (SELECTQ CODE
                            (150 

         (* * Here we go)

                                 (COND
                                    ((AND (SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION
                                                            DEVICE TCPFTPCON DATASTREAMEVENT
                                                            'INPUT))
                                          (SETQ GENERATOR (create FILEGENOBJ
                                                                 NEXTFILEFN _ (FUNCTION 
                                                                             \TCPFTP.GENERATENEXTFILE
                                                                               )
                                                                 FILEINFOFN _ (FUNCTION NILL)
                                                                 GENFILESTATE _ TCPFTPCON)))
                                     (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON
                                        with (FILENAMEFIELD NAME 'DIRECTORY))
                                     (SETQ ALLPOSSIBILITIES (bind FILE
                                                               while (SETQ FILE (
                                                                                    \GENERATENEXTFILE
                                                                                     GENERATOR))
                                                               collect FILE))
                                     (MKATOM (CAR ALLPOSSIBILITIES)))
                                    (T (ERROR 
                                             "Couldn't open data connection to remote TCPFTP server."
                                              ))))
                            (PROGN (DEL.PROCESS (CAR DATASTREAMEVENT))
                                   (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                                   NIL])

(\TCPFTP.GETFILEINFO
(LAMBDA (STREAM ATTRIB DEVICE) (* ejs%: "20-Mar-86 21:01") (COND ((type? STREAM STREAM) (STREAMPROP STREAM ATTRIB)) ((EQ ATTRIB (QUOTE EOL)) (QUOTE CRLF))))
)

(\TCPFTP.SETFILEINFO
(LAMBDA (STREAM ATTRIB VALUE DEVICE) (* ejs%: " 9-Nov-85 14:20") (STREAMPROP STREAM ATTRIB VALUE)))

(\TCPFTP.RENAMEFILE
(LAMBDA (OLDDEVICE OLDNAME NEWDEVICE NEWNAME) (* ; "Edited 15-Jun-88 13:41 by atm") (* * FTP delete request) (COND ((NEQ OLDDEVICE NEWDEVICE) (\GENERIC.RENAMEFILE OLDDEVICE OLDNAME NEWDEVICE NEWNAME)) (T (LET ((OSTYPE (\TCPFTP.GET.OSTYPE OLDDEVICE)) (TCPFTPCON (\GET.TCPFTP.CONNECTION OLDDEVICE)) CODE) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (CON) (\TCPFTP.RELEASE.CONNECTION CON))) TCPFTPCON)) (PROG NIL RETRY (SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "RNFR" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) OLDNAME) OSTYPE) (QUOTE (350 450 550)))))) (SELECTQ CODE (350 (SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "RNTO" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) NEWNAME) OSTYPE) (QUOTE (200 250 553)))))) (SELECTQ CODE ((200 250) (RETURN NEWNAME)) NIL)) (PROGN (SETQ OLDNAME (LISPERROR "FILE NOT FOUND" OLDNAME T)) (GO RETRY)))))))))
)

(\TCPFTP.CONNECT
(LAMBDA (DEVICE TCPFTPCON DIRECTORY) (* ejs%: "24-Jun-85 17:10") (LET ((DIRECTORYNAME (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY) (\TCPFTP.GET.OSTYPE DEVICE)))) (COND ((NEQ 0 (NCHARS DIRECTORYNAME)) (SELECTQ (ARPACMD TCPFTPCON "CWD" DIRECTORYNAME (QUOTE (200 250 450 550))) ((200 250) T) NIL)) (T (* The user specified no connect directory. We'll have to assume he or she meant his or her own login directory, whose name we can't even accurately guess. Thus, we leave it at this) T))))
)

(\TCPFTP.OPENFILE
  [LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE)          (* ; "Edited 22-Mar-89 22:31 by welch")
    (DECLARE (GLOBALVARS TCP.DEFAULTFILETYPE TCP.USE.STANDARD.EOL TCPFTP.EOL.CONVENTION 
                        TCPFTP.DEFAULT.FILETYPES))
    (LET* ((HOST (fetch (FDEV DEVICENAME) of DEVICE))
           (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE))
           [FILENAME (COND
                        ((EQ OSTYPE 'INTERLISP)
                         (PACKFILENAME.STRING 'HOST NIL 'BODY NAME))
                        (T (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY NAME)
                                  OSTYPE]
           (FILENAME.EXTENSION (FILENAMEFIELD FILENAME 'EXTENSION))
           (TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))
           (TYPE (OR (CADR (FASSOC 'TYPE PARAMETERS))
                     (CDR (FASSOC FILENAME.EXTENSION TCPFTP.DEFAULT.FILETYPES))
                     (CDR (FASSOC (U-CASE FILENAME.EXTENSION)
                                 TCPFTP.DEFAULT.FILETYPES))
                     TCP.DEFAULTFILETYPE))
           DATASTREAMEVENT DATASTREAM CODE FTPCMD STREAMDEV)
          (SELECTQ TYPE
              (TEXT (ARPACMD TCPFTPCON "TYPE" "A N" 200))
              (ARPACMD TCPFTPCON "TYPE" "L 8" 200))
          (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON (COND
                                                                               ((EQ ACCESS
                                                                                    'OUTPUT)
                                                                                'APPEND)
                                                                               (T ACCESS))
                                       T))
          (BLOCK)
          (PROG NIL
            LOOP
                (SETQ FTPCMD (SELECTQ ACCESS
                                 (INPUT '"RETR")
                                 (OUTPUT '"STOR")
                                 (APPEND '"APPE")
                                 (ERROR "ACCESS must be one of INPUT, OUTPUT, or APPEND" ACCESS)))
                [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON FTPCMD FILENAME
                                               '(125 150 226 250 425 426 450 451 550]
                (SELECTQ CODE
                    ((125 150) 

         (* * Here we go)

                         (COND
                            ([SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION
                                               DEVICE TCPFTPCON DATASTREAMEVENT
                                               (COND
                                                  ((EQ ACCESS 'OUTPUT)
                                                   'APPEND)
                                                  (T ACCESS]
                             (replace (STREAM ENDOFSTREAMOP) of DATASTREAM
                                with (FUNCTION \TCPFTP.ENDOFSTREAMOP))
                             (replace (STREAM FULLFILENAME) of DATASTREAM with NAME)
                             [replace (STREAM EOLCONVENTION) of DATASTREAM
                                with (COND
                                            (TCP.USE.STANDARD.EOL CRLF.EOLC)
                                            (T (OR TCPFTP.EOL.CONVENTION (SELECTQ OSTYPE
                                                                             (UNIX LF.EOLC)
                                                                             (TOPS-20 CRLF.EOLC)
                                                                             CR.EOLC]
                             (STREAMPROP DATASTREAM 'TYPE TYPE)
                             (replace (TCPDATASTREAM TCPFTPCON) of DATASTREAM with 
                                                                                            TCPFTPCON
                                    )
                             (SETQ STREAMDEV (fetch (STREAM DEVICE) of DATASTREAM))
                             (replace (FDEV GETFILENAME) of STREAMDEV
                                with (FUNCTION NILL))
                             (replace (FDEV GETFILEINFO) of STREAMDEV
                                with (FUNCTION \TCPFTP.GETFILEINFO))
                             (STREAMADDPROP DATASTREAM 'AFTERCLOSE (FUNCTION 
                                                                    \TCPFTP.TRANSFER.COMPLETE))
                             (STREAMADDPROP DATASTREAM 'BEFORECLOSE (FUNCTION \TCPFTP.READ.UNTIL.EOF)
                                    )
                             (RETURN DATASTREAM))
                            (T (ERROR "Couldn't open data connection to remote TCPFTP server"))))
                    (425                                     (* The foreign port is busy)
                         (PROMPTPRINT "TCPFTP: Please wait; the remote ftp server is busy.")
                         (DEL.PROCESS (CAR DATASTREAMEVENT))
                         (DISMISS 5000)
                         [SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION
                                                TCPFTPCON
                                                (COND
                                                   ((EQ ACCESS 'OUTPUT)
                                                    'APPEND)
                                                   (T ACCESS]
                         (BLOCK)
                         (GO LOOP))
                    ((450 550) 
                         (DEL.PROCESS (CAR DATASTREAMEVENT))
                         (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                         NIL)
                    (FTPHELP CODE])

(\TCPFTP.CLOSE
(LAMBDA (DEVICE) (* ejs%: "23-Apr-85 18:41") (* * This needs work) (PROG ((DEVINFO (fetch (FDEV DEVICEINFO) of DEVICE))) (AND (OPENP (fetch (TCPFTPCON TCPOUT) of DEVINFO) (QUOTE OUTPUT)) (CLOSEF (fetch (TCPFTPCON TCPOUT) of DEVINFO))) (AND (OPENP (fetch (TCPFTPCON TCPIN) of DEVINFO) (QUOTE INPUT)) (CLOSEF (fetch (TCPFTPCON TCPIN) of DEVINFO)))))
)

(\TCPFTP.FLUSH
(LAMBDA (DEVICE) (* ejs%: "23-Apr-85 18:56") (* * This needs work) (PROG ((INSTREAM (fetch (TCPFTPCON TCPIN) of (fetch (FDEV DEVICEINFO) of DEVICE)))) (COND ((READP INSTREAM) (until (NOT (READP INSTREAM)) do (BIN INSTREAM))))))
)

(\TCPFTP.INIT
(LAMBDA NIL (* ejs%: "10-Apr-85 19:25") (\DEFINEDEVICE NIL (create FDEV DEVICENAME _ (QUOTE TCPFTP) HOSTNAMEP _ (FUNCTION \TCPFTP.HOSTNAMEP) EVENTFN _ (FUNCTION \TCPFTP.EVENTFN))))
)

(SET.TCP.EOL.CONVENTION
  [LAMBDA (EOLTYPE)                                      (* ; "Edited 22-Mar-89 22:31 by welch")
                                                             (* ; "Sets the EOL convention to use")
    (DECLARE (GLOBALVARS TCP.USE.STANDARD.EOL TCPFTP.EOL.CONVENTION))
    (SELECTQ EOLTYPE
        (CR (SETQ TCP.USE.STANDARD.EOL NIL)
            (SETQ TCPFTP.EOL.CONVENTION CR.EOLC))
        (LF (SETQ TCP.USE.STANDARD.EOL NIL)
            (SETQ TCPFTP.EOL.CONVENTION LF.EOLC))
        (CRLF (SETQ TCP.USE.STANDARD.EOL NIL)
              (SETQ TCPFTP.EOL.CONVENTION CRLF.EOLC))
        (OS (SETQ TCP.USE.STANDARD.EOL NIL)
            (SETQ TCPFTP.EOL.CONVENTION NIL))
        (SETQ TCP.USE.STANDARD.EOL T])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS TCPDATASTREAM ((TCPCONTROLDEVICE (fetch (STREAM F3) of DATUM)
                                     (replace (STREAM F3) of DATUM with NEWVALUE))
                              (SEENEOS (fetch (STREAM F4) of DATUM)
                                     (replace (STREAM F4) of DATUM with NEWVALUE))
                              (TCPFTPCON (fetch (STREAM F5) of DATUM)
                                     (replace (STREAM F5) of DATUM with NEWVALUE))))

(RECORD TCPFTPCON (TCPIN TCPOUT DATASTREAM BUSY? IDLETIMER GENERATEFILESDIRECTORY))
)

(* "END EXPORTED DEFINITIONS")

)

(ADDTOVAR TCPFTP.DEFAULT.FILETYPES (NIL . TEXT)
                                       (DFASL . BINARY)
                                       (dfasl . BINARY)
                                       (LCOM . BINARY)
                                       (lcom . BINARY)
                                       (DCOM . BINARY)
                                       (dcom . BINARY)
                                       (LISP . TEXT)
                                       (lisp . TEXT)
                                       (LSP . TEXT)
                                       (lsp . TEXT)
                                       (RST . BINARY)
                                       (rst . BINARY)
                                       (BIN . BINARY)
                                       (bin . BINARY))

(RPAQ? TCP.DEFAULTFILETYPE 'BINARY)

(RPAQ? TCP.USE.STANDARD.EOL T)

(RPAQ? \TCPFTP.DEVICES )

(RPAQ? \TCPFTP.CLEANUP.PROCESS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCPFTP.DEVICES \TCPFTP.CLEANUP.PROCESS TCP.DEFAULTFILETYPE TCP.USE.STANDARD.EOL)
)



(* ;; "Data connection handling")

(DEFINEQ

(\TCP.BYE
(LAMBDA (HOST) (* ejs%: "15-Nov-86 15:05") (LET* ((DEVICE (\GETDEVICEFROMNAME HOST NIL T)) (CONNECTIONS (AND DEVICE (fetch (FDEV DEVICEINFO) of DEVICE)))) (bind INSTREAM for TCPFTPCON in CONNECTIONS do (SETQ INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (while (AND (OPENP INSTREAM (QUOTE INPUT)) (READP INSTREAM)) do (BIN INSTREAM)) (NLSETQ (ARPACMD TCPFTPCON "QUIT" NIL (QUOTE (221 500)))) (CLOSEF? (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) (CLOSEF? INSTREAM) (CLOSEF? (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) T) (replace (FDEV DEVICEINFO) of DEVICE with NIL)))
)

(\TCPFTP.MAYBE.ABORT
  [LAMBDA (DATASTREAM)                                   (* ; "Edited 18-Mar-89 13:43 by welch")
    (LET* ((TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM))
           (TCPOUTSTREAM (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
          (STREAMPROP DATASTREAM 'BEFORECLOSE NIL)
          (COND
             ((AND (NOT (fetch (TCPDATASTREAM SEENEOS) of DATASTREAM))
                   (OPENP DATASTREAM 'INPUT))
              (TCP.CLOSE.SENDER (TCP.OTHER.STREAM DATASTREAM))
              (BLOCK)
              (BOUT TCPOUTSTREAM 244)
              (BOUT TCPOUTSTREAM 242)
              (TCP.URGENT.MARK TCPOUTSTREAM)
              (ARPACMD TCPFTPCON "ABOR" NIL '(226 426 250])

(\TCPFTP.DATA.CLOSED
(LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "28-Jul-86 14:03") (LET* ((STREAM (OR INSTREAM OUTSTREAM))) (replace (STREAM ACCESS) of STREAM with NIL)))
)

(\TCPFTP.OPEN.DATA.CONNECTION
(LAMBDA (TCPFTPCON ACCESS EVENT FOR.FILE.TRANSFER) (* ejs%: "26-Sep-86 18:27") (DECLARE (GLOBALVARS \TCPFTP.DATACONNECTION.LOCK)) (* * Tell the FTP control connection on what port we're expecting the data connection to made, and try up to five times to accept a connection. Each time, select a new port (this hopefully a workaround to a Unix bug in which ports sometimes tend to appear busy for 2 minute timeout intervals)) (WITH.MONITOR \TCPFTP.DATACONNECTION.LOCK (bind PORT STREAM for I from 1 to 5 do (SETQ PORT (\TCP.SELECT.PORT)) (ARPACMD TCPFTPCON "PORT" (\TCPFTP.PORT.STRING PORT) (QUOTE (200))) (SETQ STREAM (TCP.OPEN NIL NIL PORT (QUOTE PASSIVE) ACCESS NIL (COND (FOR.FILE.TRANSFER (CONSTANT (BQUOTE (MAXSEG %, BYTESPERPAGE WHENCLOSEDFN \TCPFTP.DATA.CLOSED))))))) (COND (STREAM (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with STREAM) (RETURN))) finally (* * We give up. Place a NIL in the datastream field so the client who was trying to accept the data connection will realize we couldn't succeed) (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL)) (AND (TYPENAMEP EVENT (QUOTE EVENT)) (NOTIFY.EVENT EVENT)) (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)))
)

(\TCPFTP.PORT.STRING
(LAMBDA (PORT) (* ejs%: "26-Apr-85 11:54") (* * Returns "h1,h2,h3,h4,p1,p3" corresponding to bytes of local IP host and PORT for port command) (LET ((IPADDRESS (\LOCAL.IP.ADDRESS))) (CONCAT (LOADBYTE IPADDRESS 24 8) "," (LOADBYTE IPADDRESS 16 8) "," (LOADBYTE IPADDRESS 8 8) "," (LOADBYTE IPADDRESS 0 8) "," (LOADBYTE PORT 8 8) "," (LOADBYTE PORT 0 8))))
)

(\TCPFTP.SPAWN.DATACONNECTION
(LAMBDA (TCPFTPCON ACCESS FOR.FILE.TRANSFER) (* ejs%: "26-Sep-86 19:21") (* * Called from TCPFTP device methods like \TCPFTP.OPENFILE. Spawns a process to wait for the server program to open a data connection to us. Returns a CONS consisting of the spawned process handle and an event which will be notified when the server has connected to us. This function MUST be called prior to any TCPFTP operations which would cause the server to try to open a data connection to us (otherwise, the server might try to open the connection before we're prepared to accept it)) (LET* ((EVENT (CREATE.EVENT)) (PROCESS (ADD.PROCESS (BQUOTE (\TCPFTP.OPEN.DATA.CONNECTION (QUOTE %, TCPFTPCON) (QUOTE %, ACCESS) %, EVENT %, FOR.FILE.TRANSFER))))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (PROCESS INSTREAM OUTSTREAM) (DEL.PROCESS PROCESS) (* CLOSEF? INSTREAM) (* CLOSEF? OUTSTREAM) NIL)) PROCESS (fetch (TCPFTPCON TCPIN) of TCPFTPCON) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (CONS PROCESS EVENT)))
)

(\TCPFTP.READ.UNTIL.EOF
  [LAMBDA (DATASTREAM)                                   (* ; "Edited 20-Jun-89 19:41 by welch")

(* ;;; "This function is used to avoid possible deadlock in the case where the stream is opened and closed immediately. ")

    (PROG ((TCB (fetch (TCPSTREAM TCB) of DATASTREAM))
           (TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM)))
          (WITH.MONITOR \TCPFTP.DATACONNECTION.LOCK
              (if (NOT (EOFP DATASTREAM))
                  then (while (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))
                              do (\TCP.GET.SEGMENT DATASTREAM)) 

                        (* ;; "read to the end of the file.")

                        (while (NOT (EOFP DATASTREAM)) do (BIN DATASTREAM))))])

(\TCPFTP.TRANSFER.COMPLETE
  [LAMBDA (DATASTREAM)                                   (* ; "Edited 24-May-89 14:12 by welch")
    (LET ((TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM)))
         (STREAMPROP DATASTREAM 'AFTERCLOSE NIL)
         (COND
            ((AND TCPFTPCON (NOT (fetch (TCPDATASTREAM SEENEOS) of DATASTREAM)))
             [COND
                ((OPENP DATASTREAM 'INPUT)
                 (TCP.CLOSE.SENDER (TCP.OTHER.STREAM DATASTREAM]
             (replace (TCPDATASTREAM SEENEOS) of DATASTREAM with T)
             (replace (TCPDATASTREAM TCPCONTROLDEVICE) of DATASTREAM with NIL)
             (replace (TCPDATASTREAM TCPFTPCON) of DATASTREAM with NIL)
             (\TCPFTP.RELEASE.CONNECTION TCPFTPCON])

(\TCPFTP.WAIT.FOR.DATACONNECTION
(LAMBDA (DEVICE TCPFTPCON PROCESS.AND.EVENT ACCESS) (* ejs%: "26-Sep-86 18:30") (* * EVENT is a cons of PROCESS and a real event. PROCESS is the process trying to open the connection; EVENT is an event which is notified when the process succeeds or fails to open the connection to the server) (LET (STREAM) (AWAIT.EVENT (CDR PROCESS.AND.EVENT) 120000) (COND ((NULL (SETQ STREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))) (* * A NIL in this field means the local client code was unable to open the connection to the server program.) NIL) ((OPENP STREAM ACCESS) (replace (TCPDATASTREAM TCPCONTROLDEVICE) of STREAM with DEVICE) STREAM))))
)

(\TCPFTP.DELETE.CONNECTION
(LAMBDA (TCPFTPCON DEVICE SENDBYE) (* ejs%: "15-Nov-86 15:09") (LET ((INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) (COND (SENDBYE (NLSETQ (ARPACMD TCPFTPCON "BYE" NIL (QUOTE (221 500)))))) (COND (INSTREAM (DEL.PROCESS (fetch (TCP.CONTROL.BLOCK TCB.PROCESS) of (fetch (TCPSTREAM TCB) of INSTREAM))))) (replace (FDEV DEVICEINFO) of DEVICE with (DREMOVE TCPFTPCON (fetch (FDEV DEVICEINFO) of DEVICE)))))
)
)

(RPAQ? \TCPFTP.DATACONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Data Connection Lock"))

(RPAQ? \TCPFTP.CONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Connection Lock"))

(RPAQ? \TCPFTP.IDLE.TIMEOUT (TIMES 10 60 1000))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCPFTP.DATACONNECTION.LOCK \TCPFTP.CONNECTION.LOCK \TCPFTP.IDLE.TIMEOUT)
)

(FILESLOAD (SYSLOAD)
       TCPNAMES TCP)

(\TCPFTP.INIT)

(RPAQQ TCPFTP.DEFAULT.FILETYPES
       ((NIL . TEXT)
        (DFASL . BINARY)
        (dfasl . BINARY)
        (LCOM . BINARY)
        (lcom . BINARY)
        (DCOM . BINARY)
        (dcom . BINARY)
        (LISP . TEXT)
        (lisp . TEXT)
        (LSP . TEXT)
        (lsp . TEXT)
        (RST . BINARY)
        (rst . BINARY)
        (BIN . BINARY)
        (bin . BINARY)
        (TXT . TEXT)
        (txt . TEXT)
        (TEXT . TEXT)
        (text . TEXT)
        (c . TEXT)
        (h . TEXT)
        (o . BINARY)
        (TEDIT . BINARY)
        (tedit . BINARY)
        (DISPLAYFONT . BINARY)
        (WD . BINARY)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS TCPFTP COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1900 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4143 7185 (ARPACMD 4153 . 5446) (FTPHELP 5448 . 5565) (CMDREADCODE 5567 . 5671) (
CMDREAD 5673 . 5800) (DISCARDLINE 5802 . 6196) (GETLINE 6198 . 6484) (\TCPFTP.INPUT 6486 . 7041) (
TELNET.EOL 7043 . 7183)) (7526 40072 (\TCPFTP.CONTROL.CLOSED 7536 . 8004) (\TCPFTP.GET.OSTYPE 8006 . 
8252) (\TCPFTP.EVENTFN 8254 . 8834) (\TCPFTP.HOSTNAMEP 8836 . 11823) (\GET.TCPFTP.CONNECTION 11825 . 
12570) (\TCPFTP.OPEN.CONNECTION 12572 . 13893) (\TCPFTP.ASSURE.CLEANUP 13895 . 14215) (\TCPFTP.CLEANUP
 14217 . 15408) (\TCPFTP.RELEASE.CONNECTION 15410 . 15723) (\TCPFTP.LOGIN 15725 . 17870) (
\TCPFTP.DELETEFILE 17872 . 18309) (\TCPFTP.DIRECTORYNAMEP 18311 . 18965) (\TCPFTP.ENDOFSTREAMOP 18967
 . 19118) (\TCPFTP.GENERATEFILES 19120 . 22881) (\TCPFTP.GENERATENEXTFILE 22883 . 27772) (
\TCPFTP.GETFILENAME 27774 . 30946) (\TCPFTP.GETFILEINFO 30948 . 31131) (\TCPFTP.SETFILEINFO 31133 . 
31257) (\TCPFTP.RENAMEFILE 31259 . 32187) (\TCPFTP.CONNECT 32189 . 32726) (\TCPFTP.OPENFILE 32728 . 
38498) (\TCPFTP.CLOSE 38500 . 38868) (\TCPFTP.FLUSH 38870 . 39118) (\TCPFTP.INIT 39120 . 39320) (
SET.TCP.EOL.CONVENTION 39322 . 40070)) (41953 48826 (\TCP.BYE 41963 . 42548) (\TCPFTP.MAYBE.ABORT 
42550 . 43295) (\TCPFTP.DATA.CLOSED 43297 . 43468) (\TCPFTP.OPEN.DATA.CONNECTION 43470 . 44677) (
\TCPFTP.PORT.STRING 44679 . 45060) (\TCPFTP.SPAWN.DATACONNECTION 45062 . 46078) (
\TCPFTP.READ.UNTIL.EOF 46080 . 46897) (\TCPFTP.TRANSFER.COMPLETE 46899 . 47705) (
\TCPFTP.WAIT.FOR.DATACONNECTION 47707 . 48384) (\TCPFTP.DELETE.CONNECTION 48386 . 48824)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPFTPSRV b/obsolete/tcp/TCPFTPSRV
new file mode 100644
index 00000000..1e95bbcd
--- /dev/null
+++ b/obsolete/tcp/TCPFTPSRV
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "13-Sep-90 15:07:59" {DSK}<LISPFILES>TCP>TCPFTPSRV.;6 55339  

      changes to%:  (FNS TCPFTP.SERVER.MERGE.PATHNAMES TCPFTP.SERVER.PATH TCPFTP.SERVER.LIST 
                         TCPFTP.SERVER.RETRIEVE)

      previous date%: "11-Sep-90 13:34:33" {DSK}<LISPFILES>TCP>TCPFTPSRV.;5)


(* ; "
Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPFTPSRVCOMS)

(RPAQQ TCPFTPSRVCOMS
       ((FNS TCPFTP.SERVER TCPFTP.SERVER.ABORTED TCPFTP.SERVER.ACCOUNT TCPFTP.SERVER.APPEND 
             TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTP.SERVER.COMMAND.LOOP 
             TCPFTP.SERVER.CONNECTED.INFO TCPFTP.SERVER.DELETE TCPFTP.SERVER.DIRECTORY 
             TCPFTP.SERVER.EXIT TCPFTP.SERVER.IDLE.INFO TCPFTP.SERVER.LIST 
             TCPFTP.SERVER.MERGE.PATHNAMES TCPFTP.SERVER.MODE TCPFTP.SERVER.OPEN.DATA.CONNECTION 
             TCPFTP.SERVER.PARSE.PORT TCPFTP.SERVER.PASSWORD TCPFTP.SERVER.PATH TCPFTP.SERVER.PORT 
             TCPFTP.SERVER.PROCESS TCPFTP.SERVER.RENAME.FROM TCPFTP.SERVER.RENAME.TO 
             TCPFTP.SERVER.RESPONSE TCPFTP.SERVER.RETRIEVE TCPFTP.SERVER.RETURN.FILE 
             TCPFTP.SERVER.STORE TCPFTP.SERVER.STRUCTURE TCPFTP.SERVER.TYPE TCPFTP.SERVER.USER 
             TCPFTP.SERVER.VERBOSE.LIST TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTP.UNIX.LS.DATE)
        (INITVARS (TCPFTP.SERVER.HERALD.STRING "Venue Medley FTP Service 1.0 at your service")
               (TCPFTP.SERVER.USE.TOPS20.SYNTAX NIL)
               (TCPFTP.SERVER.RETRYCOUNT 5))
        (GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX 
               TCPFTP.SERVER.RETRYCOUNT)
        (FILES (SYSLOAD)
               TCPFTP)))
(DEFINEQ

(TCPFTP.SERVER
  [LAMBDA (PORT DEFAULT.FILE.PATH)                           (* ; "Edited 24-Aug-87 17:57 by scp")
          
          (* * This is the TCP-based FTP server top-level)

    (ADD.PROCESS `(TCPFTP.SERVER.PROCESS ,PORT ,DEFAULT.FILE.PATH) 'RESTARTABLE 'HARDRESET])

(TCPFTP.SERVER.ABORTED
  [LAMBDA (INSTREAM OUTSTREAM)                               (* ejs%: "20-Mar-86 19:53")
    (TCPFTP.SERVER.EXIT INSTREAM OUTSTREAM])

(TCPFTP.SERVER.ACCOUNT
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:40")
          
          (* * This function parses USER commands)

    (LET ((ACCT (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL)))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG ACCT T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (TCPFTP.SERVER.RESPONSE 230 "You sure are formal!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.APPEND
  [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH)       (* ejs%: "24-Mar-86 14:07")
          
          (* * This function parses USER commands)

    (LET*
     [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL))
      (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
      (TRUENAME (CAR (NLSETQ (OR (INFILEP PACKED.FILENAME)
                                 (OUTFILEP PACKED.FILENAME]
     (COND
        (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
     (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
     (COND
        [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'APPEND NIL
                                                        `((TYPE %, TYPE]
                       (COND
                          [FILESTREAM
                           (TCPFTP.SERVER.RESPONSE 150 (CONCAT 
                                                             "Opening data connection for append to "
                                                              (FULLNAME FILESTREAM))
                                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                           (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T
                                                    )))
                                (COND
                                   (DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM
                                                  with (FUNCTION (LAMBDA (STREAM)
                                                                   (ERROR!]
                                          (RESETLST (RESETSAVE (COND
                                                                  ((EQ TYPE 'BINARY)
                                                                   (COPYBYTES DATASTREAM FILESTREAM))
                                                                  (T (COPYCHARS DATASTREAM FILESTREAM
                                                                            )))
                                                           (LIST [FUNCTION (LAMBDA (FILESTREAM 
                                                                                          TCPFTPCON)
                                                                             (CLOSEF? FILESTREAM)
                                                                             (
                                                                  TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                              TCPFTPCON)
                                                                             (TCPFTP.SERVER.RESPONSE
                                                                              226 
                                                                             "Data transfer complete"
                                                                              (fetch (TCPFTPCON
                                                                                      TCPOUT)
                                                                                 of TCPFTPCON]
                                                                 FILESTREAM TCPFTPCON]
                          (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME)
                                    (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
        (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME)
                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.CLOSE.DATA.CONNECTION
  [LAMBDA (TCPFTPCON)                                        (* ejs%: "20-Mar-86 17:53")
    (LET ((DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))
          (EVENT (fetch (TCPFTPCON BUSY?) of TCPFTPCON)))
         (CLOSEF? DATASTREAM)
         (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL)
         (replace (TCPFTPCON BUSY?) of TCPFTPCON with NIL)
         (NOTIFY.EVENT EVENT)
         T])

(TCPFTP.SERVER.COMMAND.LOOP
  [LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM PATH)
                                                           (* ; "Edited 31-Aug-90 17:15 by gadener")
    (DECLARE (SPECVARS TCPFTPCON COMMAND))
    (LET ([COMMAND.RDTBL (DEFERREDCONSTANT (PROG [(R (COPYREADTABLE 'ORIG]
                                                 (SETBRK NIL NIL R)
                                                 (SETSYNTAX '%% 'OTHER R)
                                                 (SETSEPR '(13 10 31 32)
                                                        NIL R)
                                                 (RETURN R]
          (TCPFTPCON (create TCPFTPCON
                            TCPIN _ CONTROL.INPUT.STREAM
                            TCPOUT _ CONTROL.OUTPUT.STREAM))
          (TYPE TCP.DEFAULTFILETYPE)
          RENAME.FROM.FILE LAST.COMMAND USERPORT)
         (OR PATH (SETQ PATH "{DSK}<LISPFILES>"))
         (while (AND (OPENP CONTROL.INPUT.STREAM 'INPUT)
                         (OPENP CONTROL.OUTPUT.STREAM 'OUTPUT)
                         (NOT (EOFP CONTROL.INPUT.STREAM)))
            first [PROCESSPROP (THIS.PROCESS)
                             'NAME
                             (CONCAT "FTP#" (\IP.ADDRESS.TO.STRING (fetch (TCP.CONTROL.BLOCK
                                                                               TCB.DST.HOST)
                                                                      of (fetch (TCPSTREAM
                                                                                         TCB)
                                                                                of 
                                                                                 CONTROL.INPUT.STREAM
                                                                                    ]
            do (LET [(COMMAND (U-CASE (CAR (NLSETQ (READ CONTROL.INPUT.STREAM COMMAND.RDTBL]
                        [COND
                           ((AND (OPENP CONTROL.INPUT.STREAM 'INPUT)
                                 (NOT (EOFP CONTROL.INPUT.STREAM)))
                            (COND
                               ([NOT (FMEMB COMMAND '(QUIT REIN ABOR NOOP NIL]
                                (BIN CONTROL.INPUT.STREAM]   (* Advance past the space preceding 
                                                           the argument)
                        (COND
                           (FTPDEBUGFLG (printout FTPDEBUGLOG T "> " COMMAND " ")))
                        (SELECTQ COMMAND
                            (USER (TCPFTP.SERVER.USER TCPFTPCON COMMAND.RDTBL))
                            (PASS (TCPFTP.SERVER.PASSWORD TCPFTPCON COMMAND.RDTBL))
                            (ACCT (TCPFTP.SERVER.ACCOUNT TCPFTPCON COMMAND.RDTBL))
                            (CWD (SETQ PATH (OR (TCPFTP.SERVER.PATH TCPFTPCON COMMAND.RDTBL PATH)
                                                PATH)))
                            (PWD (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Default pathname is " PATH)
                                        (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
                            (PORT (SETQ USERPORT (OR (TCPFTP.SERVER.PORT TCPFTPCON COMMAND.RDTBL)
                                                     USERPORT)))
                            (TYPE (SETQ TYPE (OR (TCPFTP.SERVER.TYPE TCPFTPCON COMMAND.RDTBL)
                                                 TYPE)))
                            (MODE (TCPFTP.SERVER.MODE TCPFTPCON COMMAND.RDTBL))
                            (STRU (TCPFTP.SERVER.STRUCTURE TCPFTPCON COMMAND.RDTBL))
                            (* ;; "Depending on the COMMAND (LIST -> verbose), TCPFTP.SERVER.LIST will return a verbose listing or a simple list of file names ")
                            ((NLST LIST)                     (* ; 
                                         "Depending on the COMMAND, TCPFTP.SERVER.LIST will return")
                                 (TCPFTP.SERVER.LIST TCPFTPCON COMMAND.RDTBL USERPORT PATH 
                                        COMMAND))
                            (RETR (TCPFTP.SERVER.RETRIEVE TCPFTPCON COMMAND.RDTBL USERPORT TYPE 
                                         PATH))
                            (STOR (TCPFTP.SERVER.STORE TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH
                                         ))
                            (APPE (TCPFTP.SERVER.APPEND TCPFTPCON COMMAND.RDTBL USERPORT TYPE 
                                         PATH))
                            (DELE (TCPFTP.SERVER.DELETE TCPFTPCON COMMAND.RDTBL PATH))
                            (RNFR (SETQ RENAME.FROM.FILE (TCPFTP.SERVER.RENAME.FROM TCPFTPCON 
                                                                COMMAND.RDTBL PATH)))
                            (RNTO (COND
                                     ((EQ LAST.COMMAND 'RNFR)
                                      (TCPFTP.SERVER.RENAME.TO TCPFTPCON COMMAND.RDTBL PATH 
                                             RENAME.FROM.FILE))
                                     (T (TCPFTP.SERVER.RESPONSE 503 
                                        "I need a RNFR command immediately preceding a RNTO command."
                                               CONTROL.OUTPUT.STREAM))))
                            (REIN (DISCARDLINE CONTROL.INPUT.STREAM)
                                  (TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON)
                                  (TCPFTP.SERVER.RESPONSE 220 "Go ahead" CONTROL.OUTPUT.STREAM))
                            (QUIT (DISCARDLINE CONTROL.INPUT.STREAM)
                                  (TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON)
                                  (TCPFTP.SERVER.RESPONSE 221 "It's been real" 
                                         CONTROL.OUTPUT.STREAM)
                                  (RETURN))
                            (NOOP (TCPFTP.SERVER.RESPONSE 200 "I'm still here" 
                                         CONTROL.OUTPUT.STREAM))
                            (NIL                             (* Error reading from control stream)
                                 (ERROR!))
                            (PROGN (DISCARDLINE CONTROL.INPUT.STREAM)
                                   (TCPFTP.SERVER.RESPONSE 502 (CONCAT "Unrecognized command " 
                                                                          COMMAND)
                                          CONTROL.OUTPUT.STREAM)))
                        (SETQ LAST.COMMAND COMMAND])

(TCPFTP.SERVER.CONNECTED.INFO
  [LAMBDA (PROCESS BUTTON)                                   (* ejs%: "21-Mar-86 17:07")
    [PROMPTPRINT "TCPFTP server connected to " (IPHOSTNAME (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST)
                                                              of (fetch (TCPSTREAM TCB) of 
                                                                                 CONTROL.INPUT.STREAM
                                                                        ]
    (COND
       ((EQ BUTTON 'MIDDLE)
        (COND
           ((AND (BOUNDP 'TCPFTPCON)
                 (fetch (TCPFTPCON BUSY?) of TCPFTPCON))
            (printout PROMPTWINDOW T "  Server is busy; last command was "
                   (OR (AND (BOUNDP 'COMMAND)
                            COMMAND)
                       "???")))
           ((AND (BOUNDP COMMAND)
                 COMMAND)
            (printout PROMPTWINDOW T "  Last command was " COMMAND])

(TCPFTP.SERVER.DELETE
  [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH)                     (* ejs%: " 7-Apr-86 11:42")
          
          (* * This function parses USER commands)

    (LET* ((FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T T))
           TRUENAME)
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             [PACKED.FILENAME (COND
                                 ([SETQ TRUENAME (CAR (NLSETQ (DELFILE PACKED.FILENAME]
                                  (TCPFTP.SERVER.RESPONSE 250
                                         (CONCAT "Deleted " (COND
                                                               (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                                (REPACKFILENAME.STRING
                                                                 (PACKFILENAME.STRING 'HOST NIL
                                                                        'BODY TRUENAME)
                                                                 'TOPS-20))
                                                               (T TRUENAME)))
                                         (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
                                 (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't delete file " 
                                                                       TRUENAME)
                                           (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
             (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.DIRECTORY
  [LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND)
                                                           (* ; "Edited 30-Aug-90 17:47 by gadener")

         (* * This function parses USER commands)

    (LET* [(PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                        RDTBL))
           (FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG PATH T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory of " PATH 
                                                 " [" (LENGTH FILES)
                                                 " file name(s)]")
                 (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
          (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT)))
               (COND
                  (DATASTREAM (for FILE in FILES
                                 do (PRIN1 [COND
                                                  (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                   (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                           'HOST NIL 'BODY FILE)
                                                          'TOPS-20))
                                                  (T (TCPFTP.SERVER.RETURN.FILE FILE DEFAULT.PATH
                                                            'INFO]
                                               DATASTREAM)
                                       (TERPRI DATASTREAM) finally (
                                                                TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                        TCPFTPCON))
                         (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch
                                                                                   (TCPFTPCON TCPOUT)
                                                                                     of TCPFTPCON
                                                                                   ])

(TCPFTP.SERVER.EXIT
  [LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM)       (* ejs%: "20-Mar-86 19:52")
    (CLOSEF? CONTROL.OUTPUT.STREAM)
    (CLOSEF? CONTROL.INPUT.STREAM])

(TCPFTP.SERVER.IDLE.INFO
  [LAMBDA (PROCESS BUTTON)                                   (* ejs%: "21-Mar-86 16:58")
    (PROMPTPRINT "Idle TCPFTP server"])

(TCPFTP.SERVER.LIST
  [LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND)
                                                           (* ; "Edited 13-Sep-90 14:41 by gadener")

         (* * This function parses USER commands)

    (LET* ((PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                        RDTBL))
           [FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T]
           (NFILES (LENGTH FILES)))
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG PATH T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory " 
                                                 DEFAULT.PATH " [" NFILES " file name(s)]")
                 (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
          (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT)))
               (COND
                  (DATASTREAM (for FILE in FILES
                                 do (PRIN1 (COND
                                                  (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                   (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                           'HOST NIL 'BODY FILE)
                                                          'TOPS-20))
                                                  (T (TCPFTP.SERVER.RETURN.FILE FILE DEFAULT.PATH
                                                            COMMAND)))
                                               DATASTREAM)
                                       (TERPRI DATASTREAM) finally (
                                                                TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                        TCPFTPCON))
                         (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch
                                                                                   (TCPFTPCON TCPOUT)
                                                                                     of TCPFTPCON
                                                                                   ])

(TCPFTP.SERVER.MERGE.PATHNAMES
  [LAMBDA (NAME DEFAULT.PATH NODEVICE.IF.LOCAL NOVERSION.IF.LOCAL DIRFLG)
                                                           (* ; "Edited 13-Sep-90 14:16 by gadener")
    (LET* ((NAMEFIELDS (UNPACKFILENAME.STRING NAME NIL DIRFLG))
           (DEFAULTFIELDS (UNPACKFILENAME.STRING DEFAULT.PATH NIL DIRFLG))
           [HOST (OR (LISTGET NAMEFIELDS 'HOST)
                     (LISTGET DEFAULTFIELDS 'HOST]
           [HOSTSPECIFIED (NOT (NULL (LISTGET NAMEFIELDS 'HOST]
           DIRECTORY1)
          (PACKFILENAME.STRING 'HOST HOST 'DEVICE [COND
                                                     ((AND NODEVICE.IF.LOCAL (EQ HOST 'DSK))
                                                      NIL)
                                                     ((OR (LISTGET NAMEFIELDS 'DEVICE)
                                                          (COND
                                                             (HOSTSPECIFIED NIL)
                                                             (T (LISTGET DEFAULTFIELDS 'DEVICE]
                 'DIRECTORY
                 [COND
                    ((LISTGET NAMEFIELDS 'DIRECTORY))
                    ([COND
                        [(SETQ DIRECTORY1 (LISTGET NAMEFIELDS 'SUBDIRECTORY]
                        ((SETQ DIRECTORY1 (LISTGET NAMEFIELDS 'RELATIVEDIRECTORY]
                     (CL:CONCATENATE 'STRING (LISTGET DEFAULTFIELDS 'DIRECTORY)
                            ">" DIRECTORY1))
                    (HOSTSPECIFIED NIL)
                    (T (LISTGET DEFAULTFIELDS 'DIRECTORY]
                 'NAME
                 (OR (LISTGET NAMEFIELDS 'NAME)
                     (LISTGET DEFAULTFIELDS 'NAME))
                 'EXTENSION
                 (OR (LISTGET NAMEFIELDS 'EXTENSION)
                     (LISTGET DEFAULTFIELDS 'EXTENSION))
                 'VERSION
                 (COND
                    ((AND NOVERSION.IF.LOCAL (EQ HOST 'DSK))
                     NIL)
                    (T (OR (LISTGET NAMEFIELDS 'VERSION)
                           (LISTGET DEFAULTFIELDS 'VERSION])

(TCPFTP.SERVER.MODE
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 15:38")
          
          (* * This function parses USER commands)

    (LET ((MODE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                      RDTBL))
          (RESPONSE.STRING)
          (ERRORFLG))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG MODE T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (SELECTQ MODE
             (S (SETQ RESPONSE.STRING "Now in stream mode"))
             (PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " MODE))
                    (SETQ ERRORFLG T)))
         (COND
            (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
                                                                     of TCPFTPCON))
                   NIL)
            (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.OPEN.DATA.CONNECTION
  [LAMBDA (TCPFTPCON USERPORT FORINPUT)                      (* ejs%: "11-Apr-86 16:09")
          
          (* * This function handles opening data connections and marking said tcp 
          connections as busy)

    (bind (TCB _ (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))
          DATASTREAM for RETRIES from 0 to TCPFTP.SERVER.RETRYCOUNT
       until (SETQ DATASTREAM (TCP.OPEN (COND
                                           (USERPORT (CAR USERPORT))
                                           (T (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of TCB)))
                                     (COND
                                        (USERPORT (CDR USERPORT))
                                        (T (fetch (TCP.CONTROL.BLOCK TCB.DST.PORT) of TCB)))
                                     (SUB1 (fetch (TCP.CONTROL.BLOCK TCB.SRC.PORT) of TCB))
                                     'ACTIVE
                                     (COND
                                        (FORINPUT 'INPUT)
                                        (T 'OUTPUT))
                                     T)) finally (RETURN (COND
                                                            (DATASTREAM (replace (TCPFTPCON 
                                                                                        DATASTREAM)
                                                                           of TCPFTPCON with 
                                                                                           DATASTREAM
                                                                               )
                                                                   (replace (TCPFTPCON BUSY?)
                                                                      of TCPFTPCON with (CREATE.EVENT
                                                                                         ))
                                                             (* TELNET standard EOL convention on 
                                                             DATASTREAMS)
                                                                   (SETFILEINFO DATASTREAM
                                                                          'EOL
                                                                          'CRLF)
                                                                   DATASTREAM)
                                                            (T (TCPFTP.SERVER.RESPONSE
                                                                426 "Couldn't open data connection"
                                                                (fetch (TCPFTPCON TCPOUT)
                                                                   of TCPFTPCON))
                                                               NIL])

(TCPFTP.SERVER.PARSE.PORT
  [LAMBDA (PSTRING)                                          (* ; "Edited 28-May-87 18:00 by jop")

(* ;;; "Parse a port string, in the form 'h1,h2,h3,h4,p1,p2' , where the hx are bytes from an internet host address, and the px are bytes from a 16-bit TCP port number")

    (LET ((IPADDRESS (CREATECELL \FIXP))
          (TCPPORT 0))
         (bind (BYTECOUNTER _ 0)
               (ACCUMULATOR _ 0)
               ERRORFLG for CH instring PSTRING do (COND
                                                      ((EQ CH (CHARCODE %,))
                                                       (COND
                                                          ((IGREATERP BYTECOUNTER 3)
                                                           (SETQ TCPPORT (IPLUS (ITIMES TCPPORT 256)
                                                                                ACCUMULATOR)))
                                                          (T (\PUTBASEBYTE IPADDRESS BYTECOUNTER 
                                                                    ACCUMULATOR)))
                                                       (SETQ ACCUMULATOR 0)
                                                       (add BYTECOUNTER 1))
                                                      [(AND (ILEQ CH (CHARCODE 9))
                                                            (IGEQ CH (CHARCODE 0)))
                                                       (SETQ ACCUMULATOR (IPLUS (IDIFFERENCE
                                                                                 CH
                                                                                 (CHARCODE 0))
                                                                                (ITIMES ACCUMULATOR 
                                                                                       10)))
                                                       (COND
                                                          ((IGREATERP ACCUMULATOR 255)
                                                           (SETQ ERRORFLG T)
                                                           (GO $$OUT]
                                                      (T (SETQ ERRORFLG T)
                                                         (GO $$OUT)))
            finally (COND
                       (ERRORFLG (RETURN NIL))
                       (T (COND
                             ((NEQ BYTECOUNTER 5)
                              (RETURN NIL))
                             (T (RETURN (CONS IPADDRESS (IPLUS (ITIMES TCPPORT 256)
                                                               ACCUMULATOR])

(TCPFTP.SERVER.PASSWORD
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:39")
          
          (* * This function parses USER commands)

    (LET ((PASS (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL)))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG PASS T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (TCPFTP.SERVER.RESPONSE 230 "OK, so you're logged in.  Now what?" (fetch (TCPFTPCON TCPOUT)
                                                                              of TCPFTPCON])

(TCPFTP.SERVER.PATH
  [LAMBDA (TCPFTPCON COMMAND.RDTBL OLDPATH)            (* ; "Edited 13-Sep-90 13:37 by gadener")
    (LET* ((PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                        COMMAND.RDTBL))
           (TRUEPATH (TCPFTP.SERVER.MERGE.PATHNAMES PATH OLDPATH NIL T 'RETURN))

           (* ;; "The last argument, RETURN, makes sure that even though a directory was specified as /a/b/c, we really meant /a/b/c")

           )
          (IF TRUEPATH
              THEN (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Default pathname now " TRUEPATH)
                              (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                    TRUEPATH
            else (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't interpret " NEWPATH 
                                                            " as a pathname")
                            (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                  NIL])

(TCPFTP.SERVER.PORT
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:41")
    (LET* ((PORTSTRING (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                              RDTBL))
           (PARSEDPORT (TCPFTP.SERVER.PARSE.PORT PORTSTRING)))
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG PORTSTRING T)))
          (COND
             (PARSEDPORT (TCPFTP.SERVER.RESPONSE 200 (CONCAT "User port now " PORTSTRING)
                                (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                    PARSEDPORT)
             (T (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't parse port specification " PORTSTRING)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                NIL])

(TCPFTP.SERVER.PROCESS
  [LAMBDA (PORT DEFAULT.FILE.PATH)                           (* ; "Edited 24-Aug-87 17:55 by scp")
          
          (* * This is the TCP-based FTP server top-level)

    (PROCESSPROP (THIS.PROCESS)
           'INFOHOOK
           (FUNCTION TCPFTP.SERVER.IDLE.INFO))
    (LET* ((CONTROL.INPUT.STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.FTP.PORT)
                                        'PASSIVE
                                        'INPUT))
           (CONTROL.OUTPUT.STREAM (TCP.OTHER.STREAM CONTROL.INPUT.STREAM)))
                                                             (* EOL convention -> TELNET Standard)
          (SETFILEINFO CONTROL.OUTPUT.STREAM 'EOL 'CRLF)     (* Say hello quickly)
          (TCPFTP.SERVER.RESPONSE 220 TCPFTP.SERVER.HERALD.STRING CONTROL.OUTPUT.STREAM)
                                                             (* Spawn a new server)
          (ADD.PROCESS (LIST (FUNCTION TCPFTP.SERVER)
                             PORT
                             (KWOTE DEFAULT.FILE.PATH))
                 'RESTARTABLE
                 'HARDRESET)                                 (* Now that we're "established," 
                                                             errors are fatal)
          (PROCESSPROP (THIS.PROCESS)
                 'RESTARTABLE
                 'NO)
          (PROCESSPROP (THIS.PROCESS)
                 'INFOHOOK
                 (FUNCTION TCPFTP.SERVER.CONNECTED.INFO))
          (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM)
                                           (COND
                                              (RESETSTATE (TCPFTP.SERVER.ABORTED CONTROL.INPUT.STREAM 
                                                                 CONTROL.OUTPUT.STREAM))
                                              (T (TCPFTP.SERVER.EXIT CONTROL.INPUT.STREAM 
                                                        CONTROL.OUTPUT.STREAM]
                               CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM))
          (TCPFTP.SERVER.COMMAND.LOOP CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM DEFAULT.FILE.PATH])

(TCPFTP.SERVER.RENAME.FROM
  [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH)                     (* ejs%: "24-Mar-86 14:16")
          
          (* * This function parses RNFR commands)

    (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
           (TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             (TRUENAME (TCPFTP.SERVER.RESPONSE 350 (CONCAT "About to rename "
                                                          (COND
                                                             (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                              (REPACKFILENAME.STRING
                                                               (PACKFILENAME.STRING 'HOST NIL
                                                                      'BODY TRUENAME)
                                                               'TOPS-20))
                                                             (T TRUENAME)))
                              (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                    TRUENAME)
             (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                NIL])

(TCPFTP.SERVER.RENAME.TO
  [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH FROM.FILE)           (* ejs%: "24-Mar-86 14:34")
          
          (* * This function parses RNTO commands)

    (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
           (TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             (TRUENAME (RENAMEFILE FROM.FILE TRUENAME)
                    (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Renamed "
                                                       (COND
                                                          (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                           (REPACKFILENAME.STRING (
                                                                                  PACKFILENAME.STRING
                                                                                   'HOST NIL
                                                                                   'BODY FROM.FILE)
                                                                  'TOPS-20))
                                                          (T FROM.FILE))
                                                       " to "
                                                       (COND
                                                          (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                           (REPACKFILENAME.STRING (
                                                                                  PACKFILENAME.STRING
                                                                                   'HOST NIL
                                                                                   'BODY TRUENAME)
                                                                  'TOPS-20))
                                                          (T TRUENAME)))
                           (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
             (T (TCPFTP.SERVER.RESPONSE 553 (CONCAT "Couldn't make an output file named " 
                                                   PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.RESPONSE
  [LAMBDA (CODE STRING STREAM)                               (* edited%: "21-Mar-86 11:44")
    (RESETFORM (RADIX 10)
           (COND
              (FTPDEBUGFLG (printout FTPDEBUGLOG "> " CODE " " STRING T)))
           (printout STREAM CODE " " STRING T))
    (FORCEOUTPUT STREAM])

(TCPFTP.SERVER.RETRIEVE
  [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ; "Edited 13-Sep-90 14:59 by gadener")

         (* * This function parses USER commands)

    (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
           (TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'INPUT 'OLD
                                                             `((TYPE %, TYPE]
                            (COND
                               [FILESTREAM
                                (TCPFTP.SERVER.RESPONSE
                                 150
                                 (CONCAT "Opening " TYPE " data connection for "
                                        (COND
                                           (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING
                                                                             (FULLNAME FILESTREAM)
                                                                             'TOPS-20))
                                           (T (FULLNAME FILESTREAM)))
                                        " ("
                                        [\IP.ADDRESS.TO.STRING
                                         (OR (CAR USERPORT)
                                             (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST)
                                                of (fetch (TCPSTREAM TCB)
                                                          of (fetch (TCPFTPCON TCPIN)
                                                                    of TCPFTPCON]
                                        ","
                                        [OR (CDR USERPORT)
                                            (fetch (TCP.CONTROL.BLOCK TCB.DST.PORT)
                                               of (fetch (TCPSTREAM TCB)
                                                         of (fetch (TCPFTPCON TCPIN)
                                                                   of TCPFTPCON]
                                        ") ("
                                        (OR (GETFILEINFO FILESTREAM 'LENGTH)
                                            0)
                                        " bytes).")
                                 (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                                (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON 
                                                         USERPORT)))
                                     (COND
                                        (DATASTREAM (LET [(RESULT (NLSETQ (COND
                                                                             ((EQ TYPE 'BINARY)
                                                                              (COPYBYTES FILESTREAM 
                                                                                     DATASTREAM))
                                                                             (T (COPYCHARS FILESTREAM
                                                                                       DATASTREAM]
                                                         (CLOSEF? FILESTREAM)
                                                         (TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                          TCPFTPCON)
                                                         (COND
                                                            (RESULT (TCPFTP.SERVER.RESPONSE
                                                                     226 "Data transfer complete"
                                                                     (fetch (TCPFTPCON TCPOUT)
                                                                        of TCPFTPCON)))
                                                            (T (TCPFTP.SERVER.RESPONSE
                                                                426 
                                                               "Couldn't complete retrieve operation"
                                                                (fetch (TCPFTPCON TCPOUT)
                                                                   of TCPFTPCON]
                               (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " 
                                                                         TRUENAME)
                                         (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
             (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.RETURN.FILE
  [LAMBDA (FILE DEFAULT.PATH COMMAND)                  (* ; "Edited 31-Aug-90 17:57 by gadener")

    (* ;; "If COMMAND is LIST , it will return a verbose listing of the file and some of its properties. If the command is NLIST, it will just return the filename with extension and version. ")

    (* ;; "Note that since the D-mahines don't have a true directory structure, it will return the relative pathname to the file , in relation to DEFAULT.PATH.")

    (LET* [(DEFAULT.PATH.STRING.LENGTH (NCHARS DEFAULT.PATH))
           (PATH (SUBSTRING FILE (PLUS 1 DEFAULT.PATH.STRING.LENGTH)))
           (TAB (CHARACTER (CHARCODE TAB]
          (COND
             ((EQUAL COMMAND 'LIST)
              (CONCAT (GETFILEINFO FILE 'TYPE)
                     TAB
                     (GETFILEINFO FILE 'LENGTH)
                     TAB
                     (GETFILEINFO FILE 'WRITEDATE)
                     TAB
                     (GETFILEINFO FILE 'AUTHOR)
                     TAB PATH))
             (T PATH])

(TCPFTP.SERVER.STORE
  [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH)       (* ejs%: "24-Mar-86 15:27")
          
          (* * This function parses USER commands)

    (LET*
     [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL))
      (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
      (TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME]
     (COND
        (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
     (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
     (COND
        [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'OUTPUT 'NEW
                                                        `((TYPE %, TYPE]
                       (COND
                          [FILESTREAM
                           (TCPFTP.SERVER.RESPONSE 150 (CONCAT 
                                                              "Opening data connection for store of "
                                                              (FULLNAME FILESTREAM))
                                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                           (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T
                                                    )))
                                (COND
                                   (DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM
                                                  with (FUNCTION (LAMBDA (STREAM)
                                                                   (ERROR!]
                                          (RESETLST (RESETSAVE (COND
                                                                  ((EQ TYPE 'BINARY)
                                                                   (COPYBYTES DATASTREAM FILESTREAM))
                                                                  (T (COPYCHARS DATASTREAM FILESTREAM
                                                                            )))
                                                           (LIST [FUNCTION (LAMBDA (FILESTREAM 
                                                                                          TCPFTPCON)
                                                                             (CLOSEF? FILESTREAM)
                                                                             (
                                                                  TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                              TCPFTPCON)
                                                                             (TCPFTP.SERVER.RESPONSE
                                                                              226 
                                                                             "Data transfer complete"
                                                                              (fetch (TCPFTPCON
                                                                                      TCPOUT)
                                                                                 of TCPFTPCON]
                                                                 FILESTREAM TCPFTPCON]
                          (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME)
                                    (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
        (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME)
                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.STRUCTURE
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 14:08")
          
          (* * This function parses USER commands)

    (LET ((STRUCTURE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                           RDTBL))
          (RESPONSE.STRING)
          (ERRORFLG))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG STRUCTURE T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (SELECTQ STRUCTURE
             (F (SETQ RESPONSE.STRING "Now in stream mode"))
             (PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " STRUCTURE))
                    (SETQ ERRORFLG T)))
         (COND
            (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
                                                                     of TCPFTPCON))
                   NIL)
            (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.TYPE
  [LAMBDA (TCPFTPCON RDTBL)                                  (* ejs%: "24-Mar-86 15:26")
          
          (* * This function parses USER commands)

    (LET* ((MAJOR.TYPE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                             RDTBL))
           [MINOR.TYPE (LET [(TERM.CHAR (BIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON]
                            (COND
                               ((EQ TERM.CHAR (CHARCODE SPACE))
                                (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                                      RDTBL))
                               (T (SELECTQ MAJOR.TYPE
                                      (A 'N)
                                      (L 8)
                                      NIL]
           (RESPONSE.STRING)
           (ERRORFLG))
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG MAJOR.TYPE " " MINOR.TYPE T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (SELECTQ MAJOR.TYPE
              (A (SELECTQ MINOR.TYPE
                     (N (SETQ RESPONSE.STRING "Type is now standard ASCII"))
                     (PROGN (SETQ RESPONSE.STRING (CONCAT "ASCII subtype " MINOR.TYPE 
                                                         " not recognized"))
                            (SETQ ERRORFLG T))))
              (E (SETQ RESPONSE.STRING "EBCDIC not supported")
                 (SETQ ERRORFLG T))
              (I (SETQ RESPONSE.STRING "Type is now 8-bit binary"))
              (L (COND
                    ((NEQ MINOR.TYPE 8)
                     (SETQ RESPONSE.STRING (CONCAT "Binary byte size " MINOR.TYPE " not supported"))
                     (SETQ ERRORFLG T))
                    (T (SETQ RESPONSE.STRING "Type is now 8-bit binary"))))
              NIL)
          (COND
             (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
                                                                      of TCPFTPCON))
                    NIL)
             (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                (SELECTQ MAJOR.TYPE
                    (A 'TEXT)
                    'BINARY])

(TCPFTP.SERVER.USER
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:39")
          
          (* * This function parses USER commands)

    (LET ((USER (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL)))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG USER T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (TCPFTP.SERVER.RESPONSE 230 "Hi, there!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.VERBOSE.LIST
  [LAMBDA (FILE STREAM)                                      (* edited%: "26-Mar-86 11:32")
    (printout STREAM (COND
                        (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                                 'HOST NIL
                                                                                 'BODY
                                                                                 (FULLNAME FILE))
                                                                'TOPS-20))
                        (T (FULLNAME FILE)))
           ";P775252;AFORYOURSELF,"
           (FOLDHI (OR (GETFILEINFO FILE 'SIZE)
                       0)
                  4)
           ","
           (GETFILEINFO FILE 'CREATIONDATE)
           ","
           (GETFILEINFO FILE 'WRITEDATE)
           T])

(TCPFTP.SERVER.WAIT.FOR.IDLE
  [LAMBDA (TCPFTPCON)                                        (* ejs%: "20-Mar-86 16:39")
    (bind BUSY? while (SETQ BUSY? (fetch (TCPFTPCON BUSY?) of TCPFTPCON)) do (AWAIT.EVENT BUSY?])

(TCPFTP.UNIX.LS.DATE
  [LAMBDA (FILE)                                             (* edited%: "21-Mar-86 13:38")
    (LET* [(CREATIONDATE (GETFILEINFO FILE 'CREATIONDATE))
           (MONTHPOS (STRPOS "-" CREATIONDATE))
           (YEARPOS (STRPOS "-" CREATIONDATE (ADD1 MONTHPOS)))
           (TIMEPOS (ADD1 (STRPOS " " CREATIONDATE]
          (CONCAT (SUBSTRING CREATIONDATE (ADD1 MONTHPOS)
                         (SUB1 YEARPOS))
                 " "
                 (SUBSTRING CREATIONDATE 1 (SUB1 MONTHPOS))
                 " "
                 (SUBSTRING CREATIONDATE TIMEPOS -4])
)

(RPAQ? TCPFTP.SERVER.HERALD.STRING "Venue Medley FTP Service 1.0 at your service")

(RPAQ? TCPFTP.SERVER.USE.TOPS20.SYNTAX NIL)

(RPAQ? TCPFTP.SERVER.RETRYCOUNT 5)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX TCPFTP.SERVER.RETRYCOUNT)
)

(FILESLOAD (SYSLOAD)
       TCPFTP)
(PUTPROPS TCPFTPSRV COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1782 54890 (TCPFTP.SERVER 1792 . 2089) (TCPFTP.SERVER.ABORTED 2091 . 2263) (
TCPFTP.SERVER.ACCOUNT 2265 . 2817) (TCPFTP.SERVER.APPEND 2819 . 6531) (
TCPFTP.SERVER.CLOSE.DATA.CONNECTION 6533 . 7031) (TCPFTP.SERVER.COMMAND.LOOP 7033 . 13702) (
TCPFTP.SERVER.CONNECTED.INFO 13704 . 14690) (TCPFTP.SERVER.DELETE 14692 . 16577) (
TCPFTP.SERVER.DIRECTORY 16579 . 18921) (TCPFTP.SERVER.EXIT 18923 . 19115) (TCPFTP.SERVER.IDLE.INFO 
19117 . 19282) (TCPFTP.SERVER.LIST 19284 . 21609) (TCPFTP.SERVER.MERGE.PATHNAMES 21611 . 23718) (
TCPFTP.SERVER.MODE 23720 . 24743) (TCPFTP.SERVER.OPEN.DATA.CONNECTION 24745 . 27732) (
TCPFTP.SERVER.PARSE.PORT 27734 . 30442) (TCPFTP.SERVER.PASSWORD 30444 . 31090) (TCPFTP.SERVER.PATH 
31092 . 32075) (TCPFTP.SERVER.PORT 32077 . 32886) (TCPFTP.SERVER.PROCESS 32888 . 35079) (
TCPFTP.SERVER.RENAME.FROM 35081 . 36653) (TCPFTP.SERVER.RENAME.TO 36655 . 39136) (
TCPFTP.SERVER.RESPONSE 39138 . 39457) (TCPFTP.SERVER.RETRIEVE 39459 . 44526) (
TCPFTP.SERVER.RETURN.FILE 44528 . 45581) (TCPFTP.SERVER.STORE 45583 . 49232) (TCPFTP.SERVER.STRUCTURE 
49234 . 50287) (TCPFTP.SERVER.TYPE 50289 . 52577) (TCPFTP.SERVER.USER 52579 . 53118) (
TCPFTP.SERVER.VERBOSE.LIST 53120 . 54036) (TCPFTP.SERVER.WAIT.FOR.IDLE 54038 . 54285) (
TCPFTP.UNIX.LS.DATE 54287 . 54888)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPHTE b/obsolete/tcp/TCPHTE
new file mode 100644
index 00000000..dda05d9a
--- /dev/null
+++ b/obsolete/tcp/TCPHTE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP")
(FILECREATED "12-Jun-90 17:31:06" {DSK}<usr>local>lde>lispcore>library>TCPHTE.;3 5753   

      changes to%:  (VARS TCPHTECOMS)

      previous date%: "11-Feb-89 11:06:54" {DSK}<usr>local>lde>lispcore>library>TCPHTE.;2)


(* ; "
Copyright (c) 1985, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPHTECOMS)

(RPAQQ TCPHTECOMS
       ((PROP MAKEFILE-ENVIRONMENT TCPHTE)
        (RECORDS HOSTS.TXT.ENTRY)
        (FNS \HTE.PARSE.ENTRY \HTE.READ.FILE \HTE.READ; \HTE.READLINE)
        (INITVARS (HOSTS.TEXT.DIRECTORIES)
               (\HTE.RDTBL))
        (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \HTE.RDTBL \IP.HOSTNAMES)
               (RECORDS HTELINE))))

(PUTPROPS TCPHTE MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP"))
(DECLARE%: EVAL@COMPILE

(DATATYPE HOSTS.TXT.ENTRY (HTE.TYPE HTE.ADDRESSES HTE.NAMES HTE.MACHINE.TYPE HTE.OS.TYPE 
                                     HTE.PROTOCOLS))
)

(/DECLAREDATATYPE 'HOSTS.TXT.ENTRY '(POINTER POINTER POINTER POINTER POINTER POINTER)
       '((HOSTS.TXT.ENTRY 0 POINTER)
         (HOSTS.TXT.ENTRY 2 POINTER)
         (HOSTS.TXT.ENTRY 4 POINTER)
         (HOSTS.TXT.ENTRY 6 POINTER)
         (HOSTS.TXT.ENTRY 8 POINTER)
         (HOSTS.TXT.ENTRY 10 POINTER))
       '12)
(DEFINEQ

(\HTE.PARSE.ENTRY
  [LAMBDA (ENTRY)                                        (* ; "Edited 11-Feb-89 11:04 by akw:")
    (DECLARE (GLOBALVARS NETWORKOSTYPES))
    (LET* [[NAMES (for NAME in (fetch (HTELINE NAMES) of ENTRY)
                     collect (MKATOM (U-CASE NAME]
           (OSTYPE (CAR (fetch (HTELINE OS.TYPE) of ENTRY))
                  (MKATOM (U-CASE)))
           (HTE.ENTRY (create HOSTS.TXT.ENTRY
                             HTE.TYPE _ (CAR (fetch (HTELINE TYPE) of ENTRY))
                             HTE.ADDRESSES _ (for X in (fetch (HTELINE ADDRESSES)
                                                                  of ENTRY)
                                                collect (\IP.READ.STRING.ADDRESS X))
                             HTE.NAMES _ NAMES
                             HTE.MACHINE.TYPE _ [MKATOM (U-CASE (CAR (fetch (HTELINE MACHINE.TYPE
                                                                                       ) of
                                                                                         ENTRY]
                             HTE.OS.TYPE _ [AND OSTYPE (SETQ OSTYPE (MKATOM (U-CASE OSTYPE]
                             HTE.PROTOCOLS _ (for PROTOENTRY in (fetch (HTELINE PROTOCOLS
                                                                                          )
                                                                           of ENTRY) bind
                                                                                         SLASH
                                                when (SETQ SLASH (STRPOS '/ PROTOENTRY))
                                                collect (CONS (SUBATOM PROTOENTRY 1 (SUB1 SLASH))
                                                                  (SUBATOM PROTOENTRY (ADD1 SLASH]
          (for NAME in NAMES do (PUTHASH NAME HTE.ENTRY \IP.HOSTNAMES])

(\HTE.READ.FILE
(LAMBDA (FILE WANTEDTYPES) (* ; "Edited 24-May-88 16:57 by bvm") (DECLARE (GLOBALVARS \IP.HOSTNAMES \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ)) (OR WANTEDTYPES (SETQ WANTEDTYPES (QUOTE (HOST)))) (CL:WITH-OPEN-FILE (STREAM FILE) (LET ((FILENAME (FULLNAME STREAM)) (DATE (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) ENTRY) (PRINTOUT PROMPTWINDOW T "Reading " FILENAME " of " (GDATE DATE (DATEFORMAT NO.SECONDS))) (CLRHASH \IP.HOSTNAMES) (until (EOFP STREAM) when (AND (SETQ ENTRY (\HTE.READLINE STREAM WANTEDTYPES)) (FMEMB (CAR (fetch (HTELINE TYPE) of ENTRY)) WANTEDTYPES)) do (\HTE.PARSE.ENTRY ENTRY)) (SETQ \TCP.LAST.HOSTS.FILE.DATE DATE) (SETQ \TCP.LAST.HOSTS.FILE.READ FILENAME))))
)

(\HTE.READ;
(LAMBDA (FL RDTBL) (* ; "Edited 24-May-88 14:45 by bvm") (until (SELCHARQ (READCCODE FL) ((CR LF EOL) T) NIL)) NIL)
)

(\HTE.READLINE
(LAMBDA (STREAM WANTEDTYPES) (* ; "Edited 24-May-88 16:57 by bvm") (while (EQ (PEEKCCODE STREAM T) (CHARCODE ";")) do (\HTE.READ; STREAM)) (AND (NOT (EOFP STREAM)) (for FIELD# from 1 bind FIELDCONTENTS DONE (RDTBL _ (COND (\HTE.RDTBL) (T (SETQ \HTE.RDTBL (COPYREADTABLE (QUOTE ORIG))) (SETSEPR (CHARCODE (SPACE TAB %,)) NIL \HTE.RDTBL) (SETBRK (CHARCODE (":" ";" CR LF)) NIL \HTE.RDTBL) (READTABLEPROP \HTE.RDTBL (QUOTE CASEINSENSITIVE) T) \HTE.RDTBL))) until DONE collect (SETQ FIELDCONTENTS (until (SELCHARQ (SKIPSEPRCODES STREAM RDTBL) (":" (* ; "End of field") (READCCODE STREAM) T) (";" (* ; "end of line") (\HTE.READ; STREAM) (SETQ DONE T)) ((CR LF) (* ; "end of line--consume the terminator") (READCCODE STREAM) (SETQ DONE T)) (NIL (* ; "Eof") (SETQ DONE T)) NIL) collect (* ; "Read up to the next field delimiter") (if (EQ FIELD# 1) then (* ; "Canonicalize the type field") (READ STREAM RDTBL) else (RSTRING STREAM RDTBL)))) (if (AND (EQ FIELD# 1) WANTEDTYPES (NOT (FMEMB (CAR FIELDCONTENTS) WANTEDTYPES))) then (* ; "Don't care about this line") (OR DONE (\HTE.READ; STREAM)) (RETURN NIL)) FIELDCONTENTS)))
)
)

(RPAQ? HOSTS.TEXT.DIRECTORIES )

(RPAQ? \HTE.RDTBL )
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \HTE.RDTBL \IP.HOSTNAMES)
)

(DECLARE%: EVAL@COMPILE

(RECORD HTELINE (TYPE ADDRESSES NAMES MACHINE.TYPE OS.TYPE PROTOCOLS))
)
)
(PUTPROPS TCPHTE COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1360 5370 (\HTE.PARSE.ENTRY 1370 . 3378) (\HTE.READ.FILE 3380 . 4095) (\HTE.READ; 4097
 . 4230) (\HTE.READLINE 4232 . 5368)))))
STOP
\ No newline at end of file
diff --git a/library/TCPIP.TEDIT b/obsolete/tcp/TCPIP.TEDIT
similarity index 100%
rename from library/TCPIP.TEDIT
rename to obsolete/tcp/TCPIP.TEDIT
diff --git a/obsolete/tcp/TCPLLAR b/obsolete/tcp/TCPLLAR
new file mode 100644
index 00000000..12e028d3
--- /dev/null
+++ b/obsolete/tcp/TCPLLAR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Aug-90 12:32:20" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLAR.;3 22788  

      changes to%:  (FNS \AR.DAEMON \AR.ENTER.RESOLUTION \AR.NOTE.RESOLUTION \AR.UPDATE.RESOLUTION 
                         \PRINTAR SPUTASSOC \AR.TRANSLATE.TO.10MB \AR.REQUEST.IP.TO.10MB 
                         \AR.REQUEST.IP.TO.3MB \AR.RESOLVE \AR.TRANSLATE.TO.3MB \HANDLE.RAW.AR)

      previous date%: " 6-Jan-89 15:18:06" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLAR.;2)


(* "
Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPLLARCOMS)

(RPAQQ TCPLLARCOMS [(COMS 

(* ;;; "IP Ethernet address translation module")

                              [DECLARE%: DONTCOPY (EXPORT (RECORDS AR ARETHER AREXPETHER ARENTRY)
                                                         (CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET
                                                                     1)
                                                                (\AR.ETHERNET.ADDRESS.LENGTH 6)
                                                                (\AR.IP.ADDRESS.LENGTH 4)
                                                                (\AR.REQUEST 1)
                                                                (\AR.RESPONSE 2)
                                                                (\AR.ETHER.PACKET.LENGTH 28]
                              (INITRECORDS ARENTRY)
                              (INITVARS (\AR.IP.TO.10MB.ALIST (CONS))
                                     (\AR.SEARCH.TIMEOUT.INTERVAL 300000)
                                     (\AR.VALID.TIMEOUT.INTERVAL 600000))
                              (GLOBALVARS \AR.IP.TO.10MB.ALIST \AR.SEARCH.TIMEOUT.INTERVAL 
                                     \AR.VALID.TIMEOUT.INTERVAL)
                              (FNS \AR.DAEMON \AR.ENTER.RESOLUTION \AR.NOTE.RESOLUTION 
                                   \AR.UPDATE.RESOLUTION \PRINTAR SPUTASSOC \AR.TRANSLATE.TO.10MB 
                                   \AR.REQUEST.IP.TO.10MB \AR.REQUEST.IP.TO.3MB \AR.RESOLVE 
                                   \AR.TRANSLATE.TO.3MB \HANDLE.RAW.AR)
                              (ADDVARS (\PACKET.PRINTERS (2054 . \PRINTAR])



(* ;;; "IP Ethernet address translation module")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS AR [(ARBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM]
                  [BLOCKRECORD ARBASE ((ARHARDWARESPACE WORD)
                                       (ARPROTOCOLSPACE WORD)
                                       (ARHARDWARELEN BYTE)
                                       (ARPROTOCOLLEN BYTE)
                                       (AROPCODE WORD)
                                       (AR1STWORD WORD))
                         (ACCESSFNS AR1STWORD ((ARCONTENTS (LOCF DATUM])

(ACCESSFNS ARETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM)))
                       [BLOCKRECORD ARETHERBASE ((ARLCLHDW0 WORD)
                                                 (ARLCLHDW1 WORD)
                                                 (ARLCLHDW2 WORD)
                                                 (ARLCLPTCL FIXP)
                                                 (ARFRNHDW0 WORD)
                                                 (ARFRNHDW1 WORD)
                                                 (ARFRNHDW2 WORD)
                                                 (ARFRNPTCL FIXP))
                              [ACCESSFNS ARLCLHDW0 ((ARSENDERHDW (\LOADNSHOSTNUMBER (LOCF DATUM))
                                                           (\STORENSHOSTNUMBER (LOCF DATUM)
                                                                  NEWVALUE]
                              (ACCESSFNS ARFRNHDW0 ((ARTARGETHDW (\LOADNSHOSTNUMBER (LOCF DATUM))
                                                           (\STORENSHOSTNUMBER (LOCF DATUM)
                                                                  NEWVALUE])

(ACCESSFNS AREXPETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM)))
                          (BLOCKRECORD ARETHERBASE ((ARLCLHDW WORD)
                                                    (ARLCLPTCL FIXP)
                                                    (ARFRNHDW WORD)
                                                    (ARFRNPTCL FIXP))))

(DATATYPE ARENTRY ((RECENT FLAG)
                       (SEARCHING FLAG)
                       (IPADDRESS POINTER)
                       (ETHERADDRESS POINTER)
                       (TIMER POINTER))
                      TIMER _ (NCREATE 'FIXP))
)

(/DECLAREDATATYPE 'ARENTRY '(FLAG FLAG POINTER POINTER POINTER)
       '((ARENTRY 0 (FLAGBITS . 0))
         (ARENTRY 0 (FLAGBITS . 16))
         (ARENTRY 0 POINTER)
         (ARENTRY 2 POINTER)
         (ARENTRY 4 POINTER))
       '6)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \AR.HARDWARE.SPACE.ETHERNET 1)

(RPAQQ \AR.ETHERNET.ADDRESS.LENGTH 6)

(RPAQQ \AR.IP.ADDRESS.LENGTH 4)

(RPAQQ \AR.REQUEST 1)

(RPAQQ \AR.RESPONSE 2)

(RPAQQ \AR.ETHER.PACKET.LENGTH 28)


(CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1)
       (\AR.ETHERNET.ADDRESS.LENGTH 6)
       (\AR.IP.ADDRESS.LENGTH 4)
       (\AR.REQUEST 1)
       (\AR.RESPONSE 2)
       (\AR.ETHER.PACKET.LENGTH 28))
)

(* "END EXPORTED DEFINITIONS")

)

(/DECLAREDATATYPE 'ARENTRY '(FLAG FLAG POINTER POINTER POINTER)
       '((ARENTRY 0 (FLAGBITS . 0))
         (ARENTRY 0 (FLAGBITS . 16))
         (ARENTRY 0 POINTER)
         (ARENTRY 2 POINTER)
         (ARENTRY 4 POINTER))
       '6)

(RPAQ? \AR.IP.TO.10MB.ALIST (CONS))

(RPAQ? \AR.SEARCH.TIMEOUT.INTERVAL 300000)

(RPAQ? \AR.VALID.TIMEOUT.INTERVAL 600000)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \AR.IP.TO.10MB.ALIST \AR.SEARCH.TIMEOUT.INTERVAL \AR.VALID.TIMEOUT.INTERVAL)
)
(DEFINEQ

(\AR.DAEMON
  [LAMBDA NIL                                            (* ejs%: "25-Jun-85 18:47")
    (for ARENTRY in \AR.IP.TO.10MB.ALIST do (\AR.UPDATE.RESOLUTION ARENTRY)
                                                       (BLOCK])

(\AR.ENTER.RESOLUTION
  [LAMBDA (IPADDRESS ETHERADDRESS ONLY-IF-PRESENT-P)    (* ; "Edited 21-Dec-88 20:10 by Briggs")

         (* * Enter a new resolution in the AR table, or update an existing resolution)

    (LET [(OLDENTRY (find ENTRY in \AR.IP.TO.10MB.ALIST
                       suchthat (EQUAL IPADDRESS (fetch (ARENTRY IPADDRESS) of ENTRY]
         (COND
            (OLDENTRY (freplace (ARENTRY TIMER) of OLDENTRY with
                                                                    (SETUPTIMER 
                                                                           \AR.VALID.TIMEOUT.INTERVAL
                                                                           (ffetch (ARENTRY
                                                                                        TIMER)
                                                                              of OLDENTRY)))
                   (freplace (ARENTRY ETHERADDRESS) of OLDENTRY with ETHERADDRESS)
                   (freplace (ARENTRY RECENT) of OLDENTRY with T)
                   (freplace (ARENTRY SEARCHING) of OLDENTRY with NIL)
                   OLDENTRY)
            ((NOT ONLY-IF-PRESENT-P)
             (CAR (push \AR.IP.TO.10MB.ALIST (create ARENTRY
                                                        IPADDRESS _ IPADDRESS
                                                        ETHERADDRESS _ ETHERADDRESS
                                                        TIMER _ (SETUPTIMER 
                                                                       \AR.VALID.TIMEOUT.INTERVAL)
                                                        RECENT _ T])

(\AR.NOTE.RESOLUTION
  [LAMBDA (AR)                                          (* ; "Edited 21-Dec-88 20:11 by Briggs")

(* ;;; "Use the information in the AR to update any existing entry in the cache, and if this was a response (presumably to our query) add the new information.")

    [COND
       ((NOT (AND (EQ (fetch (ARETHER ARLCLHDW0) of AR)
                      0)
                  (EQ (fetch (ARETHER ARLCLHDW1) of AR)
                      0)
                  (EQ (fetch (ARETHER ARLCLHDW2) of AR)
                      0)))
        (\AR.ENTER.RESOLUTION (fetch (ARETHER ARLCLPTCL) of AR)
               (fetch (ARETHER ARSENDERHDW) of AR)
               (NOT (MEMBER (fetch (ARETHER ARFRNPTCL) of AR)
                           \IP.LOCAL.ADDRESSES]
    (COND
       ([AND (EQ (fetch (AR AROPCODE) of AR)
                 \AR.RESPONSE)
             (NOT (AND (EQ (fetch (ARETHER ARFRNHDW0) of AR)
                           0)
                       (EQ (fetch (ARETHER ARFRNHDW1) of AR)
                           0)
                       (EQ (fetch (ARETHER ARFRNHDW2) of AR)
                           0]
        (\AR.ENTER.RESOLUTION (fetch (ARETHER ARFRNPTCL) of AR)
               (fetch (ARETHER ARTARGETHDW) of AR])

(\AR.UPDATE.RESOLUTION
  [LAMBDA (ARENTRY)                                     (* ; "Edited 21-Dec-88 18:27 by Briggs")

(* ;;; "Called when a resolution is no longer recent.  Does ARP requests to update our cache.  Eventually, the entry is marked invalid and is removed")

    (COND
       [(TIMEREXPIRED? (fetch (ARENTRY TIMER) of ARENTRY))
        (COND
           ((ffetch (ARENTRY RECENT) of ARENTRY)
            (freplace (ARENTRY RECENT) of ARENTRY with NIL)
            (freplace (ARENTRY SEARCHING) of ARENTRY with T)
            (freplace (ARENTRY TIMER) of ARENTRY with (SETUPTIMER 
                                                                         \AR.SEARCH.TIMEOUT.INTERVAL
                                                                         (ffetch (ARENTRY TIMER)
                                                                            of ARENTRY)))

            (* ;; 
          "ask the system in the table to respond to avoid clogging the net with broadcasts")

            (\AR.REQUEST.IP.TO.10MB (ffetch (ARENTRY IPADDRESS) of ARENTRY)
                   (ffetch (ARENTRY ETHERADDRESS) of ARENTRY)))
           ((ffetch (ARENTRY SEARCHING) of ARENTRY)
            (SETQ \AR.IP.TO.10MB.ALIST (DREMOVE ARENTRY \AR.IP.TO.10MB.ALIST]
       ((ffetch (ARENTRY SEARCHING) of ARENTRY)
        (\AR.REQUEST.IP.TO.10MB (ffetch (ARENTRY IPADDRESS) of ARENTRY)
               (ffetch (ARENTRY ETHERADDRESS) of ARENTRY])

(\PRINTAR
  [LAMBDA (AR CALLER FILE)                               (* ejs%: " 2-Jun-85 13:58")
    (PROG NIL
          (SELECTC (fetch (ETHERPACKET EPTYPE) of AR)
              (\EPT.AR NIL)
              (3 (RETURN))
              (RETURN))
          (COND
             ((AND (EQ (fetch (AR ARHARDWARESPACE) of AR)
                       \AR.HARDWARE.SPACE.ETHERNET)
                   (EQ (fetch (AR ARHARDWARELEN) of AR)
                       \AR.ETHERNET.ADDRESS.LENGTH)
                   (EQ (fetch (AR ARPROTOCOLSPACE) of AR)
                       \EPT.IP)
                   (EQ (fetch (AR ARPROTOCOLLEN) of AR)
                       \AR.IP.ADDRESS.LENGTH))
              (printout FILE CALLER ": Address resolution " (SELECTC (fetch (AR AROPCODE)
                                                                        of AR)
                                                                (\AR.REQUEST "request.")
                                                                (\AR.RESPONSE "response.")
                                                                "unknown opcode.")
                     T "Sender's protocol address is " (\IP.ADDRESS.TO.STRING (fetch (ARETHER
                                                                                          ARLCLPTCL)
                                                                                 of AR))
                     "." T "Sender's hardware address is " (fetch (ARETHER ARSENDERHDW)
                                                              of AR)
                     "." T)
              (SELECTC (fetch (AR AROPCODE) of AR)
                  (\AR.REQUEST (printout FILE "Sender desires hardware address for "
                                      (\IP.ADDRESS.TO.STRING (fetch (ARETHER ARFRNPTCL)
                                                                of AR))
                                      T))
                  (\AR.RESPONSE (printout FILE "Sender says hardware address for "
                                       (\IP.ADDRESS.TO.STRING (fetch (ARETHER ARFRNPTCL)
                                                                 of AR))
                                       T "  is " (fetch (ARETHER ARTARGETHDW) of AR)
                                       T))
                  NIL)))
          (TERPRI FILE])

(SPUTASSOC
  [LAMBDA (KEY VAL ALIST)                                (* ejs%: "27-Dec-84 17:52")
    (PROG (OLDENTRY)
          [COND
             ([SETQ OLDENTRY (for ENTRY in ALIST thereis (EQUAL KEY (CAR ENTRY]
              (RPLACD OLDENTRY VAL))
             (T (NCONC1 ALIST (CONS KEY VAL]
          (RETURN VAL])

(\AR.TRANSLATE.TO.10MB
  [LAMBDA (IPADDRESS DONTPROBE)                         (* ; "Edited 21-Dec-88 20:11 by Briggs")

(* ;;; "Translate an IPADDRESS to a 10MBHOSTNUMBER, or initiate request and fail for now")

    (COND
       ((\IP.BROADCAST.ADDRESS IPADDRESS)
        BROADCASTNSHOSTNUMBER)
       [(bind FOUNDIT find ENTRY in \AR.IP.TO.10MB.ALIST
           suchthat (AND (EQUAL IPADDRESS (fetch (ARENTRY IPADDRESS) of ENTRY))
                             (SETQ FOUNDIT T)) finally (COND
                                                              (FOUNDIT (RETURN (ffetch
                                                                                (ARENTRY ETHERADDRESS
                                                                                       ) of
                                                                                         ENTRY]
       ((NOT DONTPROBE)
        (\AR.REQUEST.IP.TO.10MB IPADDRESS)
        NIL])

(\AR.REQUEST.IP.TO.10MB
  [LAMBDA (IPADDRESS PDH)                               (* ; "Edited 21-Dec-88 18:31 by Briggs")

(* ;;; 
"Request an address translation, either from the specified host, or  by broadcasting the request.")

    (PROG ((AR (\ALLOCATE.ETHERPACKET)))
          (replace (AR ARHARDWARESPACE) of AR with \AR.HARDWARE.SPACE.ETHERNET)
          (replace (AR ARPROTOCOLSPACE) of AR with \EPT.IP)
          (replace (AR ARHARDWARELEN) of AR with \AR.ETHERNET.ADDRESS.LENGTH)
          (replace (AR ARPROTOCOLLEN) of AR with \AR.IP.ADDRESS.LENGTH)
          (replace (AR AROPCODE) of AR with \AR.REQUEST)
          (replace (ARETHER ARSENDERHDW) of AR with \MY.NSHOSTNUMBER)
          (replace (ARETHER ARLCLPTCL) of AR with (ffetch (NDB NDBIPHOST#)
                                                                 of \10MBLOCALNDB))
          (replace (ARETHER ARFRNPTCL) of AR with IPADDRESS)
          (replace (ETHERPACKET EPTYPE) of AR with \EPT.AR)
          (ENCAPSULATE.ETHERPACKET \10MBLOCALNDB AR (OR PDH BROADCASTNSHOSTNUMBER)
                 \AR.ETHER.PACKET.LENGTH \EPT.AR)
          (COND
             ((EQ IPTRACEFLG T)
              (PRINTPACKET AR 'PUT IPTRACEFILE))
             (IPTRACEFLG (PRIN1 (COND
                                   (PDH "!")
                                   (T "^"))
                                IPTRACEFILE)))
          (TRANSMIT.ETHERPACKET \10MBLOCALNDB AR])

(\AR.REQUEST.IP.TO.3MB
  [LAMBDA (IPADDRESS)                                    (* ejs%: " 2-Jan-85 17:12")

         (* * Broadcast a request for an address translation)

    (PROG ((AR (\ALLOCATE.ETHERPACKET)))
          (replace (AR ARHARDWARESPACE) of AR with \AR.HARDWARE.SPACE.ETHERNET)
          (replace (AR ARPROTOCOLSPACE) of AR with \EET.IP)
          (replace (AR ARHARDWARELEN) of AR with 2)
          (replace (AR ARPROTOCOLLEN) of AR with \AR.IP.ADDRESS.LENGTH)
          (replace (AR AROPCODE) of AR with \AR.REQUEST)
          (replace (AREXPETHER ARLCLHDW) of AR with (LOGAND \LOCALPUPNETHOST
                                                                       (MASK.1'S 0 8)))
          (replace (AREXPETHER ARLCLPTCL) of AR with (ffetch (NDB NDBIPHOST#)
                                                                    of \3MBLOCALNDB))
          (replace (AREXPETHER ARFRNPTCL) of AR with IPADDRESS)
          (ENCAPSULATE.ETHERPACKET \3MBLOCALNDB AR 0 20 \EPT.AR)
          (COND
             (IPTRACEFLG (PRINTPACKET AR 'PUT IPTRACEFILE)))
          (TRANSMIT.ETHERPACKET \3MBLOCALNDB AR])

(\AR.RESOLVE
  [LAMBDA (AR)                                          (* ; "Edited  6-Jan-89 14:50 by Briggs")

(* ;;; "Try to respond to an address resolution request.  Release the packet if we can't")

    (DECLARE (GLOBALVARS \10MBLOCALNDB \MY.NSHOSTNUMBER))
    (LET* ((TargetProtocolAddress (fetch (ARETHER ARFRNPTCL) of AR))
           (TargetHardwareAddress (COND
                                     ((MEMBER TargetProtocolAddress \IP.LOCAL.ADDRESSES)
                                      (\AR.ENTER.RESOLUTION TargetProtocolAddress 
                                             \MY.NSHOSTNUMBER)
                                      \MY.NSHOSTNUMBER)
                                     ([AND \IP.GATEWAY.FLG
                                           (LET* ((SUBNETMASK (CDR (SASSOC (fetch NDBIPHOST#
                                                                              of \10MBLOCALNDB)
                                                                          \IP.SUBNET.MASKS)))
                                                  (MASKEDTARGET (LOGAND TargetProtocolAddress 
                                                                       SUBNETMASK)))
                                                 (COND
                                                    ([AND SUBNETMASK
                                                          (NOT (EQP MASKEDTARGET
                                                                    (LOGAND (fetch NDBIPHOST#
                                                                               of \10MBLOCALNDB)
                                                                           SUBNETMASK]
                                                     (for ADDRPAIR in \IP.ROUTING.TABLE
                                                        when (LISTP ADDRPAIR)
                                                        thereis (EQP MASKEDTARGET (CAR ADDRPAIR]
                                      \MY.NSHOSTNUMBER)))
           (SenderHardwareAddress (fetch (ARETHER ARSENDERHDW) of AR)))
          (COND
             (TargetHardwareAddress (swap (fetch (ARETHER ARLCLPTCL) of AR)
                                           (fetch (ARETHER ARFRNPTCL) of AR))
                    (replace (ARETHER ARTARGETHDW) of AR with (fetch (ARETHER 
                                                                                          ARSENDERHDW
                                                                                            )
                                                                             of AR))
                    (replace (ARETHER ARSENDERHDW) of AR with TargetHardwareAddress)
                    (replace (ARETHER ARLCLPTCL) of AR with TargetProtocolAddress)
                    (replace (AR AROPCODE) of AR with \AR.RESPONSE)
                    (ENCAPSULATE.ETHERPACKET \10MBLOCALNDB AR SenderHardwareAddress 
                           \AR.ETHER.PACKET.LENGTH \EPT.AR)
                    [COND
                       (IPTRACEFLG (COND
                                      ((EQ IPTRACEFLG T)
                                       (PRINTPACKET AR 'PUT IPTRACEFILE))
                                      (T (PRIN1 "!" IPTRACEFILE]
                    (TRANSMIT.ETHERPACKET \10MBLOCALNDB AR))
             (T (\RELEASE.ETHERPACKET AR])

(\AR.TRANSLATE.TO.3MB
  [LAMBDA (IPADDRESS)                                    (* ejs%: "27-Jun-85 12:43")
    (COND
       ((\IP.BROADCAST.ADDRESS IPADDRESS)
        0)
       (T (LDB (BYTE 8 0)
               IPADDRESS])

(\HANDLE.RAW.AR
  [LAMBDA (AR TYPE)                                      (* ejs%: " 2-Jun-85 14:12")
    (PROG ((NDB (ffetch (ETHERPACKET EPNETWORK) of AR)))
          (SELECTQ (ffetch (NDB NETTYPE) of NDB)
              (10 (COND
                     ((NEQ TYPE \EPT.AR)
                      (RETURN))))
              (3 (RETURN))
              (ERROR "Unknown net type" (fetch (NDB NETTYPE) of NDB)))
          [COND
             ((AND (EQ (fetch (AR ARHARDWARESPACE) of AR)
                       \AR.HARDWARE.SPACE.ETHERNET)
                   (EQ (fetch (AR ARHARDWARELEN) of AR)
                       \AR.ETHERNET.ADDRESS.LENGTH)
                   (EQ (fetch (AR ARPROTOCOLSPACE) of AR)
                       \EPT.IP)
                   (EQ (fetch (AR ARPROTOCOLLEN) of AR)
                       \AR.IP.ADDRESS.LENGTH))
              [COND
                 (IPTRACEFLG (COND
                                ((EQ IPTRACEFLG T)
                                 (PRINTPACKET AR 'ARGET IPTRACEFILE))
                                (T (PRIN1 "*" IPTRACEFILE]
              (\AR.NOTE.RESOLUTION AR)
              (COND
                 ((EQ (fetch (AR AROPCODE) of AR)
                      \AR.REQUEST)
                  (\AR.RESOLVE AR))
                 (T (\RELEASE.ETHERPACKET AR]
          (RETURN T])
)

(ADDTOVAR \PACKET.PRINTERS (2054 . \PRINTAR))
(PUTPROPS TCPLLAR COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (5949 22633 (\AR.DAEMON 5959 . 6223) (\AR.ENTER.RESOLUTION 6225 . 7972) (
\AR.NOTE.RESOLUTION 7974 . 9329) (\AR.UPDATE.RESOLUTION 9331 . 10916) (\PRINTAR 10918 . 13356) (
SPUTASSOC 13358 . 13700) (\AR.TRANSLATE.TO.10MB 13702 . 14709) (\AR.REQUEST.IP.TO.10MB 14711 . 16270) 
(\AR.REQUEST.IP.TO.3MB 16272 . 17510) (\AR.RESOLVE 17512 . 20996) (\AR.TRANSLATE.TO.3MB 20998 . 21232)
 (\HANDLE.RAW.AR 21234 . 22631)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPLLICMP b/obsolete/tcp/TCPLLICMP
new file mode 100644
index 00000000..62f1f4bb
--- /dev/null
+++ b/obsolete/tcp/TCPLLICMP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Aug-90 12:34:42" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLICMP.;2 20237  

      changes to%:  (FNS PRINTICMP \ICMP.HANDLE.REDIRECT \ICMP.INPUT)

      previous date%: " 6-Jan-89 16:38:06" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLICMP.;1)


(* "
Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPLLICMPCOMS)

(RPAQQ TCPLLICMPCOMS [(COMS (* * ICMP functions)
                                (DECLARE%: DONTCOPY (EXPORT (RECORDS ICMPADMASK ICMP ICMPECHO 
                                                                   ICMPDESTUN ICMPREDIRECT)
                                                           (CONSTANTS * ICMPTYPES)
                                                           (CONSTANTS * ICMPUNREACHABLES)
                                                           (CONSTANTS * ICMPREDIRECTS)
                                                           (CONSTANTS \ICMPOVLEN)
                                                           (CONSTANTS \ICMP.PROTOCOL)
                                                           (MACROS ICMPLENGTH)))
                                (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS IP.FROM.ICMP))
                                (INITVARS * ICMPTIMEXS)
                                (INITVARS (\ICMP.ECHO.REPLY.QUEUE (NCREATE 'SYSQUEUE))
                                       (\ICMP.ECHO.REPLY.EVENT (CREATE.EVENT "ICMP Echo reply"))
                                       (\ICMP.ECHOING))
                                (GLOBALVARS \ICMP.ECHO.REPLY.QUEUE \ICMP.ECHO.REPLY.EVENT 
                                       \ICMP.ECHOING)
                                (FNS PRINTICMP \ICMP.DEST.UNREACHABLE \ICMP.REDIRECT \ICMP.ECHO.TEST
                                     \ICMP.HANDLE.ECHO.REPLY \ICMP.HANDLE.REDIRECT \ICMP.INPUT 
                                     \ICMP.REPLY.TO.ECHO \ICMP.SETUPICMP \ICMP.TIME.EXCEEDED 
                                     \ICMP.TRANSMIT)
                                (FNS ICMP.HANDLE.ADDRESS.MASK \ICMP.INPUT \ICMP.REQUEST.ADDRESS.MASK)
                                (ADDVARS (IPPRINTMACROS (1 . PRINTICMP])
(* * ICMP functions)

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS ICMPADMASK ((ICMPADMASKBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                          (BLOCKRECORD ICMPADMASKBASE ((ICMPADMASKID WORD)
                                                       (ICMPADMASKSEQNO WORD)
                                                       (ICMPADMASKADMASK FIXP))))

(ACCESSFNS ICMP ((ICMPBASE (\IPDATABASE DATUM)))
                    (BLOCKRECORD ICMPBASE ((ICMPTYPE BYTE)
                                           (ICMPCODE BYTE)
                                           (ICMPCHECKSUM WORD)
                                           (ICMPDATASTART WORD)))
                    [ACCESSFNS ICMP ((ICMPCONTENTS (LOCF (fetch (ICMP ICMPDATASTART) of
                                                                                         DATUM])

(ACCESSFNS ICMPECHO ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                        (BLOCKRECORD ICMPECHOBASE ((ICMPECHOID WORD)
                                                   (ICMPECHOSEQNO WORD)
                                                   (ICMPECHODATA BYTE))))

(ACCESSFNS ICMPDESTUN ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                          (BLOCKRECORD ICMPECHOBASE ((NIL FIXP)
                                                     (ICMPIPSTART WORD)))
                          [ACCESSFNS ICMPDESTUN ((ICMPIPHEADER (LOCF (fetch (ICMPDESTUN 
                                                                                       ICMPIPSTART)
                                                                        of DATUM])

(ACCESSFNS ICMPREDIRECT ((ICMPREDIRECTBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                            (BLOCKRECORD ICMPREDIRECTBASE ((ICMPGATEWAY FIXP)
                                                           (ICMPIPSTART WORD)))
                            [ACCESSFNS ICMPREDIRECT ((ICMPIPHEADER (LOCF (fetch (ICMPREDIRECT
                                                                                     ICMPIPSTART)
                                                                            of DATUM])
)

(RPAQQ ICMPTYPES ((\ICMP.ECHO.REPLY 0)
                      (\ICMP.DEST.UNREACHABLE 3)
                      (\ICMP.SOURCE.QUENCH 4)
                      (\ICMP.REDIRECT 5)
                      (\ICMP.ECHO 8)
                      (\ICMP.TIME.EXCEEDED 11)
                      (\ICMP.PARAMETER.PROBLEM 12)
                      (\ICMP.TIMESTAMP 13)
                      (\ICMP.TIMESTAMP.REPLY 14)
                      (\ICMP.INFO.REQUEST 15)
                      (\ICMP.INFO.REPLY 16)
                      (\ICMP.ADDRESS.MASK.REQUEST 17)
                      (\ICMP.ADDRESS.MASK.REPLY 18)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.ECHO.REPLY 0)

(RPAQQ \ICMP.DEST.UNREACHABLE 3)

(RPAQQ \ICMP.SOURCE.QUENCH 4)

(RPAQQ \ICMP.REDIRECT 5)

(RPAQQ \ICMP.ECHO 8)

(RPAQQ \ICMP.TIME.EXCEEDED 11)

(RPAQQ \ICMP.PARAMETER.PROBLEM 12)

(RPAQQ \ICMP.TIMESTAMP 13)

(RPAQQ \ICMP.TIMESTAMP.REPLY 14)

(RPAQQ \ICMP.INFO.REQUEST 15)

(RPAQQ \ICMP.INFO.REPLY 16)

(RPAQQ \ICMP.ADDRESS.MASK.REQUEST 17)

(RPAQQ \ICMP.ADDRESS.MASK.REPLY 18)


(CONSTANTS (\ICMP.ECHO.REPLY 0)
       (\ICMP.DEST.UNREACHABLE 3)
       (\ICMP.SOURCE.QUENCH 4)
       (\ICMP.REDIRECT 5)
       (\ICMP.ECHO 8)
       (\ICMP.TIME.EXCEEDED 11)
       (\ICMP.PARAMETER.PROBLEM 12)
       (\ICMP.TIMESTAMP 13)
       (\ICMP.TIMESTAMP.REPLY 14)
       (\ICMP.INFO.REQUEST 15)
       (\ICMP.INFO.REPLY 16)
       (\ICMP.ADDRESS.MASK.REQUEST 17)
       (\ICMP.ADDRESS.MASK.REPLY 18))
)

(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0)
                             (\ICMP.HOST.UNREACHABLE 1)
                             (\ICMP.PROTOCOL.UNREACHABLE 2)
                             (\ICMP.PORT.UNREACHABLE 3)
                             (\ICMP.CANT.FRAGMENT 4)
                             (\ICMP.SOURCE.ROUTE 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.NET.UNREACHABLE 0)

(RPAQQ \ICMP.HOST.UNREACHABLE 1)

(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)

(RPAQQ \ICMP.PORT.UNREACHABLE 3)

(RPAQQ \ICMP.CANT.FRAGMENT 4)

(RPAQQ \ICMP.SOURCE.ROUTE 5)


(CONSTANTS (\ICMP.NET.UNREACHABLE 0)
       (\ICMP.HOST.UNREACHABLE 1)
       (\ICMP.PROTOCOL.UNREACHABLE 2)
       (\ICMP.PORT.UNREACHABLE 3)
       (\ICMP.CANT.FRAGMENT 4)
       (\ICMP.SOURCE.ROUTE 5))
)

(RPAQQ ICMPREDIRECTS ((\ICMP.REDIRECT.NET 0)
                          (\ICMP.REDIRECT.HOST 1)
                          (\ICMP.REDIRECT.SVC.AND.NET 2)
                          (\ICMP.REDIRECT.SVC.AND.HOST 3)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.REDIRECT.NET 0)

(RPAQQ \ICMP.REDIRECT.HOST 1)

(RPAQQ \ICMP.REDIRECT.SVC.AND.NET 2)

(RPAQQ \ICMP.REDIRECT.SVC.AND.HOST 3)


(CONSTANTS (\ICMP.REDIRECT.NET 0)
       (\ICMP.REDIRECT.HOST 1)
       (\ICMP.REDIRECT.SVC.AND.NET 2)
       (\ICMP.REDIRECT.SVC.AND.HOST 3))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMPOVLEN 4)


(CONSTANTS \ICMPOVLEN)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.PROTOCOL 1)


(CONSTANTS \ICMP.PROTOCOL)
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS ICMPLENGTH MACRO (LAMBDA (ICMP)
                             (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of ICMP)
                                    (LLSH (fetch (IP IPHEADERLENGTH) of ICMP)
                                          2]
)

(* "END EXPORTED DEFINITIONS")

)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTPROPS IP.FROM.ICMP MACRO (OPENLAMBDA (PKT)

                                 (* ;; "Returns a pointer to the 'Internet header + 64 bits' found in an ICMP packet, offset so that it looks like an IP record.  I.e., add to the base the size of the IP header + ICMP header")

                                    (\ADDBASE PKT (+ (UNFOLD (fetch (IP IPHEADERLENGTH)
                                                                of PKT)
                                                            WORDSPERCELL)
                                                     (CONSTANT (+ (FOLDHI \ICMPOVLEN BYTESPERWORD)
                                                                  2]
)
)

(RPAQQ ICMPTIMEXS ((\ICMP.TRANSIT.TIME.EXCEEDED 0)
                       (\ICMP.FRAGMENT.TIME.EXCEEDED 1)))

(RPAQ? \ICMP.TRANSIT.TIME.EXCEEDED 0)

(RPAQ? \ICMP.FRAGMENT.TIME.EXCEEDED 1)

(RPAQ? \ICMP.ECHO.REPLY.QUEUE (NCREATE 'SYSQUEUE))

(RPAQ? \ICMP.ECHO.REPLY.EVENT (CREATE.EVENT "ICMP Echo reply"))

(RPAQ? \ICMP.ECHOING )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \ICMP.ECHO.REPLY.QUEUE \ICMP.ECHO.REPLY.EVENT \ICMP.ECHOING)
)
(DEFINEQ

(PRINTICMP
  [LAMBDA (ICMP FILE)                                    (* ; "Edited 13-Sep-88 11:35 by bvm")
    (LET ((*PRINT-BASE* 10)
          (TYPE (fetch (ICMP ICMPTYPE) of ICMP))
          (CODE (fetch (ICMP ICMPCODE) of ICMP)))
         (PRINTCONSTANT TYPE ICMPTYPES FILE "\ICMP.")
         (SPACES 1 FILE)
         (SELECTC TYPE
             (\ICMP.REDIRECT 
                  (PRINTCONSTANT CODE ICMPREDIRECTS FILE "\ICMP.REDIRECT.")
                  (PRINTOUT FILE " " (\IP.ADDRESS.TO.STRING (fetch (ICMPREDIRECT ICMPGATEWAY)
                                                               of ICMP))))
             (\ICMP.DEST.UNREACHABLE 
                  (PRINTCONSTANT CODE ICMPUNREACHABLES FILE "\ICMP."))
             (PRIN3 CODE FILE))
         (TERPRI FILE])

(\ICMP.DEST.UNREACHABLE
(LAMBDA (PACKET CODE) (* ejs%: " 2-Feb-86 11:35") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.DEST.UNREACHABLE CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL))) (\BLT (fetch (ICMPDESTUN ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP) (\RELEASE.ETHERPACKET PACKET)))
)

(\ICMP.REDIRECT
(LAMBDA (PACKET CODE) (* ejs%: " 2-Feb-86 12:13") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.REDIRECT CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL) WORDSPERCELL)) (replace (ICMPREDIRECT ICMPGATEWAY) of ICMP with (OR \IP.DEFAULT.GATEWAY 0)) (\BLT (fetch (ICMPREDIRECT ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP) (\RELEASE.ETHERPACKET PACKET)))
)

(\ICMP.ECHO.TEST
(LAMBDA (IPADDRESS ECHOSTREAM DATALENGTH) (* ejs%: "12-May-86 18:01") (* * An ICMP echo tester) (while (\QUEUEHEAD \ICMP.ECHO.REPLY.QUEUE) do (\RELEASE.ETHERPACKET (\DEQUEUE \ICMP.ECHO.REPLY.QUEUE))) (RESETVAR \ICMP.ECHOING T (PROG (ICMP (IPSOCKET (\IP.FIND.PROTOCOL \ICMP.PROTOCOL))) (for SEQUENCE from 0 do ((SETQ ICMP (\ALLOCATE.ETHERPACKET)) (\IP.SETUPIP ICMP (DODIP.HOSTP IPADDRESS) 0 IPSOCKET) (\ICMP.SETUPICMP ICMP \ICMP.ECHO 0) (replace (ICMPECHO ICMPECHOID) of ICMP with 0) (replace (ICMPECHO ICMPECHOSEQNO) of ICMP with SEQUENCE) (add (fetch (IP IPTOTALLENGTH) of ICMP) 4) (AND (NUMBERP DATALENGTH) (add (fetch (IP IPTOTALLENGTH) of ICMP) DATALENGTH)) (printout ECHOSTREAM "!") (\ICMP.TRANSMIT ICMP) (AWAIT.EVENT \ICMP.ECHO.REPLY.EVENT \ETHERTIMEOUT) (COND ((SETQ ICMP (\DEQUEUE \ICMP.ECHO.REPLY.QUEUE)) (COND ((IGREATERP (fetch (ICMPECHO ICMPECHOSEQNO) of ICMP) SEQUENCE) (printout T "ICMP echo out of sequence" T) (PRINTPACKET ICMP (QUOTE GET) ECHOSTREAM) (RETURN ICMP)) (T (printout ECHOSTREAM "+") (\RELEASE.ETHERPACKET ICMP)))) (T (printout ECHOSTREAM "."))))))))
)

(\ICMP.HANDLE.ECHO.REPLY
(LAMBDA (ICMP) (* ejs%: "28-Dec-84 09:02") (COND (\ICMP.ECHOING (\ENQUEUE \ICMP.ECHO.REPLY.QUEUE ICMP) (NOTIFY.EVENT \ICMP.ECHO.REPLY.EVENT)) (T (\RELEASE.ETHERPACKET ICMP))))
)

(\ICMP.HANDLE.REDIRECT
  [LAMBDA (ICMP)                                         (* ; "Edited 24-Aug-88 16:16 by bvm")

(* ;;; "Called when a gateway tells us a better route to the destination.  There is a code for type of redirect, but it's not obviously meaningful ")

    (LET* ((NDB (fetch EPNETWORK of ICMP))
           (GATEWAY (fetch (ICMPREDIRECT ICMPGATEWAY) of ICMP))
           (DESTADDRESS (fetch (IP IPDESTINATIONADDRESS) of (IP.FROM.ICMP ICMP)))
           (DESTNET (\IPNETADDRESS DESTADDRESS)))

          (* ;; "Store the new route in the routing table")

          (COND
             [(= DESTNET (fetch (NDB NDBIPNET#) of NDB))
              (LET* ((SOURCEADDRESS (fetch (NDB NDBIPHOST#) of NDB))
                     (SUBNETMASK (CDR (SASSOC SOURCEADDRESS \IP.SUBNET.MASKS)))
                     (DESTSUBNET (LOGAND DESTADDRESS SUBNETMASK)))

                    (* ;; "The dest net is a local net.  Either we fouled up in our routing, or the dest net is really a subnet")

                    (COND
                       ((NOT (= DESTSUBNET (LOGAND SOURCEADDRESS SUBNETMASK)))
                                                             (* ; 
                                        "Yes, this is a redirect for a subnet, if such is possible")
                        (SPUTASSOC DESTSUBNET GATEWAY \IP.ROUTING.TABLE]
             (T                                              (* ; "Non-local net")
                (SPUTASSOC DESTNET GATEWAY \IP.ROUTING.TABLE)))

          (* ;; "If it's a 10MB network, see if we have the 10MB address of this gateway, and if not, request the address")

          (SELECTQ (fetch (NDB NETTYPE) of NDB)
              (10 (COND
                     ((NOT (\AR.TRANSLATE.TO.10MB GATEWAY T))
                      (\AR.TRANSLATE.TO.10MB GATEWAY))))
              NIL)
          (\RELEASE.ETHERPACKET ICMP])

(\ICMP.INPUT
  [LAMBDA (ICMP)                                         (* ; "Edited 25-Aug-88 11:51 by bvm")

(* ;;; "ICMP packet received")

    (COND
       ((\IP.CHECKSUM.OK (\IPCHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP)
                                (\IPDATALENGTH ICMP)))
        (SELECTC (fetch (ICMP ICMPTYPE) of ICMP)
            (\ICMP.ECHO.REPLY 
                 (\ICMP.HANDLE.ECHO.REPLY ICMP))
            (\ICMP.ECHO (\ICMP.REPLY.TO.ECHO ICMP))
            (\ICMP.DEST.UNREACHABLE                          (* ; "Some packet couldn't reach its destination.  Tell the protocol that sent the packet (found in the enclosed header)")
                 [LET* [(SEGMENT (IP.FROM.ICMP ICMP))
                        (PROTOCOL (\IP.FIND.PROTOCOL (fetch (IP IPPROTOCOL) of SEGMENT]
                       (COND
                          (PROTOCOL (CL:FUNCALL (fetch (IPSOCKET IPSICMPFN) of PROTOCOL)
                                           ICMP SEGMENT PROTOCOL])
            (\ICMP.REDIRECT 
                 (\ICMP.HANDLE.REDIRECT ICMP))
            (\ICMP.ADDRESS.MASK.REPLY 
                 (ICMP.HANDLE.ADDRESS.MASK ICMP))
            (\RELEASE.ETHERPACKET ICMP)))
       (T (AND IPTRACEFLG (PRINTPACKET ICMP 'ICMPGET IPTRACEFILE 
                                 "[dropping packet--bad ICMP checksum]"])

(\ICMP.REPLY.TO.ECHO
(LAMBDA (ICMP) (* ejs%: "12-May-86 17:34") (* * Reply to an echo request) (swap (fetch (IP IPSOURCEADDRESS) of ICMP) (fetch (IP IPDESTINATIONADDRESS) of ICMP)) (replace (ICMP ICMPTYPE) of ICMP with \ICMP.ECHO.REPLY) (replace EPREQUEUE of ICMP with (QUOTE FREE)) (\ICMP.TRANSMIT ICMP))
)

(\ICMP.SETUPICMP
(LAMBDA (ICMP TYPE CODE) (* ejs%: "27-Dec-84 19:00") (replace (ICMP ICMPTYPE) of ICMP with TYPE) (replace (ICMP ICMPCODE) of ICMP with CODE) (add (fetch (IP IPTOTALLENGTH) of ICMP) \ICMPOVLEN))
)

(\ICMP.TIME.EXCEEDED
(LAMBDA (PACKET CODE) (* ejs%: " 3-Feb-86 11:00") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.TIME.EXCEEDED CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL))) (\BLT (fetch (ICMPDESTUN ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP)))
)

(\ICMP.TRANSMIT
(LAMBDA (ICMP) (* ejs%: "31-Dec-84 14:27") (* * Checksum and transmit an ICMP packet) (\IP.SET.CHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP) (\IPDATALENGTH ICMP) (LOCF (fetch (ICMP ICMPCHECKSUM) of ICMP))) (\IP.TRANSMIT ICMP))
)
)
(DEFINEQ

(ICMP.HANDLE.ADDRESS.MASK
(LAMBDA (ICMP) (* ; "Edited 22-Mar-88 18:49 by eweaver") (* ;; "Called when an address-mask-reply icmp comes in.") (LET* ((FROM (fetch (IP IPSOURCEADDRESS) of ICMP)) (DESTADDR (fetch (IP IPDESTINATIONADDRESS) of ICMP)) (LOCALADDR (COND ((AND \3MBLOCALNDB (EQ (fetch NDBIPHOST# of \3MBLOCALNDB) DESTADDR)) DESTADDR) ((AND \10MBLOCALNDB (EQ (fetch NDBIPHOST# of \10MBLOCALNDB) DESTADDR)) DESTADDR))) (MASK (fetch (ICMPADMASK ICMPADMASKADMASK) of ICMP))) (* ;; (CL:FORMAT PROMPTWINDOW "ICMP AdMask from ~a mask ~a" (\IP.ADDRESS.TO.STRING FROM) (\IP.ADDRESS.TO.STRING MASK))) (COND ((NULL \IP.DEFAULT.GATEWAY) (SETQ \IP.DEFAULT.GATEWAY FROM))) (COND ((NULL (SASSOC DESTADDR \IP.SUBNET.MASKS)) (CL:PUSH (CONS DESTADDR MASK) \IP.SUBNET.MASKS)))))
)

(\ICMP.INPUT
  [LAMBDA (ICMP)                                         (* ; "Edited 25-Aug-88 11:51 by bvm")

(* ;;; "ICMP packet received")

    (COND
       ((\IP.CHECKSUM.OK (\IPCHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP)
                                (\IPDATALENGTH ICMP)))
        (SELECTC (fetch (ICMP ICMPTYPE) of ICMP)
            (\ICMP.ECHO.REPLY 
                 (\ICMP.HANDLE.ECHO.REPLY ICMP))
            (\ICMP.ECHO (\ICMP.REPLY.TO.ECHO ICMP))
            (\ICMP.DEST.UNREACHABLE                          (* ; "Some packet couldn't reach its destination.  Tell the protocol that sent the packet (found in the enclosed header)")
                 [LET* [(SEGMENT (IP.FROM.ICMP ICMP))
                        (PROTOCOL (\IP.FIND.PROTOCOL (fetch (IP IPPROTOCOL) of SEGMENT]
                       (COND
                          (PROTOCOL (CL:FUNCALL (fetch (IPSOCKET IPSICMPFN) of PROTOCOL)
                                           ICMP SEGMENT PROTOCOL])
            (\ICMP.REDIRECT 
                 (\ICMP.HANDLE.REDIRECT ICMP))
            (\ICMP.ADDRESS.MASK.REPLY 
                 (ICMP.HANDLE.ADDRESS.MASK ICMP))
            (\RELEASE.ETHERPACKET ICMP)))
       (T (AND IPTRACEFLG (PRINTPACKET ICMP 'ICMPGET IPTRACEFILE 
                                 "[dropping packet--bad ICMP checksum]"])

(\ICMP.REQUEST.ADDRESS.MASK
(LAMBDA NIL (* ; "Edited  8-Jan-88 15:15 by eweaver") (* ;; "Broadcast a request for the subnet mask.  The reply is handled asynchronously by") (* ;; " \handle-icmp-address-mask.") (LET ((ICMP (\ALLOCATE.ETHERPACKET)) (IPSOCKET (\IP.FIND.PROTOCOL \ICMP.PROTOCOL))) (\IP.SETUPIP ICMP 0 0 IPSOCKET) (\ICMP.SETUPICMP ICMP \ICMP.ADDRESS.MASK.REQUEST 0) (replace (ICMPADMASK ICMPADMASKID) of ICMP with 0) (replace (ICMPADMASK ICMPADMASKSEQNO) of ICMP with 0) (add (fetch (IP IPTOTALLENGTH) of ICMP) 4) (\ICMP.TRANSMIT ICMP)))
)
)

(ADDTOVAR IPPRINTMACROS (1 . PRINTICMP))
(PUTPROPS TCPLLICMP COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (9098 17355 (PRINTICMP 9108 . 9918) (\ICMP.DEST.UNREACHABLE 9920 . 10573) (
\ICMP.REDIRECT 10575 . 11304) (\ICMP.ECHO.TEST 11306 . 12407) (\ICMP.HANDLE.ECHO.REPLY 12409 . 12615) 
(\ICMP.HANDLE.REDIRECT 12617 . 14564) (\ICMP.INPUT 14566 . 15953) (\ICMP.REPLY.TO.ECHO 15955 . 16266) 
(\ICMP.SETUPICMP 16268 . 16484) (\ICMP.TIME.EXCEEDED 16486 . 17103) (\ICMP.TRANSMIT 17105 . 17353)) (
17356 20085 (ICMP.HANDLE.ADDRESS.MASK 17366 . 18138) (\ICMP.INPUT 18140 . 19527) (
\ICMP.REQUEST.ADDRESS.MASK 19529 . 20083)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPLLIP b/obsolete/tcp/TCPLLIP
new file mode 100644
index 00000000..b5ec716b
--- /dev/null
+++ b/obsolete/tcp/TCPLLIP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP")
(FILECREATED "30-Aug-90 13:46:39" {DSK}<LISPFILES>TCP>TCPLLIP.;3 151757 

      changes to%:  (VARS TCPLLIPCOMS)

      previous date%: "29-Aug-90 16:28:12" {DSK}<LISPFILES>TCP>TCPLLIP.;2)


(* ; "
Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPLLIPCOMS)

(RPAQQ TCPLLIPCOMS 
       ((PROP MAKEFILE-ENVIRONMENT TCPLLIP)
        (COMS 
              (* ;; "IP definitions and addressing")

              (DECLARE%: DONTCOPY (EXPORT (RECORDS IP IPSOCKET IPADDRESS)
                                         (CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION 
                                                \IP.MAX.EPKTS.ON.QUEUE \IP.DEFAULT.TIME.TO.LIVE 
                                                \IP.WAKEUP.INTERVAL)
                                         (CONSTANTS * IPPACKETTYPES)
                                         (CONSTANTS * ICMPUNREACHABLES)
                                         (MACROS \IPDATABASE \IPDATALENGTH)))
              (ADDVARS (*IP-PROTOCOL-NAME-FROM-NUMBER* (17 . "UDP")
                              (6 . "TCP")
                              (1 . "ICMP")))
              (GLOBALVARS *IP-PROTOCOL-NAME-FROM-NUMBER*)
              
              (* ;; "value in sysout is too small.  This is 512-(indexf (fetch epencapsulation))-2.  489 is more correct, but let's leave a word of slop for off-by-ones")

              (VARS (\10MBPACKETLENGTH 488))
              
              (* ;; "Make it easier to see queuelength without opening up q.")

              (FNS \SYSQUEUE.DEFPRINT \IPSOCKET.DEFPRINT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'IPSOCKET '\IPSOCKET.DEFPRINT))
                     (P (DEFPRINT 'SYSQUEUE '\SYSQUEUE.DEFPRINT]
              (INITVARS (IPTRACETIME)
                     (IPONLYTYPES)
                     (IPIGNORETYPES)
                     (IPPRINTMACROS)
                     (IPTRACEFLG)
                     (IPTRACEFILE)
                     (\IP.INIT.FILE)
                     (\IP.DEFAULT.CONFIGURATION)
                     (\IP.HOSTNAMES (HASHARRAY 40 1.1))
                     (\IP.HOSTNUMBERS)
                     (INTERNET.LOCAL.DOMAIN))
              (INITRECORDS IP IPSOCKET IPADDRESS)
              (GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS 
                     \IP.HOSTNAMES \IP.INIT.FILE INTERNET.LOCAL.DOMAIN \IP.DEFAULT.CONFIGURATION 
                     \IP.HOSTNUMBERS)
              (FILES (SYSLOAD)
                     TCPHTE TCPLLICMP TCPLLAR)
              (ADDVARS (\PACKET.PRINTERS (2048 . PRINTIP)))
              (FNS \CANONICALIZE.IP.HOSTNAME DODIP.HOSTP IPHOSTADDRESS IPHOSTNAME IPTRACE 
                   IPTRACEWINDOW.BUTTONFN PRINTIP PRINTIPDATA \IPADDRESSCLASS \IPEVENTFN 
                   \IPHOSTADDRESS \IPNETADDRESS \IP.ADDRESS.TO.STRING \IP.BROADCAST.ADDRESS 
                   \IP.LEGAL.ADDRESS \IP.MAKE.BROADCAST.ADDRESS \IP.PRINT.ADDRESS 
                   \IP.READ.STRING.ADDRESS \DOMAIN.NAME.QUALIFY.FULLY))
        (COMS 
              (* ;; "Startup and shutdown")

              (INITVARS (*IP-DEFAULT-HOSTS-FILE*)
                     (TCP.ALWAYS.READ.HOSTS.FILE T)
                     (\TCP.LAST.HOSTS.FILE.DATE)
                     (\TCP.LAST.HOSTS.FILE.READ)
                     (\IPFLG)
                     (\IP.READY)
                     (\IP.READY.EVENT (CREATE.EVENT "IP Ready"))
                     (\IP.WAKEUP.TIMER)
                     (IPTRACEFLG)
                     (\IP.WAKEUP.EVENT (CREATE.EVENT "IP Wakeup")))
              (GLOBALVARS \IPFLG \IP.READY \IP.READY.EVENT \IP.WAKEUP.TIMER \IP.WAKEUP.EVENT 
                     TCP.ALWAYS.READ.HOSTS.FILE \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ 
                     *IP-DEFAULT-HOSTS-FILE*)
              (FNS STOPIP \IPINIT \IPLISTENER \IP.REINITIALIZE.FROM.SCRATCH 
                   \IP.RESTART.FROM.CONFIGURATION \IP.MAYBE.READ.HOSTS.TXT \IP.READ.INIT.FILE 
                   \IP.PROMPT.FOR.FILE.NAME)
              (ADDVARS (RESTARTETHERFNS \IPEVENTFN)))
        (COMS 
              (* ;; "Early IP reception functions")

              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPADDRESSTYPES)))
              (INITVARS (\IP.LOCAL.ADDRESSES)
                     (\IP.SUBNET.MASKS)
                     (\IP.GATEWAY.FLG))
              (VARS (\IP.ADDRESS.BOX (\CREATECELL \FIXP)))
              (GLOBALVARS \IP.LOCAL.ADDRESSES \IP.SUBNET.MASKS \IP.GATEWAY.FLG \IP.ADDRESS.BOX)
              (MACROS \IP.FIX.DEST.HOST \IP.FIX.DEST.NET \IP.FIX.SOURCE.HOST \IP.FIX.SOURCE.NET)
              (FNS \HANDLE.RAW.IP \FORWARD.IP \IP.LOCAL.DESTINATION \IPCHECKSUM \IP.CHECKSUM.OK 
                   \IP.SET.CHECKSUM))
        (COMS 
              (* ;; "Protocol Distribution")

              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPPROTOCOLTYPES)))
              (INITVARS (\IP.PROTOCOLS))
              (GLOBALVARS \IP.PROTOCOLS)
              (FNS \IP.HAND.TO.PROTOCOL \IP.DEFAULT.INPUTFN \IP.DEFAULT.NOSOCKETFN \IP.ADD.PROTOCOL 
                   \IP.DELETE.PROTOCOL \IP.FIND.PROTOCOL \IP.FIND.PROTOCOL.SOCKET \IP.FIND.SOCKET 
                   \IP.OPEN.SOCKET \IP.CLOSE.SOCKET))
        (COMS 
              (* ;; "Fragmentation Handling")

              (DECLARE%: DONTCOPY (EXPORT (RECORDS AssemblyRecord FragmentRecord FragmentID)))
              (INITVARS (\IP.FRAGMENT.LIST)
                     (\IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock")))
              (GLOBALVARS \IP.FRAGMENT.LIST \IP.FRAGMENT.LOCK)
              (CONSTANTS (\IP.FRAGMENTATION.UNIT 8))
              (FNS \HANDLE.RAW.IP.FRAGMENT \IP.NEW.FRAGMENT.LST 
                   \IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER \IP.ADD.FRAGMENT 
                   \IP.FIND.MATCHING.FRAGMENTS \IP.FRAGMENTED.PACKET \IP.CHECK.REASSEMBLY.TIMEOUTS 
                   \IP.DELETE.FRAGMENT \IP.PRINT.FRAGMENT))
        (COMS 
              (* ;; "Option Processing")

              [DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPOPTIONTYPES)
                                         (CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0]
              (FNS \IP.PROCESS.OPTIONS \IP.OPTION.RECORD.ROUTE \IP.OPTION.STRICT.SOURCE.ROUTE 
                   \IP.OPTION.TIMESTAMP))
        (COMS 
              (* ;; "Packet Transmission and routing")

              (INITVARS (\IP.ROUTING.TABLE (CONS))
                     (\IP.DEFAULT.GATEWAY)
                     (\IP.LOCAL.NETWORKS)
                     (\IP.GATEWAY.FORWARDING.FUNCTIONS))
              (GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS 
                     \IP.GATEWAY.FORWARDING.FUNCTIONS)
              (FNS \IP.SETUPIP \IP.TRANSMIT \IP.ROUTE.PACKET)
              (FNS IP.GET IP.SEND IP.PACKET.WATCHER)
              (MACROS IP.SEND))
        (COMS 
              (* ;; "Client functions for building packets")

              (FNS \IP.APPEND.BYTE \IP.APPEND.CELL \IP.APPEND.STRING \IP.APPEND.WORD \IP.GET.BYTE 
                   \IP.GET.CELL \IP.GET.STRING \IP.GET.WORD \IP.PUT.BYTE \IP.PUT.CELL \IP.PUT.STRING
                   \IP.PUT.WORD)
              (MACROS \IP.GET.BYTE \IP.GET.CELL \IP.GET.STRING \IP.GET.WORD \IP.PUT.BYTE \IP.PUT.CELL
                     \IP.PUT.STRING \IP.PUT.WORD))
        (P (MOVD? 'NILL 'IP.DEFAULT.CONFIGURATION))
        (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY 
                                                \IP.INIT.FILE \IP.SUBNET.MASKS 
                                                \PROCESS.AFTEREXIT.EVENT \PROC.READY 
                                                \AR.IP.TO.10MB.ALIST))))

(PUTPROPS TCPLLIP MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP"))



(* ;; "IP definitions and addressing")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS IP [(IPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM]
                  [BLOCKRECORD IPBASE ((IPVERSION BITS 4)    (* ; "Protocol version")
                                       (IPHEADERLENGTH BITS 4)
                                                             (* ; "Head length, in cells")
                                       (IPSERVICE BYTE)      (* ; "Service type")
                                       (IPTOTALLENGTH WORD)  (* ; "Packet length, in bytes")
                                       (IPID WORD)           (* ; "Packet id")
                                       (NIL BITS 1)
                                       (IPDONTFRAGMENT FLAG) (* ; "Don't fragment me")
                                       (IPMOREFRAGMENTS FLAG)(* ; "Last fragment")
                                       (IPFRAGMENTOFFSET BITS 13)
                                                             (* ; "Fragment position")
                                       (IPTIMETOLIVE BYTE)   (* ; "Hop limiter")
                                       (IPPROTOCOL BYTE)     (* ; "Client protocol")
                                       (IPHEADERCHECKSUM WORD)
                                                             (* ; "Header-only checksum")
                                       (IPSOURCEADDRESS FIXP)
                                       (IPDESTINATIONADDRESS FIXP)
                                       (IPOPTIONSSTART BYTE) (* ; "Options or data start here")
                                       )
                         [ACCESSFNS IPSERVICE ((IPSERVICEBASE (LOCF DATUM)))
                                (BLOCKRECORD IPSERVICEBASE ((IPPRECEDENCE BITS 3)
                                                            (IPDELAY FLAG)
                                                            (IPTHROUGHPUT FLAG)
                                                            (IPRELIABILITY FLAG)
                                                            (NIL BITS 2]
                         [ACCESSFNS IPDESTINATIONADDRESS ((IPDESTBASE (LOCF DATUM)))
                                (ACCESSFNS IPDESTBASE ([IPDESTINATIONNET
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSANET)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSBNET)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSCNET)
                                                               of DATUM))
                                                           (T (ERROR "Illegal address class" DATUM)))
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSANET)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSBNET)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSCNET)
                                                               of DATUM with NEWVALUE))
                                                           (T (ERROR "Illegal address class" DATUM]
                                                       (IPDESTINATIONHOST
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSAHOST)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSBHOST)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSCHOST)
                                                               of DATUM))
                                                           (T (ERROR "Illegal address class" DATUM)))
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSAHOST)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSBHOST)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSCHOST)
                                                               of DATUM with NEWVALUE))
                                                           (T (ERROR "Illegal address class" DATUM]
                         (ACCESSFNS IPSOURCEADDRESS ((IPSOURCEBASE (LOCF DATUM)))
                                (ACCESSFNS IPSOURCEBASE ([IPSOURCENET (COND
                                                                         ((EQ \IP.CLASS.A
                                                                              (fetch (IPADDRESS
                                                                                          CLASSA)
                                                                                 of DATUM))
                                                                          (fetch (IPADDRESS
                                                                                      CLASSANET)
                                                                             of DATUM))
                                                                         ((EQ \IP.CLASS.B
                                                                              (fetch (IPADDRESS
                                                                                          CLASSB)
                                                                                 of DATUM))
                                                                          (fetch (IPADDRESS
                                                                                      CLASSBNET)
                                                                             of DATUM))
                                                                         ((EQ \IP.CLASS.C
                                                                              (fetch (IPADDRESS
                                                                                          CLASSC)
                                                                                 of DATUM))
                                                                          (fetch (IPADDRESS
                                                                                      CLASSCNET)
                                                                             of DATUM))
                                                                         (T (ERROR 
                                                                              "Illegal address class"
                                                                                   DATUM)))
                                                                (COND
                                                                   ((EQ \IP.CLASS.A
                                                                        (fetch (IPADDRESS CLASSA)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS CLASSANET
                                                                                        )
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.B
                                                                        (fetch (IPADDRESS CLASSB)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS CLASSBNET
                                                                                        )
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.C
                                                                        (fetch (IPADDRESS CLASSC)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS CLASSCNET
                                                                                        )
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   (T (ERROR "Illegal address class"
                                                                             DATUM]
                                                         (IPSOURCEHOST (COND
                                                                          ((EQ \IP.CLASS.A
                                                                               (fetch
                                                                                (IPADDRESS CLASSA)
                                                                                  of DATUM))
                                                                           (fetch (IPADDRESS
                                                                                       CLASSAHOST)
                                                                              of DATUM))
                                                                          ((EQ \IP.CLASS.B
                                                                               (fetch
                                                                                (IPADDRESS CLASSB)
                                                                                  of DATUM))
                                                                           (fetch (IPADDRESS
                                                                                       CLASSBHOST)
                                                                              of DATUM))
                                                                          ((EQ \IP.CLASS.C
                                                                               (fetch
                                                                                (IPADDRESS CLASSC)
                                                                                  of DATUM))
                                                                           (fetch (IPADDRESS
                                                                                       CLASSCHOST)
                                                                              of DATUM))
                                                                          (T (ERROR 
                                                                              "Illegal address class"
                                                                                    DATUM)))
                                                                (COND
                                                                   ((EQ \IP.CLASS.A
                                                                        (fetch (IPADDRESS CLASSA)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS 
                                                                                        CLASSAHOST)
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.B
                                                                        (fetch (IPADDRESS CLASSB)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS 
                                                                                        CLASSBHOST)
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.C
                                                                        (fetch (IPADDRESS CLASSC)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS 
                                                                                        CLASSCHOST)
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   (T (ERROR "Illegal address class"
                                                                             DATUM]
                  (TYPE? (type? ETHERPACKET DATUM)))

(DATATYPE IPSOCKET ((PROTOCOL BYTE)
                        (IPSLINK POINTER)                    (* ; 
                                                           "Other sockets of this protocol type")
                        (NIL BYTE)
                        (IPSQUEUE POINTER)                   (* ; 
                                                           "Queue of packets for this protocol")
                        (IPSQUEUELENGTH WORD)                (* ; "Count of packets of input queue")
                        (IPSQUEUEALLOC WORD)                 (* ; "Max count allowed")
                        (IPSDESTSOCKETCOMPAREFN POINTER)     (* ; 
                                         "Call this to compare dest protocol socket to this socket")
                        (IPSOCKET POINTER)                   (* ; "This socket")
                        (IPSINPUTFN POINTER)                 (* ; "Call to hand packet to protocol")
                        (IPSEVENT POINTER)                   (* ; "Notify me when a packet arrives")
                        (IPSNOSOCKETFN POINTER)              (* ; "Call this when no socket found")
                        (IPSICMPFN POINTER)                  (* ; 
                                       "Call this when an ICMP packet is received on this protocol")
                        )
                       IPSQUEUE _ (create SYSQUEUE)
                       IPSQUEUEALLOC _ \IP.MAX.EPKTS.ON.QUEUE IPSEVENT _ (CREATE.EVENT)
                       IPSINPUTFN _ (FUNCTION \IP.DEFAULT.INPUTFN)
                       IPSICMPFN _ (FUNCTION \RELEASE.ETHERPACKET))

(BLOCKRECORD IPADDRESS ((ADDRESS FIXP))

                           (* ;; "Class A nets: high bit is 0")

                           (BLOCKRECORD IPADDRESS ((CLASSA BITS 1)
                                                   (CLASSANET BITS 7)
                                                   (CLASSAHOST BITS 24)))

                           (* ;; "Class B nets: high 2 bits are 10")

                           (BLOCKRECORD IPADDRESS ((CLASSB BITS 2)))
                           (BLOCKRECORD IPADDRESS ((CLASSBNET BITS 16)
                                                   (CLASSBHOST BITS 16)))

                           (* ;; "Class C nets: high 3 bits are 110")

                           (BLOCKRECORD IPADDRESS ((CLASSC BITS 3)))
                           (BLOCKRECORD IPADDRESS ((CLASSCNETB1 BITS 8)
                                                   (CLASSCNETB2 BITS 8)
                                                   (CLASSCNETB3 BITS 8)
                                                   (CLASSCHOST BITS 8)))
                                                             (* ; 
                          "I wish I could say just net bits 24, host bits 8, but BLOCKRECORD barfs")
                           (BLOCKRECORD IPADDRESS ((CLASSCNETHI BITS 16)))
                           [ACCESSFNS IPADDRESS ((CLASSCNET (\MAKENUMBER (FETCH CLASSCNETB1
                                                                            OF DATUM)
                                                                   (LOGOR (LLSH (FETCH 
                                                                                       CLASSCNETB2
                                                                                   OF DATUM)
                                                                                8)
                                                                          (FETCH CLASSCNETB3
                                                                             OF DATUM)))
                                                        (PROGN (REPLACE CLASSCNETHI OF DATUM
                                                                  WITH (LRSH NEWVALUE 8))
                                                               (REPLACE CLASSCNETB3 OF DATUM
                                                                  WITH (LOGAND NEWVALUE 255))
                                                               DATUM])
)

(/DECLAREDATATYPE 'IPSOCKET '(BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER 
                                   POINTER POINTER)
       '((IPSOCKET 0 (BITS . 7))
         (IPSOCKET 0 POINTER)
         (IPSOCKET 2 (BITS . 7))
         (IPSOCKET 2 POINTER)
         (IPSOCKET 4 (BITS . 15))
         (IPSOCKET 5 (BITS . 15))
         (IPSOCKET 6 POINTER)
         (IPSOCKET 8 POINTER)
         (IPSOCKET 10 POINTER)
         (IPSOCKET 12 POINTER)
         (IPSOCKET 14 POINTER)
         (IPSOCKET 16 POINTER))
       '18)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \IPOVLEN 20)

(RPAQQ \MAX.IPDATALENGTH 556)

(RPAQQ \IP.PROTOCOLVERSION 4)

(RPAQQ \IP.MAX.EPKTS.ON.QUEUE 16)

(RPAQQ \IP.DEFAULT.TIME.TO.LIVE 120)

(RPAQQ \IP.WAKEUP.INTERVAL 15000)


(CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE 
       \IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL)
)

(RPAQQ IPPACKETTYPES ((\EPT.IP 2048)
                          (\EPT.AR 2054)
                          (\EET.IP 513)
                          (\EPT.CHAOS 2052)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \EPT.IP 2048)

(RPAQQ \EPT.AR 2054)

(RPAQQ \EET.IP 513)

(RPAQQ \EPT.CHAOS 2052)


(CONSTANTS (\EPT.IP 2048)
       (\EPT.AR 2054)
       (\EET.IP 513)
       (\EPT.CHAOS 2052))
)

(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0)
                             (\ICMP.HOST.UNREACHABLE 1)
                             (\ICMP.PROTOCOL.UNREACHABLE 2)
                             (\ICMP.PORT.UNREACHABLE 3)
                             (\ICMP.CANT.FRAGMENT 4)
                             (\ICMP.SOURCE.ROUTE 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.NET.UNREACHABLE 0)

(RPAQQ \ICMP.HOST.UNREACHABLE 1)

(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)

(RPAQQ \ICMP.PORT.UNREACHABLE 3)

(RPAQQ \ICMP.CANT.FRAGMENT 4)

(RPAQQ \ICMP.SOURCE.ROUTE 5)


(CONSTANTS (\ICMP.NET.UNREACHABLE 0)
       (\ICMP.HOST.UNREACHABLE 1)
       (\ICMP.PROTOCOL.UNREACHABLE 2)
       (\ICMP.PORT.UNREACHABLE 3)
       (\ICMP.CANT.FRAGMENT 4)
       (\ICMP.SOURCE.ROUTE 5))
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS \IPDATABASE MACRO (LAMBDA (IP)                 (* ejs%: "26-Dec-84 17:50")
                                                             (* Returns the LOCF of the start of 
                                                           the data in the packet)
                              (\ADDBASE (fetch (IP IPBASE) of IP)
                                     (UNFOLD (fetch (IP IPHEADERLENGTH) of IP)
                                            2]

[PUTPROPS \IPDATALENGTH MACRO (LAMBDA (IP)
                                (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of IP)
                                       (LLSH (fetch (IP IPHEADERLENGTH) of IP)
                                             2]
)

(* "END EXPORTED DEFINITIONS")

)

(ADDTOVAR *IP-PROTOCOL-NAME-FROM-NUMBER* (17 . "UDP")
                                             (6 . "TCP")
                                             (1 . "ICMP"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *IP-PROTOCOL-NAME-FROM-NUMBER*)
)



(* ;; 
"value in sysout is too small.  This is 512-(indexf (fetch epencapsulation))-2.  489 is more correct, but let's leave a word of slop for off-by-ones"
)


(RPAQQ \10MBPACKETLENGTH 488)



(* ;; "Make it easier to see queuelength without opening up q.")

(DEFINEQ

(\SYSQUEUE.DEFPRINT
  [LAMBDA (Q STREAM)                                     (* ; "Edited  8-Sep-89 11:06 by bvm")
    (\DEFPRINT.BY.NAME Q STREAM (if (fetch (SYSQUEUE SYSQUEUEHEAD) of Q)
                                    then (\QUEUELENGTH Q)
                                  else "Empty")
           "SysQueue"])

(\IPSOCKET.DEFPRINT
  [LAMBDA (SOCKET STREAM)                                (* ; "Edited 25-Aug-88 17:51 by bvm")

    (* ;; "Print an object using its name, for example, #<FDev ERIS/76,5432>.  NAME is the object's name (or NIL if this one happens to be nameless), TYPENAME is a string giving the generic name you want to appear in front, e.g., %"FDev%"")

    (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
    (\OUTCHAR STREAM (CHARCODE <))
    (LET ((TYPE (CDR (ASSOC (fetch (IPSOCKET PROTOCOL) of SOCKET)
                            *IP-PROTOCOL-NAME-FROM-NUMBER*)))
          (NUM (fetch (IPSOCKET IPSOCKET) of SOCKET))
          (*PRINT-BASE* 10))
         (\SOUT (if TYPE
                    then (MKSTRING TYPE)
                  else "IP")
                STREAM)
         (\SOUT " Socket" STREAM)
         (if (if (FIXP NUM)
                   elseif (NULL NUM)
                     then                                (* ; "I assume this is the master")
                           (SETQ NUM "Head"))
             then (\OUTCHAR STREAM (CHARCODE SPACE))
                   (PRIN3 NUM STREAM)))
    (\OUTCHAR STREAM (CHARCODE /))
    (\PRINTADDR SOCKET STREAM)
    (\OUTCHAR STREAM (CHARCODE >))
    T])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(DEFPRINT 'IPSOCKET '\IPSOCKET.DEFPRINT)


(DEFPRINT 'SYSQUEUE '\SYSQUEUE.DEFPRINT)
)

(RPAQ? IPTRACETIME )

(RPAQ? IPONLYTYPES )

(RPAQ? IPIGNORETYPES )

(RPAQ? IPPRINTMACROS )

(RPAQ? IPTRACEFLG )

(RPAQ? IPTRACEFILE )

(RPAQ? \IP.INIT.FILE )

(RPAQ? \IP.DEFAULT.CONFIGURATION )

(RPAQ? \IP.HOSTNAMES (HASHARRAY 40 1.1))

(RPAQ? \IP.HOSTNUMBERS )

(RPAQ? INTERNET.LOCAL.DOMAIN )

(/DECLAREDATATYPE 'IPSOCKET '(BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER 
                                   POINTER POINTER)
       '((IPSOCKET 0 (BITS . 7))
         (IPSOCKET 0 POINTER)
         (IPSOCKET 2 (BITS . 7))
         (IPSOCKET 2 POINTER)
         (IPSOCKET 4 (BITS . 15))
         (IPSOCKET 5 (BITS . 15))
         (IPSOCKET 6 POINTER)
         (IPSOCKET 8 POINTER)
         (IPSOCKET 10 POINTER)
         (IPSOCKET 12 POINTER)
         (IPSOCKET 14 POINTER)
         (IPSOCKET 16 POINTER))
       '18)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS \IP.HOSTNAMES 
       \IP.INIT.FILE INTERNET.LOCAL.DOMAIN \IP.DEFAULT.CONFIGURATION \IP.HOSTNUMBERS)
)

(FILESLOAD (SYSLOAD)
       TCPHTE TCPLLICMP TCPLLAR)

(ADDTOVAR \PACKET.PRINTERS (2048 . PRINTIP))
(DEFINEQ

(\CANONICALIZE.IP.HOSTNAME
  [LAMBDA (NAME)                                         (* ; "Edited 12-Apr-88 17:18 by bvm")
    (AND \IP.READY (IPHOSTADDRESS NAME)
         NAME])

(DODIP.HOSTP
  [LAMBDA (NAME)                                         (* ; "Edited 27-Feb-89 21:49 by welch")
    (COND
       ((NULL NAME)
        NIL)
       ((NUMBERP NAME))
       (T (LET [(NAME (\DOMAIN.NAME.QUALIFY.FULLY (U-CASE NAME]
               (COND
                  ((IPHOSTADDRESS NAME))
                  (T (if (CL:FBOUNDP 'DOMAIN.LOOKUP.ADDRESS)
                         then (CAR (DOMAIN.LOOKUP.ADDRESS NAME])

(IPHOSTADDRESS
  [LAMBDA (NAME)                                         (* ; "Edited 19-Jan-88 14:41 by FS")
    (LET (ENTRY)

         (* ;; "Hack to handle strings, by canonicalizing NAME")

         (SETQ NAME (MKATOM (U-CASE NAME)))
         (SETQ ENTRY (GETHASH NAME \IP.HOSTNAMES))
         (COND
            (ENTRY (LET [(ADDRESS (CAR (fetch (HOSTS.TXT.ENTRY HTE.ADDRESSES) of ENTRY]
                        [COND
                           ((NOT (SASSOC ADDRESS \IP.HOSTNUMBERS))
                            (push \IP.HOSTNUMBERS (CONS ADDRESS NAME]
                        ADDRESS))
            ((\IP.READ.STRING.ADDRESS NAME])

(IPHOSTNAME
  [LAMBDA (IPADDRESS)                                    (* ejs%: "22-Apr-85 13:54")
    (OR (CDR (SASSOC IPADDRESS \IP.HOSTNUMBERS))
        (MKATOM (\IP.ADDRESS.TO.STRING IPADDRESS])

(IPTRACE
  [LAMBDA (FLG REGION)                                   (* ; "Edited 13-Sep-88 14:53 by bvm")
    (MAKE-NETWORK-TRACE-WINDOW 'IPTRACEFLG 'IPTRACEFILE "IP traffic" REGION FLG])

(IPTRACEWINDOW.BUTTONFN
  [LAMBDA (WINDOW)                                       (* ejs%: " 2-Jun-85 13:05")
    (COND
       ((MOUSESTATE (NOT UP))
        (SETQ IPTRACEFLG (SELECTQ IPTRACEFLG
                             (NIL T)
                             (T 'PEEK)
                             (PEEK NIL)
                             NIL))
        (printout WINDOW T "[Tracing " (SELECTQ IPTRACEFLG
                                           (T "on")
                                           (PEEK "peek")
                                           "off")
               "]" T])

(PRINTIP
  [LAMBDA (IP CALLER FILE PRE.NOTE DOFILTER)             (* ; "Edited 28-Apr-88 14:05 by bvm")
    (PROG ((*STANDARD-OUTPUT* (GETSTREAM (OR FILE IPTRACEFILE)
                                     'OUTPUT))
           (PROTOCOL (fetch (IP IPPROTOCOL) of IP))
           MACRO LENGTH)
          [COND
             (DOFILTER (COND
                          ((COND
                              (IPONLYTYPES (NOT (FMEMB PROTOCOL IPONLYTYPES)))
                              (IPIGNORETYPES (FMEMB PROTOCOL IPIGNORETYPES)))
                           (RETURN (PRIN1 (SELECTQ CALLER
                                              ((PUT RAWPUT) 
                                                   '!)
                                              ((GET RAWGET) 
                                                   '+)
                                              '?]
          (AND PRE.NOTE (printout NIL T PRE.NOTE))
          (if CALLER
              then                                       (* ; "Print GET or PUT")
                    (FRESHLINE)
                    (PRINTOUT NIL CALLER " "))
          (printout NIL "From " (\IP.ADDRESS.TO.STRING (fetch (IP IPSOURCEADDRESS)
                                                              of IP))
                 " to "
                 (\IP.ADDRESS.TO.STRING (fetch (IP IPDESTINATIONADDRESS) of IP)))
          (if IPTRACETIME
              then (LET ((CSECS (\CENTICLOCK IP)))
                            (PRINTOUT NIL " [" |.I4| (IQUOTIENT CSECS 100)
                                   "." |.I2..T| (IREMAINDER CSECS 100)
                                   "]")))
          (TERPRI)
          [COND
             ((AND (SETQ MACRO (CDR (FASSOC PROTOCOL IPPRINTMACROS)))
                   (NLISTP MACRO))                           (* ; 
                                       "Macro is a function to which to dispatch for the printing.")
              (CL:FUNCALL MACRO IP *STANDARD-OUTPUT*)
              (RETURN (TERPRI]
          (printout NIL "Length = " |.P2| (SETQ LENGTH (fetch (IP IPTOTALLENGTH) of IP))
                 " bytes" " (header + " |.P2| (IDIFFERENCE LENGTH \IPOVLEN)
                 ")" T "Protocol = ")
          (PRINTCONSTANT PROTOCOL IPPROTOCOLTYPES NIL)
          (TERPRI)
          [COND
             ((IGREATERP LENGTH \IPOVLEN)                    (* ; "MACRO tells how to print data.")
              (PRIN1 "Contents: ")
              (PRINTIPDATA IP (OR MACRO '(BYTES 12 |...|]
          (TERPRI)
          (RETURN IP])

(PRINTIPDATA
  [LAMBDA (IP MACRO OFFSET FILE)                         (* ejs%: "27-Dec-84 18:43")

         (* * Prints DATA part of IP starting at OFFSET
       (Default zero) according to MACRO. MACRO contains elements describing what 
       format the data is in -
       WORDS, BYTES, CHARS%: print as words, bytes
       (numeric) or ascii characters -
       <number>%: subsequent commands apply starting at this byte offset -
       ...%: print "..." and quit if you still have data at this point)

    (PROG ((DATA (\IPDATABASE IP))
           (LENGTH (\IPDATALENGTH IP)))
          (PRINTPACKETDATA DATA OFFSET MACRO LENGTH FILE])

(\IPADDRESSCLASS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 12:49 by bvm")
    (if (SMALLP IPADDRESS)
        then                                             (* ; "bogus unless it's broadcastp")
              '\IP.CLASS.A
      elseif (EQ \IP.CLASS.C (SETQ IPADDRESS (fetch (IPADDRESS CLASSC) of IPADDRESS)))
        then '\IP.CLASS.C
      elseif (EQ \IP.CLASS.B (SETQ IPADDRESS (LRSH IPADDRESS 1)))
        then '\IP.CLASS.B
      elseif (EQ \IP.CLASS.A (LRSH IPADDRESS 1))
        then '\IP.CLASS.A])

(\IPEVENTFN
  [LAMBDA (EVENT)                               (* ; "Edited 13-Sep-88 18:53 by Hiroshi Hayata")

    (* ;; "If maiko, do nothing. ")

    (* ;; "Call of \IPINIT with AFTERSYSOUT on maiko cause RAID.")

    (COND
       ((EQ \MACHINETYPE \MAIKO)
        NIL)
       (T (COND
             (\IPFLG (\IPINIT EVENT])

(\IPHOSTADDRESS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 12:43 by bvm")
    (if (SMALLP IPADDRESS)
        then                                             (* ; "can only be class a or bogus")
              (LOGAND IPADDRESS MAX.SMALLP)
      elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS)
                     \IP.CLASS.A)
        then (fetch (IPADDRESS CLASSAHOST) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS)
                     \IP.CLASS.B)
        then (fetch (IPADDRESS CLASSBHOST) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS)
                     \IP.CLASS.C)
        then (fetch (IPADDRESS CLASSCHOST) of IPADDRESS])

(\IPNETADDRESS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 12:45 by bvm")
    (if (SMALLP IPADDRESS)
        then                                             (* ; "bogus unless it's broadcastp")
              (if (< IPADDRESS 0)
                  then -1
                else 0)
      elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS)
                     \IP.CLASS.A)
        then (fetch (IPADDRESS CLASSANET) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS)
                     \IP.CLASS.B)
        then (fetch (IPADDRESS CLASSBNET) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS)
                     \IP.CLASS.C)
        then (fetch (IPADDRESS CLASSCNET) of IPADDRESS])

(\IP.ADDRESS.TO.STRING
  [LAMBDA (IPADDRESS)                                    (* ejs%: "28-Dec-84 08:43")
    (RESETFORM (RADIX 10)
           (CONCAT (LDB (BYTE 8 24)
                        IPADDRESS)
                  "."
                  (LDB (BYTE 8 16)
                       IPADDRESS)
                  "."
                  (LDB (BYTE 8 8)
                       IPADDRESS)
                  "."
                  (LDB (BYTE 8 0)
                       IPADDRESS])

(\IP.BROADCAST.ADDRESS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 14:59 by bvm")

    (* ;; 
  "0's in the host field are now considered broadcasts, so this code works with Berkeley Unix")

    (LET (HOST MASK)
         (if (SMALLP IPADDRESS)
             then (OR (EQ IPADDRESS 0)
                          (EQ IPADDRESS -1))
           elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS)
                          \IP.CLASS.A)
             then [if (AND \IP.SUBNET.MASKS (ASSOC (fetch (IPADDRESS CLASSANET)
                                                              of IPADDRESS)
                                                           \IP.LOCAL.NETWORKS))
                          then                           (* ; 
    "If it's our subnet, check only the subnetted host part.  The LOGOR patches bogus subnet masks")
                                [SETQ HOST (LOGAND IPADDRESS (SETQ MASK (LOGXOR (LOGOR (CDAR 
                                                                                     \IP.SUBNET.MASKS
                                                                                             )
                                                                                       -16777216)
                                                                               -1]
                                (OR (EQ HOST 0)
                                    (EQL HOST MASK))
                        else (SETQ HOST (fetch (IPADDRESS CLASSAHOST) of IPADDRESS))
                              (OR (EQ HOST 0)
                                  (EQL HOST (MASK.1'S 0 24]
           elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS)
                          \IP.CLASS.B)
             then [if (AND \IP.SUBNET.MASKS (ASSOC (fetch (IPADDRESS CLASSBNET)
                                                              of IPADDRESS)
                                                           \IP.LOCAL.NETWORKS))
                          then [SETQ HOST (LOGAND IPADDRESS (SETQ MASK (LOGXOR
                                                                            (LOGOR (CDAR 
                                                                                     \IP.SUBNET.MASKS
                                                                                         )
                                                                                   -65536)
                                                                            -1]
                                (OR (EQ HOST 0)
                                    (EQ HOST MASK))
                        else (SETQ HOST (fetch (IPADDRESS CLASSBHOST) of IPADDRESS))
                              (OR (EQ HOST 0)
                                  (EQ HOST (MASK.1'S 0 16]
           elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS)
                          \IP.CLASS.C)
             then (SETQ HOST (fetch (IPADDRESS CLASSCHOST) of IPADDRESS)) 
                                                             (* ; "No subnetting here")
                   (OR (EQ HOST 0)
                       (EQ HOST (MASK.1'S 0 8)))
           elseif (EQ (fetch (IPADDRESS CLASSBNET) of IPADDRESS)
                          MAX.SMALLP)
             then                                        (* ; 
                                             "Sort of illegal, but recognize all ones as broadcast")
                   (EQ (fetch (IPADDRESS CLASSBHOST) of IPADDRESS)
                       MAX.SMALLP])

(\IP.LEGAL.ADDRESS
  [LAMBDA (ADDRESS)                                      (* ejs%: "25-Mar-86 16:00")
    (AND (NOT (EQ ADDRESS 0))
         (NOT (EQ ADDRESS -1))
         (OR (EQ \IP.CLASS.C (SETQ ADDRESS (LRSH ADDRESS 29)))
             (EQ \IP.CLASS.B (SETQ ADDRESS (LRSH ADDRESS 1)))
             (EQ \IP.CLASS.A (LRSH ADDRESS 1])

(\IP.MAKE.BROADCAST.ADDRESS
  [LAMBDA (IPADDRESS)                                    (* ejs%: " 3-Jun-85 01:02")
    (SELECTQ (\IPADDRESSCLASS IPADDRESS)
        (\IP.CLASS.A (LOGOR (MASK.1'S 0 24)
                            IPADDRESS))
        (\IP.CLASS.B (LOGOR (MASK.1'S 0 16)
                            IPADDRESS))
        (\IP.CLASS.C (LOGOR (MASK.1'S 0 8)
                            IPADDRESS))
        (SHOULDNT])

(\IP.PRINT.ADDRESS
  [LAMBDA (IPADDRESS FILE)                               (* ejs%: "28-Dec-84 08:42")
    (RESETFORM (RADIX 10)
           (PRIN1 (LDB (BYTE 8 24)
                       IPADDRESS)
                  FILE)
           (PRIN1 "." FILE)
           (PRIN1 (LDB (BYTE 8 16)
                       IPADDRESS)
                  FILE)
           (PRIN1 "." FILE)
           (PRIN1 (LDB (BYTE 8 8)
                       IPADDRESS)
                  FILE)
           (PRIN1 "." FILE)
           (PRIN1 (LDB (BYTE 8 0)
                       IPADDRESS)
                  FILE)
           IPADDRESS])

(\IP.READ.STRING.ADDRESS
  [LAMBDA (STRING.OR.ATOM)                               (* ; "Edited 21-Apr-88 14:41 by bvm")
    (for CHAR instring (MKSTRING STRING.OR.ATOM) bind (RESULT _ (NCREATE 'FIXP))
                                                               (INDEX _ 0)
                                                               BYTE
       do (if (> INDEX 3)
                  then                                   (* ; 
                                            "Got 3 parts and there's still more to go, must be bad")
                        (RETURN NIL)
                elseif (EQ CHAR (CHARCODE %.))
                  then (if BYTE
                               then (\PUTBASEBYTE RESULT INDEX BYTE))
                        (SETQ BYTE NIL)
                        (add INDEX 1)
                elseif (AND (SETQ CHAR (CL:DIGIT-CHAR-P (CL:INT-CHAR CHAR)))
                                (< (SETQ BYTE (+ (if BYTE
                                                     then (TIMES BYTE 10)
                                                   else 0)
                                                 CHAR))
                                   256))
                  then                                   (* ; 
                                  "Accumulated decimal digit, and we haven't overflowed a byte yet")
                else                                     (* ; "Malformed")
                      (RETURN NIL)) finally (if BYTE
                                                    then (\PUTBASEBYTE RESULT INDEX BYTE)
                                                          (add INDEX 1))
                                          (RETURN (AND (EQ INDEX 4)
                                                       RESULT])

(\DOMAIN.NAME.QUALIFY.FULLY
  [LAMBDA (NAME)                                       (* ; "Edited 29-Aug-90 16:27 by gadener")
                                                             (* Make a fully qualified domain 
                                                           name from a partial one)
    (if (OR (NULL INTERNET.LOCAL.DOMAIN)
                (STRPOS "." NAME))
        then NAME
      else (MKATOM (CONCAT NAME "." INTERNET.LOCAL.DOMAIN])
)



(* ;; "Startup and shutdown")


(RPAQ? *IP-DEFAULT-HOSTS-FILE* )

(RPAQ? TCP.ALWAYS.READ.HOSTS.FILE T)

(RPAQ? \TCP.LAST.HOSTS.FILE.DATE )

(RPAQ? \TCP.LAST.HOSTS.FILE.READ )

(RPAQ? \IPFLG )

(RPAQ? \IP.READY )

(RPAQ? \IP.READY.EVENT (CREATE.EVENT "IP Ready"))

(RPAQ? \IP.WAKEUP.TIMER )

(RPAQ? IPTRACEFLG )

(RPAQ? \IP.WAKEUP.EVENT (CREATE.EVENT "IP Wakeup"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IPFLG \IP.READY \IP.READY.EVENT \IP.WAKEUP.TIMER \IP.WAKEUP.EVENT 
       TCP.ALWAYS.READ.HOSTS.FILE \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ 
       *IP-DEFAULT-HOSTS-FILE*)
)
(DEFINEQ

(STOPIP
  [LAMBDA NIL                                            (* ejs%: "28-Dec-84 08:10")
    (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.IP))
    (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.AR))
    (DEL.PROCESS '\IPLISTENER)
    (SETQ \IPFLG (SETQ \IP.READY NIL])

(\IPINIT
  [LAMBDA (EVENT)                                        (* ; "Edited 18-Mar-88 17:22 by bvm")

    (* ;; "Initialize IP protocol.  Called with EVENT NIL for explicit restart, RESTART from RESTART.ETHER, otherwise from usual around exit events via \ETHEREVENTFN and RESTARTETHERFNS after Pup and/an \icmp.echo.reply")

    (* ;; "or NS turned on.")

    (SELECTQ EVENT
        ((NIL RESTART AFTERSYSOUT AFTERMAKESYS AFTERLOGOUT AFTERSAVEVM) 
             (if (AND (NULL \IPFLG)
                          (NOT (NULL EVENT)))
                 then                                    (* ; 
                                     "Nothing to do.  Only turn IP on for explicit call to \IPINIT")
                       NIL
               elseif [OR (NULL EVENT)
                              (NULL \IP.DEFAULT.CONFIGURATION)
                              (NOT (EQUAL \MY.NSHOSTNUMBER (fetch (IPINIT LOCAL.NSHOSTNUMBER)
                                                              of \IP.DEFAULT.CONFIGURATION]
                 then                                    (* ; 
                           "Machine changed, or caller explicitly wants us to reread the init file")
                       (SETQ \IP.DEFAULT.CONFIGURATION NIL)
                       (SETQ \IP.LOCAL.ADDRESSES NIL)
                       (SETQ \IP.LOCAL.NETWORKS NIL)
                       (SETQ \IP.SUBNET.MASKS NIL)
                       (DEL.PROCESS '\IPLISTENER)
                       [SELECTQ EVENT
                           ((NIL RESTART)                    (* ; "Can do it here--explicit manual restart.  Otherwise spawn process, so that we can do arbitrary things like rely on other devices initialized later than ether")
                                (\IP.REINITIALIZE.FROM.SCRATCH))
                           (ADD.PROCESS `(\IP.REINITIALIZE.FROM.SCRATCH ',EVENT]
               else (\IP.RESTART.FROM.CONFIGURATION EVENT)))
        NIL])

(\IPLISTENER
  [LAMBDA NIL                                            (* ejs%: "25-Jun-85 18:52")

         (* * IP background process)

    (SETQ \IP.WAKEUP.TIMER (SETUPTIMER \IP.WAKEUP.INTERVAL))
    (bind [\AR.WAKEUP.TIMER _ (SETUPTIMER (CONSTANT (ITIMES 4 \IP.WAKEUP.INTERVAL] while
                                                                                       T
       do (AWAIT.EVENT \IP.WAKEUP.EVENT \IP.WAKEUP.INTERVAL)
             (\IP.CHECK.REASSEMBLY.TIMEOUTS)
             (COND
                ((TIMEREXPIRED? \AR.WAKEUP.TIMER)
                 (\AR.DAEMON)
                 (SETQ \AR.WAKEUP.TIMER (SETUPTIMER (CONSTANT (ITIMES 4 \IP.WAKEUP.INTERVAL))
                                               \AR.WAKEUP.TIMER])

(\IP.REINITIALIZE.FROM.SCRATCH
  [LAMBDA (EVENT)                                        (* ; "Edited 20-Jan-89 18:35 by bvm")
    (DECLARE (GLOBALVARS \IP.DEFAULT.CONFIGURATION \IP.LOCAL.ADDRESSES))

    (* ;; "Called when we have never enabled IP, or the machine's address has changed.")

    (RESETBUFS (PROG (FILE ADDRESS.STRING HOSTS.FILE HOSTNAME ADDRESSES)

                (* ;; 
         "This is a kludge until we know more about IP routing and reverse address resolution (??)")

                     [SETQ \IP.DEFAULT.CONFIGURATION (COND
                                                        ((AND (SETQ FILE (INFILEP '{DSK}IP.INIT))
                                                              (\IP.READ.INIT.FILE FILE)))
                                                        ((IP.DEFAULT.CONFIGURATION))
                                                        ((AND (SETQ FILE (\IP.PROMPT.FOR.FILE.NAME
                                                                          
                                "Please enter the name of the IP initialization file for this host: "
                                                                          ))
                                                              (\IP.READ.INIT.FILE FILE)))
                                                        (T   (* ; 
                                        "User declined to specify, or init file failed, so give up")
                                                           (PRINTOUT T "IP not initialized" T)
                                                           (RETURN NIL]
                     (COND
                        ((SETQ FILE (OR (fetch (IPINIT HTE.FILE) of \IP.DEFAULT.CONFIGURATION
                                               )
                                        *IP-DEFAULT-HOSTS-FILE*))

                         (* ;; 
               "there is a hosts file in the configuration.  Now see if we really want to read it.")

                         (\IP.MAYBE.READ.HOSTS.TXT T FILE)))
                     (COND
                        ([AND (NOT (SETQ HOSTNAME (fetch (IPINIT HOSTNAME) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                         )))
                              (SETQ HOSTNAME (AND (EQ \PUP.READY T)
                                                  (U-CASE (ETHERHOSTNAME]
                         (replace (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION with
                                                                                         HOSTNAME)))
                     [COND
                        [(SETQ ADDRESSES (fetch (IPINIT LOCAL.ADDRESSES) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                ))
                         (SETQ \IP.LOCAL.ADDRESSES (for ADDR in ADDRESSES
                                                      collect (\IP.READ.STRING.ADDRESS ADDR]
                        ((AND HOSTNAME (SETQ ADDRESSES (DODIP.HOSTP HOSTNAME)))
                         (SETQ \IP.LOCAL.ADDRESSES (LIST ADDRESSES)))
                        (T (until (SETQ ADDRESS.STRING (PROMPTFORWORD 
                                        "Please enter this machine's IP host address (e.g. 39.9.0.9)"
                                                                  )))
                           (SETQ \IP.LOCAL.ADDRESSES (LIST (\IP.READ.STRING.ADDRESS 
                                                                  ADDRESS.STRING)))
                           (COND
                              (HOSTNAME                      (* ; 
                                                           "Associate name with local address(es)")
                                     (PUTHASH HOSTNAME [create HOSTS.TXT.ENTRY
                                                              HTE.TYPE _ 'HOST
                                                              HTE.ADDRESSES _ \IP.LOCAL.ADDRESSES
                                                              HTE.NAMES _ (LIST HOSTNAME)
                                                              HTE.MACHINE.TYPE _
                                                              (SELECTQ (MACHINETYPE)
                                                                  (DOVE 'XEROX-1185)
                                                                  (DANDELION 'XEROX-1108)
                                                                  (DOLPHIN 'XEROX-1100)
                                                                  (DORADO 'XEROX-1132)
                                                                  'XEROX-11XX)
                                                              HTE.OS.TYPE _ 'INTERLISP
                                                              HTE.PROTOCOLS _ '((TCP)
                                                                                (IP]
                                            \IP.HOSTNAMES]
                     (\IP.RESTART.FROM.CONFIGURATION EVENT T])

(\IP.RESTART.FROM.CONFIGURATION
  [LAMBDA (EVENT NEW.INIT)                               (* ; "Edited 26-Feb-89 21:28 by welch")

    (* ;; "Reinitialize IP after logout, etc, from the info in the default configuration.  This is the only place that sets \IP.READY true.")

    (GLOBALVARS INTERNET.LOCAL.DOMAIN)
    (PROG ((GATE (fetch (IPINIT DEFAULT.GATEWAY) of \IP.DEFAULT.CONFIGURATION))
           (NETS (fetch (IPINIT LOCAL.NETWORKS) of \IP.DEFAULT.CONFIGURATION))
           PROC NDB)
          (SETQ \IP.DEFAULT.GATEWAY (AND GATE (\IP.READ.STRING.ADDRESS GATE)))
          (SETQ \IP.ROUTING.TABLE (CONS))
          (SETQ \AR.IP.TO.10MB.ALIST NIL)
          (SETQ INTERNET.LOCAL.DOMAIN (fetch (IPINIT LOCAL.DOMAIN) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                             ))
          [COND
             [(EQLENGTH NETS (LENGTH \IP.LOCAL.ADDRESSES))

              (* ;; 
  "List tells net numbers of each directly connected net.  Each element = (%"net.number%" . type).")

              (SETQ \IP.LOCAL.NETWORKS (bind NDB for NET.AND.TYPE in NETS as ADDRESS
                                          in \IP.LOCAL.ADDRESSES
                                          collect (LET* [(TYPE (CDR NET.AND.TYPE))
                                                             [NET (\IPNETADDRESS
                                                                   (\IP.READ.STRING.ADDRESS
                                                                    (CAR NET.AND.TYPE]
                                                             (NDB (SELECTQ TYPE
                                                                      (3 \3MBLOCALNDB)
                                                                      (10 \10MBLOCALNDB)
                                                                      (SHOULDNT]
                                                            (replace (NDB NDBIPNET#) of
                                                                                         NDB
                                                               with NET)
                                                            (replace (NDB NDBIPHOST#)
                                                               of NDB with ADDRESS)
                                                            (CONS NET NDB]
             ((NULL \IP.LOCAL.ADDRESSES)
              (RETURN (CL:WARN "Error in IP init file.  No local host address specified")))
             ((AND (NULL (CDR \IP.LOCAL.ADDRESSES))
                   (NULL (fetch (NDB NDBNEXT) of \LOCALNDBS)))
                                                             (* ; 
                                                    "Only one address, so it goes with our one net")
              [SETQ \IP.LOCAL.NETWORKS (LIST (CONS (\IPNETADDRESS (CAR \IP.LOCAL.ADDRESSES))
                                                   (SETQ NDB (OR \10MBLOCALNDB \3MBLOCALNDB]
              (replace (NDB NDBIPNET#) of NDB with (CAAR \IP.LOCAL.NETWORKS))
              (replace (NDB NDBIPHOST#) of NDB with (CAR \IP.LOCAL.ADDRESSES)))
             (T (RETURN (CL:WARN 
                      "Error in IP init file.  Network list and local address list do not correlate."
                               ]
          [SETQ \IP.SUBNET.MASKS (for LOCALADDR in \IP.LOCAL.ADDRESSES as MASK
                                    in (fetch (IPINIT SUBNETMASK) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                  ) as NETADDRESS in NETS
                                    collect (CONS LOCALADDR (\IP.READ.STRING.ADDRESS
                                                                 (OR MASK (CAR NETADDRESS]
          (COND
             ((BOUNDP '\DOMAIN.NAMESERVERS)
              (\DOMAIN.INIT EVENT)))
          (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.IP))
          (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.AR))
          (SETQ \IPFLG T)
          (\IP.ADD.PROTOCOL \ICMP.PROTOCOL (FUNCTION TRUE)
                 (FUNCTION NILL)
                 (FUNCTION \ICMP.INPUT))
          (COND
             ((SETQ PROC (FIND.PROCESS '\IPLISTENER))
              (RESTART.PROCESS PROC))
             (T (ADD.PROCESS '(\IPLISTENER)
                       'RESTARTABLE
                       'SYSTEM
                       'AFTEREXIT \IP.READY.EVENT)))
          (if (NOT NEW.INIT)
              then                                       (* ; "Finally, check for new hosts.txt file, but we can do this in background.  If NEW.INIT, the configuration code has already read it.")
                    (ADD.PROCESS '(\IP.MAYBE.READ.HOSTS.TXT T)
                           'AFTEREXIT
                           'DELETE))
          (SETQ \IP.READY T)
          (NOTIFY.EVENT \IP.READY.EVENT)
          (\ICMP.REQUEST.ADDRESS.MASK)
          (RETURN T])

(\IP.MAYBE.READ.HOSTS.TXT
  [LAMBDA (AFTEREXIT FILE)                               (* ; "Edited 20-Jan-89 11:56 by bvm")

    (* ;; "Read the hosts.txt file if it has changed")

    (if AFTEREXIT
        then                                             (* ; 
                                                         "Have to wait until all devices are happy")
              (until \PROC.READY do (AWAIT.EVENT \PROCESS.AFTEREXIT.EVENT 10000)))
    (LET (FULLNAME)
         (COND
            ((NULL FILE))
            (TCP.ALWAYS.READ.HOSTS.FILE                      (* ; 
                                                       "the user wants us to always read it fresh.")
                   (\HTE.READ.FILE FILE))
            ((NULL (SETQ FULLNAME (INFILEP FILE)))
             (CL:FORMAT PROMPTWINDOW "~%%Couldn't find hosts file ~A" FILE))
            ([AND \TCP.LAST.HOSTS.FILE.DATE (STRING-EQUAL FULLNAME \TCP.LAST.HOSTS.FILE.READ)
                  (EQUAL \TCP.LAST.HOSTS.FILE.DATE (GETFILEINFO FILE 'ICREATIONDATE]
                                                             (* ; 
              "the file names and the file write dates are the same, don't re-read the hosts file.")
             NIL)
            (T                                               (* ; 
                                            "Haven't read this particular file before, so snarf it")
               (\HTE.READ.FILE FILE])

(\IP.READ.INIT.FILE
  [LAMBDA (FILE)                                         (* ; "Edited 18-Mar-88 18:34 by bvm")
    (CL:MULTIPLE-VALUE-BIND (CONFIGURATION CONDITION)
           [IGNORE-ERRORS (LET ((*UPPER-CASE-FILE-NAMES* NIL)
                                (*READTABLE* (FIND-READTABLE "INTERLISP")))
                               (CL:WITH-OPEN-FILE (S FILE)
                                      (READ S]
           (if CONDITION
               then (PRINTOUT T "Failed to read init file because: " CONDITION)
                     NIL
             else (LET ((HOST (fetch (IPINIT LOCAL.NSHOSTNUMBER) of CONFIGURATION)))
                           (if (NULL HOST)
                               then                      (* ; 
                                    "Old file that doesn't have its processor identification in it")
                                     (create IPINIT using CONFIGURATION LOCAL.NSHOSTNUMBER _
                                                              \MY.NSHOSTNUMBER)
                             elseif (EQUAL HOST \MY.NSHOSTNUMBER)
                               then                      (* ; "Good, init file for same host")
                                     CONFIGURATION
                             else (PRINTOUT T FILE " gives configuration for host " (
                                                                                 \COERCE.TO.NSADDRESS
                                                                                         HOST)
                                             " but this is machine "
                                             (\COERCE.TO.NSADDRESS \MY.NSHOSTNUMBER)
                                             T)
                                   NIL])

(\IP.PROMPT.FOR.FILE.NAME
  [LAMBDA (PROMPT DEFAULT)                               (* ; "Edited 18-Mar-88 18:14 by bvm")

    (* ;; "Prompts for a file name from user and returns its full name if it is infilep")

    (bind NAME do (if [NULL (SETQ NAME (PROG1 (PROMPTFORWORD PROMPT DEFAULT NIL NIL NIL 
                                                                 NIL (CHARCODE (CR)))
                                                          (TERPRI]
                              then (RETURN NIL)
                            elseif (SETQ NAME (INFILEP NAME))
                              then (RETURN NAME)
                            else (PRINTOUT T "File not found" T])
)

(ADDTOVAR RESTARTETHERFNS \IPEVENTFN)



(* ;; "Early IP reception functions")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ IPADDRESSTYPES ((\IP.CLASS.A 0)
                           (\IP.CLASS.A.BYTESPEC (BYTE 1 31))
                           (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))
                           (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))
                           (\IP.CLASS.B 2)
                           (\IP.CLASS.B.BYTESPEC (BYTE 2 30))
                           (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))
                           (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))
                           (\IP.CLASS.C 6)
                           (\IP.CLASS.C.BYTESPEC (BYTE 3 29))
                           (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))
                           (\IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \IP.CLASS.A 0)

(RPAQ \IP.CLASS.A.BYTESPEC (BYTE 1 31))

(RPAQ \IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))

(RPAQ \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))

(RPAQQ \IP.CLASS.B 2)

(RPAQ \IP.CLASS.B.BYTESPEC (BYTE 2 30))

(RPAQ \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))

(RPAQ \IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))

(RPAQQ \IP.CLASS.C 6)

(RPAQ \IP.CLASS.C.BYTESPEC (BYTE 3 29))

(RPAQ \IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))

(RPAQ \IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))


(CONSTANTS (\IP.CLASS.A 0)
       (\IP.CLASS.A.BYTESPEC (BYTE 1 31))
       (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))
       (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))
       (\IP.CLASS.B 2)
       (\IP.CLASS.B.BYTESPEC (BYTE 2 30))
       (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))
       (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))
       (\IP.CLASS.C 6)
       (\IP.CLASS.C.BYTESPEC (BYTE 3 29))
       (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))
       (\IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0)))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \IP.LOCAL.ADDRESSES )

(RPAQ? \IP.SUBNET.MASKS )

(RPAQ? \IP.GATEWAY.FLG )

(RPAQ \IP.ADDRESS.BOX (\CREATECELL \FIXP))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.LOCAL.ADDRESSES \IP.SUBNET.MASKS \IP.GATEWAY.FLG \IP.ADDRESS.BOX)
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS \IP.FIX.DEST.HOST MACRO (LAMBDA (IP NDB)       (* ejs%: "26-Dec-84 15:07")
                                    (replace (IP IPDESTINATIONHOST) of IP
                                       with (ffetch (NDB NDBIPHOST#) of NDB]

[PUTPROPS \IP.FIX.DEST.NET MACRO (LAMBDA (IP NDB)        (* ejs%: "26-Dec-84 15:08")

         (* * Put the IP net# corresponding to the given NDB into the destination net 
       field of the dest address of the IP packet)

                                   (replace (IP IPDESTINATIONADDRESS) of IP
                                      with (LOGOR (fetch (IP IPDESTINATIONADDRESS)
                                                         of IP)
                                                      (LLSH (fetch (NDB NDBIPNET#) of NDB)
                                                            (SELECTQ (\IPADDRESSCLASS
                                                                      (fetch (NDB NDBIPHOST#)
                                                                         of NDB))
                                                                (\IP.CLASS.A 24)
                                                                (\IP.CLASS.B 16)
                                                                (\IP.CLASS.C 8)
                                                                (SHOULDNT]

[PUTPROPS \IP.FIX.SOURCE.HOST MACRO (LAMBDA (IP NDB)     (* ejs%: "26-Dec-84 15:07")
                                      (replace (IP IPSOURCEHOST) of IP
                                         with (ffetch (NDB NDBIPHOST#) of NDB]

[PUTPROPS \IP.FIX.SOURCE.NET MACRO (LAMBDA (IP NDB)      (* ejs%: "26-Dec-84 15:08")

         (* * Put the IP net# corresponding to the given NDB into the destination net 
       field of the dest address of the IP packet)

                                     (replace (IP IPSOURCENET) of IP
                                        with (ffetch (NDB NDBIPNET#) of NDB]
)
(DEFINEQ

(\HANDLE.RAW.IP
  [LAMBDA (IP TYPE)                                      (* ejs%: " 3-Feb-86 11:01")
    (PROG ((NDB (ffetch (ETHERPACKET EPNETWORK) of IP)))
          (COND
             ((NOT (type? NDB NDB))
              (ERROR "No NDB in ETHERPACKET!" IP)))
          (SELECTQ (ffetch (NDB NETTYPE) of NDB)
              (10 (COND
                     ((NEQ TYPE \EPT.IP)
                      (RETURN))))
              (3 (COND
                    ((NEQ TYPE \EET.IP)
                     (RETURN))))
              (ERROR "Unknown net type" (ffetch (NDB NETTYPE) of NDB)))
          [COND
             ((NOT \IP.READY)
              (\RELEASE.ETHERPACKET IP))
             ([NOT (\IP.CHECKSUM.OK (\IPCHECKSUM IP (ffetch (IP IPBASE) of IP)
                                               (TIMES (ffetch (IP IPHEADERLENGTH) of IP)
                                                      BYTESPERCELL]
              (AND IPTRACEFLG (PRINTPACKET IP 'GET IPTRACEFILE 
                                     "[Packet dropped--bad IP header checksum]"))
              (\RELEASE.ETHERPACKET IP))
             ((ZEROP (ffetch (IP IPTIMETOLIVE) of IP))
              (\ICMP.TIME.EXCEEDED IP \ICMP.TRANSIT.TIME.EXCEEDED)
              (\RELEASE.ETHERPACKET IP))
             ((\IP.PROCESS.OPTIONS IP)
              (COND
                 ((NOT (\IP.LOCAL.DESTINATION IP))
                  (\FORWARD.IP IP))
                 [(\IP.FRAGMENTED.PACKET IP)
                  (COND
                     ((SETQ IP (\HANDLE.RAW.IP.FRAGMENT IP))
                      [COND
                         (IPTRACEFLG (COND
                                        ((EQ IPTRACEFLG T)
                                         (PRINTIP IP 'GETFRAGMENT IPTRACEFILE NIL T))
                                        (T (PRIN1 "+" IPTRACEFILE]
                      (\IP.HAND.TO.PROTOCOL IP]
                 (T [COND
                       (IPTRACEFLG (COND
                                      ((EQ IPTRACEFLG T)
                                       (PRINTIP IP 'GET IPTRACEFILE NIL T))
                                      (T (PRIN1 "+" IPTRACEFILE]
                    (\IP.HAND.TO.PROTOCOL IP]
          (RETURN T])

(\FORWARD.IP
  [LAMBDA (IP)                                           (* ejs%: "10-Feb-86 11:32")
    (DECLARE (GLOBALVARS \IP.GATEWAY.FLG \IP.GATEWAY.FORWARDING.FUNCTIONS))
    (COND
       [\IP.GATEWAY.FLG (LET* ((DESTADDRESS (ffetch (IP IPDESTINATIONADDRESS) of IP))
                               (NETADDRESS (\IPNETADDRESS DESTADDRESS))
                               (NDB (fetch (ETHERPACKET EPNETWORK) of IP))
                               (SOURCEADDRESS (fetch NDBIPHOST# of NDB))
                               (SUBNETMASK (CDR (SASSOC SOURCEADDRESS \IP.SUBNET.MASKS)))
                               SUBNETINUSE ROUTE FORWARDING.FUNCTION)
                              [COND
                                 [(AND NDB SUBNETMASK (OR (EQP (LOGAND SOURCEADDRESS SUBNETMASK)
                                                               (LOGAND DESTADDRESS SUBNETMASK))
                                                          (PROGN (SETQ SUBNETINUSE T)
                                                                 NIL]
                                 ((NULL NDB)
                                  (COND
                                     ((SETQ ROUTE (CDR (SASSOC NETADDRESS \IP.ROUTING.TABLE)))
                                      (SETQ NDB (CDR (SASSOC (\IPNETADDRESS ROUTE)
                                                            \IP.LOCAL.NETWORKS]
                              (COND
                                 [NDB (replace EPREQUEUE of IP with 'FREE)
                                      (add (ffetch (IP IPTIMETOLIVE) of IP)
                                             -1)
                                      [SETQ NETADDRESS (COND
                                                          (SUBNETINUSE (LOGAND DESTADDRESS SUBNETMASK
                                                                              ))
                                                          (T (BITCLEAR DESTADDRESS (\IPHOSTADDRESS
                                                                                    DESTADDRESS]
                                      (COND
                                         ((SETQ FORWARDING.FUNCTION (CDR (SASSOC NETADDRESS 
                                                                     \IP.GATEWAY.FORWARDING.FUNCTIONS
                                                                                )))
                                          (APPLY* FORWARDING.FUNCTION IP NDB NETADDRESS ROUTE))
                                         (T (\RELEASE.ETHERPACKET IP]
                                 (T (\ICMP.REDIRECT IP \ICMP.REDIRECT.NET]
       (T (\RELEASE.ETHERPACKET IP])

(\IP.LOCAL.DESTINATION
  [LAMBDA (IP)                                           (* ejs%: "25-Mar-86 16:03")

         (* * Return T if IP packet is destined for us)

    (UNINTERRUPTABLY
        (\BLT \IP.ADDRESS.BOX (LOCF (fetch (IP IPDESTINATIONADDRESS) of IP))
              WORDSPERCELL)
        [LET [(LOCALNETADDRESS (fetch NDBIPNET# of (fetch EPNETWORK of IP]
             (COND
                ((MEMBER \IP.ADDRESS.BOX \IP.LOCAL.ADDRESSES)
                 T)
                ((AND (\IP.BROADCAST.ADDRESS \IP.ADDRESS.BOX)
                      (EQP LOCALNETADDRESS (\IPNETADDRESS \IP.ADDRESS.BOX)))
                 T)
                ((NOT (\IP.LEGAL.ADDRESS \IP.ADDRESS.BOX))
                                                             (* Bogus destination address)
                 NIL)
                ((EQP 0 (\IPNETADDRESS \IP.ADDRESS.BOX)) (* Source doesn't know its network?)
                 (SELECTQ (INTEGERLENGTH LOCALNETADDRESS)
                     (8 (\PUTBASEBYTE \IP.ADDRESS.BOX 0 LOCALNETADDRESS))
                     (16 (\PUTBASE \IP.ADDRESS.BOX 0 LOCALNETADDRESS))
                     (24 [for I from 0 to 2
                            do (\PUTBASEBYTE \IP.ADDRESS.BOX I
                                          (LOGAND 255 (LRSH LOCALNETADDRESS (ITIMES 8
                                                                                   (IDIFFERENCE
                                                                                    2 I])
                     NIL)
                 (COND
                    ((\IP.BROADCAST.ADDRESS \IP.ADDRESS.BOX)
                     T)
                    ((MEMBER \IP.ADDRESS.BOX \IP.LOCAL.ADDRESSES)
                     T])])

(\IPCHECKSUM
  [LAMBDA (ETHERPACKET CHECKSUMBASE NBYTES IGNOREDWORD)  (* ejs%: "31-Dec-84 13:53")

         (* * Compute a general checksum for a packet starting at CHECKSUMBASE and 
       extending NBYTES. If NBYTES is odd, a 0 byte is padded on the end.
       The IGNOREDWORD field is the LOCF of the field which will contain the checksum, 
       and is to be considered 0 for the calculation.)

    (PROG ((MAXINDEX (SUB1 (FOLDHI NBYTES BYTESPERWORD)))
           (CHECKSUM 0)
           (ODDFLG (ODDP NBYTES))
           DIFF WORDCONTENTS)
          (AND IGNOREDWORD (\PUTBASE IGNOREDWORD 0 0))
          [for WORD from 0 to MAXINDEX
             do (SETQ CHECKSUM (COND
                                      [(AND ODDFLG (EQ WORD MAXINDEX))
                                       (COND
                                          ([ILEQ CHECKSUM (SETQ DIFF (IDIFFERENCE
                                                                      MAX.SMALL.INTEGER
                                                                      (SETQ WORDCONTENTS
                                                                       (LOGAND (\GETBASE CHECKSUMBASE
                                                                                      WORD)
                                                                              (MASK.1'S 8 8]
                                           (IPLUS CHECKSUM WORDCONTENTS))
                                          (T (IDIFFERENCE CHECKSUM DIFF]
                                      (T (COND
                                            ([ILEQ CHECKSUM (SETQ DIFF (IDIFFERENCE MAX.SMALL.INTEGER
                                                                              (SETQ WORDCONTENTS
                                                                               (\GETBASE CHECKSUMBASE
                                                                                      WORD]
                                             (IPLUS CHECKSUM WORDCONTENTS))
                                            (T (IDIFFERENCE CHECKSUM DIFF]
          (RETURN CHECKSUM])

(\IP.CHECKSUM.OK
  [LAMBDA (CHECKSUM)                                     (* ejs%: "28-Dec-84 19:40")
    (OR (EQ CHECKSUM (MASK.1'S 0 16))
        (EQ CHECKSUM 0])

(\IP.SET.CHECKSUM
  [LAMBDA (PACKET CHECKSUMBASE NBYTES CHECKSUMWORD)      (* ejs%: " 4-Jun-85 22:47")
    (PROG ((CHECKSUM (\IPCHECKSUM PACKET CHECKSUMBASE NBYTES CHECKSUMWORD)))
          (\PUTBASE CHECKSUMWORD 0 (COND
                                      ((EQ CHECKSUM (MASK.1'S 0 16))
                                       CHECKSUM)
                                      (T (LOGAND (LOGNOT CHECKSUM)
                                                (MASK.1'S 0 16])
)



(* ;; "Protocol Distribution")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ IPPROTOCOLTYPES ((\ICMP.PROTOCOL 1)
                            (\TCP.PROTOCOL 6)
                            (\UDP.PROTOCOL 17)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.PROTOCOL 1)

(RPAQQ \TCP.PROTOCOL 6)

(RPAQQ \UDP.PROTOCOL 17)


(CONSTANTS (\ICMP.PROTOCOL 1)
       (\TCP.PROTOCOL 6)
       (\UDP.PROTOCOL 17))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \IP.PROTOCOLS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.PROTOCOLS)
)
(DEFINEQ

(\IP.HAND.TO.PROTOCOL
  [LAMBDA (IP)                                           (* ejs%: "31-Mar-86 15:39")
    (PROG ((PROTOCOL (ffetch (IP IPPROTOCOL) of IP))
           PROTOCOLCHAIN IPSOCKET)
          (COND
             ((NOT (SETQ PROTOCOLCHAIN (\IP.FIND.PROTOCOL PROTOCOL \IP.PROTOCOLS)))
              (OR (\IP.BROADCAST.ADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP))
                  (\ICMP.DEST.UNREACHABLE IP \ICMP.PROTOCOL.UNREACHABLE)))
             ((NOT (SETQ IPSOCKET (\IP.FIND.PROTOCOL.SOCKET IP PROTOCOLCHAIN)))
              (APPLY* (ffetch (IPSOCKET IPSNOSOCKETFN) of PROTOCOLCHAIN)
                     IP))
             (T (APPLY* (ffetch (IPSOCKET IPSINPUTFN) of (COND
                                                                    ((type? IPSOCKET IPSOCKET)
                                                                     IPSOCKET)
                                                                    (T PROTOCOLCHAIN)))
                       IP IPSOCKET])

(\IP.DEFAULT.INPUTFN
  [LAMBDA (IP IPSOCKET)                                  (* ejs%: " 3-Feb-85 19:19")
    (COND
       ((EQ (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET)
            (fetch (IPSOCKET IPSQUEUEALLOC) of IPSOCKET))
        (\RELEASE.ETHERPACKET IP))
       (T (UNINTERRUPTABLY
              (\ENQUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)
                     IP)
              (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET)
                     1)
              (NOTIFY.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)))])

(\IP.DEFAULT.NOSOCKETFN
  [LAMBDA (IP)                                           (* ejs%: " 2-Feb-86 11:38")
    (COND
       ([OR (NEQ 0 (fetch (IP IPDESTINATIONHOST) of IP))
            (NOT (\IP.BROADCAST.ADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP]
        (\ICMP.DEST.UNREACHABLE IP \ICMP.PORT.UNREACHABLE))
       (T (\RELEASE.ETHERPACKET IP])

(\IP.ADD.PROTOCOL
  [LAMBDA (PROTOCOL SOCKETCOMPAREFN NOSOCKETFN INPUTFN ICMPFN)
                                                             (* ; "Edited 25-Aug-88 12:10 by bvm")

(* ;;; "Find an existing protocol, or create a new one, and return the socket chain head.  If the protocol already exists, the remaining arguments redefine the current slots.")

    (LET* [(FOUND (find SOCKET in \IP.PROTOCOLS suchthat (EQ (fetch (IPSOCKET 
                                                                                           PROTOCOL)
                                                                            of SOCKET)
                                                                         PROTOCOL)))
           (SOCKET (OR FOUND (create IPSOCKET
                                    PROTOCOL _ PROTOCOL
                                    IPSQUEUE _ NIL
                                    IPSQUEUEALLOC _ 0
                                    IPSEVENT _ NIL]
          (replace (IPSOCKET IPSDESTSOCKETCOMPAREFN) of SOCKET with SOCKETCOMPAREFN)
          (replace (IPSOCKET IPSINPUTFN) of SOCKET with (OR INPUTFN
                                                                        (FUNCTION \IP.DEFAULT.INPUTFN
                                                                         )))
          (replace (IPSOCKET IPSNOSOCKETFN) of SOCKET with (OR NOSOCKETFN
                                                                           (FUNCTION 
                                                                            \IP.DEFAULT.NOSOCKETFN)))
          (replace (IPSOCKET IPSICMPFN) of SOCKET with (OR ICMPFN (FUNCTION 
                                                                               \RELEASE.ETHERPACKET))
                 )
          (if (NOT FOUND)
              then                                       (* ; 
                                          "Now that it's all filled in, add it to the protocol set")
                    (push \IP.PROTOCOLS SOCKET))
          SOCKET])

(\IP.DELETE.PROTOCOL
  [LAMBDA (PROTOCOL)                                     (* ejs%: "10-Apr-85 16:24")
    (LET ((PROTOCOLCHAIN (\IP.FIND.PROTOCOL PROTOCOL)))
         (COND
            (PROTOCOLCHAIN (until (NULL (fetch (IPSOCKET IPSLINK) of PROTOCOLCHAIN))
                              do (\IP.CLOSE.SOCKET (fetch (IPSOCKET IPSOCKET)
                                                              of (fetch (IPSOCKET IPSLINK)
                                                                        of PROTOCOLCHAIN))
                                            PROTOCOL))
                   (SETQ \IP.PROTOCOLS (DREMOVE PROTOCOLCHAIN \IP.PROTOCOLS))
                   T])

(\IP.FIND.PROTOCOL
  [LAMBDA (PROTOCOL)                                     (* ejs%: "27-Dec-84 11:18")

         (* * Find the protocol chain for this protocol#)

    (CAR (SOME \IP.PROTOCOLS (FUNCTION (LAMBDA (IPSOCKET)
                                         (EQ (ffetch (IPSOCKET PROTOCOL) of IPSOCKET)
                                             PROTOCOL])

(\IP.FIND.PROTOCOL.SOCKET
  [LAMBDA (IP PROTOCOLCHAIN)                             (* ; "Edited 26-Aug-88 12:44 by bvm")

    (* ;; "Find the socket specified by IP packet.  PROTOCOLCHAIN is the head of the socket chain for this protocol; if NIL we look it up.")

    (LET ([SOCKET (OR PROTOCOLCHAIN (\IP.FIND.PROTOCOL (ffetch (IP IPPROTOCOL) of IP]
          RESULT)

         (* ;; "Note that we start the comparisons with the dummy head, even though we expect that to fail.  This is so that a socketless protocol, such as ICMP can use this dummy head as the sole handler of the protocol.")

         (AND SOCKET (when (SETQ RESULT (CL:FUNCALL (ffetch (IPSOCKET IPSDESTSOCKETCOMPAREFN)
                                                           of SOCKET)
                                                   IP SOCKET))
                        do (RETURN (COND
                                          ((EQ RESULT T)
                                           SOCKET)
                                          (T                 (* ; "This is a little strange.  Non-T comparison result will be passed as the second arg to the chain head's inputfn when a packet arrives here.")
                                             RESULT))) repeatwhile (SETQ SOCKET
                                                                        (ffetch (IPSOCKET IPSLINK
                                                                                           )
                                                                           of SOCKET])

(\IP.FIND.SOCKET
  [LAMBDA (SOCKET# SOCKETCHAIN)                          (* ejs%: "27-Dec-84 11:39")

         (* * Called to find the socket open on the socketchain, or NIL if no such open 
       socket. Socketchain comes from \IP.FIND.PROTOCOL)

    (while SOCKETCHAIN until (COND
                                        ((EQUAL SOCKET# (ffetch (IPSOCKET IPSOCKET) of 
                                                                                          SOCKETCHAIN
                                                               ))
                                         SOCKETCHAIN)
                                        (T (SETQ SOCKETCHAIN (ffetch (IPSOCKET IPSLINK)
                                                                of SOCKETCHAIN))
                                           NIL)) finally (RETURN SOCKETCHAIN])

(\IP.OPEN.SOCKET
  [LAMBDA (PROTOCOL SOCKET NOERRORFLG DESTSOCKETCOMPAREFN NOSOCKETFN INPUTFN ICMPFN)
                                                             (* ; "Edited 25-Aug-88 12:43 by bvm")

(* ;;; "Open a new socket for a protocol.  The last 4 fns default to those specified when the protocol was enabled.")

    (* ;; "Keeping NOSOCKETFN for back compatibility, but it doesn't really make any sense --bvm.")

    (LET ((MASTERSOC (\IP.FIND.PROTOCOL PROTOCOL))
          OLDSOC NEWSOC)
         (COND
            [(NOT (type? IPSOCKET MASTERSOC))
             (COND
                ((NOT NOERRORFLG)
                 (ERROR "Attempt to open socket in unknown protocol" PROTOCOL SOCKET]
            [(if SOCKET
                 then (SETQ OLDSOC (\IP.FIND.SOCKET SOCKET MASTERSOC))
               else                                      (* ; 
        "Pick a random socket that is smallp but not very small, so as to avoid well-known sockets")
                     (SETQ SOCKET (LOGOR (LOGAND (DAYTIME)
                                                65535)
                                         32768))
                     (while (\IP.FIND.SOCKET SOCKET MASTERSOC)
                        do (SETQ SOCKET (- SOCKET 1)))
                     NIL)
             (COND
                (NOERRORFLG OLDSOC)
                (T (ERROR "Attempt to open an existing socket" OLDSOC]
            (T [SETQ NEWSOC (create IPSOCKET
                                   IPSLINK _ (ffetch (IPSOCKET IPSLINK) of MASTERSOC)
                                   IPSOCKET _ SOCKET
                                   PROTOCOL _ PROTOCOL
                                   IPSDESTSOCKETCOMPAREFN _ (OR DESTSOCKETCOMPAREFN
                                                                (ffetch (IPSOCKET 
                                                                               IPSDESTSOCKETCOMPAREFN
                                                                                   ) of MASTERSOC
                                                                       ))
                                   IPSNOSOCKETFN _ (OR NOSOCKETFN (ffetch (IPSOCKET IPSNOSOCKETFN
                                                                                     ) of 
                                                                                            MASTERSOC
                                                                         ))
                                   IPSINPUTFN _ (OR INPUTFN (ffetch (IPSOCKET IPSINPUTFN)
                                                               of MASTERSOC))
                                   IPSICMPFN _ (OR ICMPFN (ffetch (IPSOCKET IPSICMPFN)
                                                             of MASTERSOC]
               (freplace (IPSOCKET IPSLINK) of MASTERSOC with NEWSOC)
               NEWSOC])

(\IP.CLOSE.SOCKET
  [LAMBDA (SOCKET PROTOCOL NOERRORFLG)                   (* ; "Edited 26-Aug-88 12:33 by bvm")

(* ;;; "Close the given socket.  Call this only after the higher level protocol has finished doing its closing operations.")

    (* ;; "For some silly reason, this fn was defined to take not an IPSOCKET object but rather the socket number, or whatever was in the socket slot.  For backward compatibility, let's do both (sigh).")

    (LET ((PREV (\IP.FIND.PROTOCOL PROTOCOL))
          NEXT)
         (COND
            [(AND PREV (while (SETQ NEXT (ffetch (IPSOCKET IPSLINK) of PREV))
                          do (if (OR (EQ SOCKET NEXT)
                                             (EQ SOCKET (ffetch (IPSOCKET IPSOCKET) of NEXT))
                                             )
                                     then                (* ; "Found it, so splice it out")
                                           (freplace (IPSOCKET IPSLINK) of PREV
                                              with (ffetch (IPSOCKET IPSLINK) of NEXT))
                                           (freplace (IPSOCKET IPSLINK) of NEXT with
                                                                                        NIL)
                                           (RETURN T))
                                (SETQ PREV NEXT]
            ((NOT NOERRORFLG)
             (ERROR "Socket not found" SOCKET])
)



(* ;; "Fragmentation Handling")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(RECORD AssemblyRecord (Packet FirstHole Fragments Timeout)
                           Packet _ (\ALLOCATE.ETHERPACKET)
                           FirstHole _ 0)

(RECORD FragmentRecord (Start Length LastFragment))

(RECORD FragmentID (AssemblyRecord SourceAddress ID Protocol . DestinationAddress))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \IP.FRAGMENT.LIST )

(RPAQ? \IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.FRAGMENT.LIST \IP.FRAGMENT.LOCK)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \IP.FRAGMENTATION.UNIT 8)


(CONSTANTS (\IP.FRAGMENTATION.UNIT 8))
)
(DEFINEQ

(\HANDLE.RAW.IP.FRAGMENT
  [LAMBDA (IP)                                           (* ejs%: " 1-Feb-86 14:24")

         (* * Add the next fragment to a packet under assembly.
       If this fragment completes a packet, return the completed packet to be 
       processed by higher-level protocol routines.)

    (WITH.MONITOR \IP.FRAGMENT.LOCK
        (LET ((AssemblyRecord (\IP.FIND.MATCHING.FRAGMENTS IP)))
             (COND
                (AssemblyRecord (\IP.ADD.FRAGMENT AssemblyRecord IP))
                (T (\IP.NEW.FRAGMENT.LST IP)
                   NIL))))])

(\IP.NEW.FRAGMENT.LST
  [LAMBDA (IP)                                           (* ejs%: " 3-Feb-86 10:57")

         (* * Add a new fragment to the fragment list)

    (PROG ((Source (ffetch (IP IPSOURCEADDRESS) of IP))
           (Dest (ffetch (IP IPDESTINATIONADDRESS) of IP))
           (Protocol (ffetch (IP IPPROTOCOL) of IP))
           (ID (ffetch (IP IPID) of IP))
           NewFragmentID FragmentRecord AssemblyPacket AssemblyRecord)
          [SETQ NewFragmentID
           (create FragmentID
                  SourceAddress _ Source
                  ID _ ID
                  Protocol _ Protocol
                  DestinationAddress _ Dest
                  AssemblyRecord _ (SETQ AssemblyRecord
                                    (create AssemblyRecord
                                           Timeout _ (SETUPTIMER (ITIMES 1000 (ffetch
                                                                               (IP IPTIMETOLIVE)
                                                                                 of IP)))
                                           Fragments _
                                           (LIST (SETQ FragmentRecord
                                                  (create FragmentRecord
                                                         Start _ (UNFOLD (ffetch (IP 
                                                                                     IPFRAGMENTOFFSET
                                                                                         )
                                                                            of IP)
                                                                        \IP.FRAGMENTATION.UNIT)
                                                         Length _ (IDIFFERENCE
                                                                   (ffetch (IP IPTOTALLENGTH)
                                                                      of IP)
                                                                   (UNFOLD (ffetch (IP 
                                                                                       IPHEADERLENGTH
                                                                                           )
                                                                              of IP)
                                                                          BYTESPERCELL]
          (COND
             ((EQ IPTRACEFLG T)
              (\IP.PRINT.FRAGMENT NewFragmentID IP IPTRACEFILE)))
          (SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord))
          (\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER AssemblyPacket IP)

         (* * Copy the packet data to the packet)

          (\BLT (\ADDBASE (\IPDATABASE AssemblyPacket)
                       (FOLDLO (fetch (FragmentRecord Start) of FragmentRecord)
                              BYTESPERWORD))
                (\IPDATABASE IP)
                (FOLDLO (fetch (FragmentRecord Length) of FragmentRecord)
                       BYTESPERWORD))
          (\RELEASE.ETHERPACKET IP)
          (push \IP.FRAGMENT.LIST NewFragmentID])

(\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER
  [LAMBDA (Packet Fragment)                              (* ejs%: " 1-Feb-86 14:14")

         (* * Copy information from the header of the fragment packet into the header of 
       the reassembled packet)

    (\MOVEBYTES (fetch (IP IPBASE) of Fragment)
           0
           (fetch (IP IPBASE) of Packet)
           0
           (UNFOLD (fetch (IP IPHEADERLENGTH) of Fragment)
                  BYTESPERCELL])

(\IP.ADD.FRAGMENT
  [LAMBDA (FragmentID NewIP)                             (* ejs%: " 1-Feb-86 18:41")

         (* * Called to add a fragment to a fragment list.
       The fragment is added in order. If the fragment completes a fragmented IP 
       packet, a new packet is assembled and returned, else NIL is returned)

    (LET*
     ((AssemblyRecord (fetch (FragmentID AssemblyRecord) of FragmentID))
      [NewFrag (create FragmentRecord
                      Start _ (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of NewIP)
                                     \IP.FRAGMENTATION.UNIT)
                      Length _ (IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of NewIP)
                                      (UNFOLD (ffetch (IP IPHEADERLENGTH) of NewIP)
                                             BYTESPERCELL))
                      LastFragment _ (NOT (fetch (IP IPMOREFRAGMENTS) of NewIP]
      (Fragments (fetch (AssemblyRecord Fragments) of AssemblyRecord))
      Status NextHole AssemblyPacket)
     (COND
        ((EQ IPTRACEFLG T)
         (\IP.PRINT.FRAGMENT FragmentID NewIP IPTRACEFILE)))
     (SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord))
     (replace (AssemblyRecord Timeout) of AssemblyRecord
        with (SETUPTIMER (ITIMES 1000 (ffetch (IP IPTIMETOLIVE) of NewIP))
                        (fetch (AssemblyRecord Timeout) of AssemblyRecord)))
     [SETQ Status (COND
                     ((ILESSP (fetch (FragmentRecord Start) of NewFrag)
                             (fetch (FragmentRecord Start) of (CAR Fragments)))
                                                             (* Earlier than the earliest 
                                                           existing fragment)
                      (SETQ Fragments (push (fetch (AssemblyRecord Fragments) of 
                                                                                       AssemblyRecord
                                                       )
                                             NewFrag))
                      'INSERTED.FRAGMENT)
                     ((EQ (fetch (FragmentRecord Start) of NewFrag)
                          (fetch (FragmentRecord Start) of (CAR Fragments)))
                                                             (* Duplicate of earliest fragment)
                      'DUPLICATE)
                     (T                                      (* Have to search)
                        (for OldFragTail on Fragments while (CDR OldFragTail)
                           thereis (COND
                                          ((EQ (fetch (FragmentRecord Start) of NewFrag)
                                               (fetch (FragmentRecord Start) of (CADR 
                                                                                          OldFragTail
                                                                                              )))
                                                             (* Duplicate)
                                           (SETQ Status 'DUPLICATE)
                                           T)
                                          ((ILESSP (fetch (FragmentRecord Start) of NewFrag)
                                                  (fetch (FragmentRecord Start)
                                                     of (CADR OldFragTail)))
                                                             (* Found the hole to insert)
                                           T)) finally (COND
                                                              (Status 
                                                             (* Duplicate)
                                                                     (RETURN Status))
                                                              ((CDR OldFragTail)
                                                             (* Inserted in middle of list)
                                                               (RPLACD OldFragTail
                                                                      (CONS NewFrag (CDR OldFragTail)
                                                                            ))
                                                               (RETURN 'INSERTED.FRAGMENT))
                                                              (T 
                                                             (* Inserted at end of list)
                                                                 (NCONC1 OldFragTail NewFrag)
                                                                 (RETURN 'INSERTED.FRAGMENT]
     (PROG1 (SELECTQ Status
                (DUPLICATE NIL)
                (INSERTED.FRAGMENT                           (* Copy bytes into assembly)
                     (\MOVEBYTES (\IPDATABASE NewIP)
                            0
                            (\IPDATABASE AssemblyPacket)
                            (fetch (FragmentRecord Start) of NewFrag)
                            (fetch (FragmentRecord Length) of NewFrag))
                     (add (ffetch (IP IPTOTALLENGTH) of AssemblyPacket)
                            (fetch (FragmentRecord Length) of NewFrag))
                                                             (* Update Assembly record)
                     [COND
                        ((ILESSP (fetch (FragmentRecord Start) of NewFrag)
                                (fetch (AssemblyRecord FirstHole) of AssemblyRecord))
                         (ERROR "Error in IP fragment reassembly!" NewFrag))
                        (T (COND
                              ((EQ [bind End Status for FragTail on Fragments
                                      while (CDR FragTail)
                                      thereis [COND
                                                     ((NEQ [SETQ End (IPLUS (fetch (
                                                                                       FragmentRecord
                                                                                        Start)
                                                                               of (CAR FragTail))
                                                                            (fetch (
                                                                                       FragmentRecord
                                                                                        Length)
                                                                               of (CAR FragTail]
                                                           (fetch (FragmentRecord Start)
                                                              of (CADR FragTail)))
                                                      (replace (AssemblyRecord FirstHole)
                                                         of AssemblyRecord with End)
                                                      (SETQ Status 'FOUND.HOLE]
                                      finally (RETURN (COND
                                                             [(NULL Status)
                                                              (COND
                                                                 ((fetch (FragmentRecord 
                                                                                    LastFragment)
                                                                     of (CAR FragTail))
                                                                  (COND
                                                                     ((EQ IPTRACEFLG T)
                                                                      (printout IPTRACEFILE T 
                                                                      "Complete IP Fragment received"
                                                                             T)))
                                                                  'COMPLETE.PACKET)
                                                                 (T (replace (AssemblyRecord
                                                                                  FirstHole)
                                                                       of AssemblyRecord
                                                                       with End)
                                                                    'INCOMPLETE.BUT.NO.HOLES]
                                                             (T Status]
                                   'COMPLETE.PACKET)
                               (\IP.DELETE.FRAGMENT FragmentID)
                               AssemblyPacket])
                NIL)
            (\RELEASE.ETHERPACKET NewIP])

(\IP.FIND.MATCHING.FRAGMENTS
  [LAMBDA (IP)                                           (* ejs%: " 1-Feb-86 14:41")

         (* * Find the list of fragments matching this IP packet, or NIL if none exists)

    (DECLARE (GLOBALVARS \IP.FRAGMENT.LIST))
    (LET* ((Source (ffetch (IP IPSOURCEADDRESS) of IP))
           (Dest (ffetch (IP IPDESTINATIONADDRESS) of IP))
           (Protocol (ffetch (IP IPPROTOCOL) of IP))
           (ID (ffetch (IP IPID) of IP))
           (FragmentEntry))
          (for FragmentID in \IP.FRAGMENT.LIST thereis (AND (EQP (fetch (FragmentID
                                                                                         
                                                                                        SourceAddress
                                                                                         )
                                                                                of FragmentID)
                                                                             Source)
                                                                        (EQ (fetch (FragmentID
                                                                                        ID)
                                                                               of FragmentID)
                                                                            ID)
                                                                        (EQ (fetch (FragmentID
                                                                                        Protocol)
                                                                               of FragmentID)
                                                                            Protocol)
                                                                        (EQP (fetch (FragmentID
                                                                                         
                                                                                   DestinationAddress
                                                                                         )
                                                                                of FragmentID)
                                                                             Dest])

(\IP.FRAGMENTED.PACKET
  [LAMBDA (IP)                                           (* ejs%: " 1-Feb-86 16:50")

         (* * Return T if IP packet is a fragment)

    (OR (ffetch (IP IPMOREFRAGMENTS) of IP)
        (NEQ 0 (ffetch (IP IPFRAGMENTOFFSET) of IP])

(\IP.CHECK.REASSEMBLY.TIMEOUTS
  [LAMBDA NIL                                            (* ejs%: " 3-Feb-86 11:00")

         (* * Kill any fragments in the process of reassembly if their timeout has 
       expired. Report timeout via ICMP)

    (WITH.MONITOR \IP.FRAGMENT.LOCK
        (bind AssemblyRecord for Fragment in \IP.FRAGMENT.LIST
           when [TIMEREXPIRED? (fetch (AssemblyRecord Timeout) of (SETQ AssemblyRecord
                                                                               (fetch
                                                                                (FragmentID 
                                                                                       AssemblyRecord
                                                                                       ) of
                                                                                         Fragment]
           do (COND
                     ((EQ IPTRACEFLG T)
                      (printout IPTRACEFILE T "IP Fragment timeout expired" T)))
                 (\ICMP.TIME.EXCEEDED (fetch (AssemblyRecord Packet) of AssemblyRecord)
                        \ICMP.FRAGMENT.TIME.EXCEEDED)
                 (\IP.DELETE.FRAGMENT Fragment T)))])

(\IP.DELETE.FRAGMENT
  [LAMBDA (FragmentID FreePacketToo)                     (* ejs%: " 3-Feb-86 10:59")

         (* * Delete FragmentID from the list of Fragment ID's)

    (PROG [(IP (fetch (AssemblyRecord Packet) of (fetch (FragmentID AssemblyRecord)
                                                            of FragmentID]
          (SETQ \IP.FRAGMENT.LIST (DREMOVE FragmentID \IP.FRAGMENT.LIST))
          (AND FreePacketToo (\RELEASE.ETHERPACKET IP])

(\IP.PRINT.FRAGMENT
  [LAMBDA (FragmentID IPFragment File)                   (* ejs%: " 2-Feb-86 10:39")

         (* * Print information about this fragement to File)

    (printout File T "Received IP Fragment:" T "Source " (\IP.ADDRESS.TO.STRING
                                                          (fetch (FragmentID SourceAddress)
                                                             of FragmentID))
           " Dest "
           (\IP.ADDRESS.TO.STRING (fetch (FragmentID DestinationAddress) of FragmentID))
           T "Protocol ")
    (PRINTCONSTANT (fetch (FragmentID Protocol) of FragmentID)
           IPPROTOCOLTYPES File)
    (printout File " ID " (fetch (FragmentID ID) of FragmentID)
           T "Covering [" (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of IPFragment)
                                 \IP.FRAGMENTATION.UNIT)
           ".."
           (IPLUS (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of IPFragment)
                         \IP.FRAGMENTATION.UNIT)
                  (IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of IPFragment)
                         (UNFOLD (ffetch (IP IPHEADERLENGTH) of IPFragment)
                                BYTESPERCELL)))
           "]" T)
    (bind C for I from 0 to [SUB1 (IMIN 40 (IDIFFERENCE (ffetch (IP IPTOTALLENGTH
                                                                                        )
                                                                           of IPFragment)
                                                                  (UNFOLD (ffetch (IP 
                                                                                       IPHEADERLENGTH
                                                                                          )
                                                                             of IPFragment)
                                                                         BYTESPERCELL]
       do (SETQ C (\GETBASEBYTE (\IPDATABASE IPFragment)
                             I))
             (COND
                ((AND (IGEQ C (CHARCODE SPACE))
                      (ILEQ C 126))
                 (BOUT File C))
                (T (printout File "[" C "]"])
)



(* ;; "Option Processing")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ IPOPTIONTYPES ((IPOPT.END 0)
                          (IPOPT.NOP 1)
                          (IPOPT.SECURITY 2)
                          (IPOPT.LSRR 3)
                          (IPOPT.TIMESTAMP 4)
                          (IPOPT.RECRT 7)
                          (IPOPT.STREAMID 8)
                          (IPOPT.SSSR 9)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ IPOPT.END 0)

(RPAQQ IPOPT.NOP 1)

(RPAQQ IPOPT.SECURITY 2)

(RPAQQ IPOPT.LSRR 3)

(RPAQQ IPOPT.TIMESTAMP 4)

(RPAQQ IPOPT.RECRT 7)

(RPAQQ IPOPT.STREAMID 8)

(RPAQQ IPOPT.SSSR 9)


(CONSTANTS (IPOPT.END 0)
       (IPOPT.NOP 1)
       (IPOPT.SECURITY 2)
       (IPOPT.LSRR 3)
       (IPOPT.TIMESTAMP 4)
       (IPOPT.RECRT 7)
       (IPOPT.STREAMID 8)
       (IPOPT.SSSR 9))
)
(DECLARE%: EVAL@COMPILE 

(RPAQ IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0))


(CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)))
)

(* "END EXPORTED DEFINITIONS")

)
(DEFINEQ

(\IP.PROCESS.OPTIONS
  [LAMBDA (IP)                                           (* ; "Edited 20-Jan-89 12:24 by bvm")

(* ;;; "Process option fields in IP header.  Return T if OK, else handle internally needed actions like redirection or reporting of parameter problems")

    (bind (OPTIONSSTART _ (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (INDEX _ 0)
           (RESULT _ T)
           REROUTING OPTION until (OR (>= INDEX (- (UNFOLD (fetch (IP IPHEADERLENGTH)
                                                                  of IP)
                                                              BYTESPERCELL)
                                                       \IPOVLEN))
                                          (EQ (SETQ OPTION (LDB (BYTE 5 0)
                                                                (\GETBASEBYTE OPTIONSSTART INDEX)))
                                              IPOPT.END))
       do (if (EQ OPTION IPOPT.NOP)
                  then                                   (* ; 
                                 "This is the only one-byte option we know of other than IPOPT.END")
                        (add INDEX 1)
                else (SELECTC OPTION
                             ((LIST IPOPT.LSRR IPOPT.SSSR) 
                                  (COND
                                     (REROUTING (SETQ RESULT INDEX))
                                     ((NEQ (SETQ RESULT (\IP.OPTION.STRICT.SOURCE.ROUTE IP INDEX)
                                            )
                                           'REROUTE)
                                      (SETQ REROUTING T))))
                             (IPOPT.RECRT (SETQ RESULT (\IP.OPTION.RECORD.ROUTE IP INDEX)))
                             (IPOPT.TIMESTAMP 
                                  (\IP.OPTION.TIMESTAMP IP INDEX))
                             (IPOPT.SECURITY)
                             (IPOPT.STREAMID)
                             (PROGN                          (* ; 
            "Unknown option code-- we can't continue, since it could be some unknown 1-byte option")
                                    (RETURN NIL)))
                      (COND
                         ((NUMBERP RESULT)

                          (* ;; 
        "If the result is a number then there was a parameter problem. We could process them here.")

                          (RETURN NIL)))
                      (add INDEX (\GETBASEBYTE OPTIONSSTART (ADD1 INDEX))) 
                                                             (* ; "Increment by the length field")
                     ) finally (RETURN RESULT])

(\IP.OPTION.RECORD.ROUTE
  [LAMBDA (IP INDEX)                                     (* ; "Edited  2-Aug-88 14:57 by atm")
    (LET* [(OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1)))
           (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2]

          (* ;; "From RFC 791: If the route data area is already full just forward. If there is room , but not enough for a full address to be inserted, signal an ICMP error. Otherwise insert the address into the datagram and update PTR.")

          (COND
             ((IGREATERP PTR LENGTH)
              NIL)
             ((ILESSP (IDIFFERENCE LENGTH PTR)
                     3)
              INDEX)
             (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR)
                       (CAR \IP.LOCAL.ADDRESSES))
                (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                       (LDB (BYTE 8 0)
                            (IPLUS PTR 4)))
                T])

(\IP.OPTION.STRICT.SOURCE.ROUTE
  [LAMBDA (IP INDEX)                                     (* ; "Edited  8-Aug-88 12:05 by atm")
    (LET* ((OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1)))
           (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2)))
           (DESTINATIONADDRESSLOC (LOCF (ffetch (IP IPDESTINATIONADDRESS) of IP)))
           (DESTINATIONADDRESS (\GETBASEFIXP DESTINATIONADDRESSLOC 0)))

          (* ;; "From RFC 791: If the address in the destination field has been reached and PTR is not greater than LENGTH, the next address in the source route replaces the address in the destination address field, and the recorded route address replaces the source address just used, and PTR is increased by four.")

          (COND
             ((IGREATERP PTR LENGTH)
              NIL)
             ((ILESSP (IDIFFERENCE LENGTH PTR)
                     3)
              INDEX)
             (T (COND
                   ((MEMBER DESTINATIONADDRESS \IP.LOCAL.ADDRESSES)
                    (\PUTBASEFIXP OPTIONSSTART (IPLUS PTR INDEX 4)
                           DESTINATIONADDRESS)
                    (\PUTBASEFIXP DESTINATIONADDRESSLOC 0 (\GETBASEFIXP OPTIONSSTART (IPLUS PTR INDEX
                                                                                            )))
                    (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                           (LDB (BYTE 8 0)
                                (IPLUS PTR 4)))
                    'REROUTE)
                   (T])

(\IP.OPTION.TIMESTAMP
  [LAMBDA (IP INDEX)                                     (* ; "Edited  8-Aug-88 12:08 by atm")
    (LET* ((OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1)))
           (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2)))
           (OFLW/FLG (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 3)))
           FLAG)

          (* ;; "From RFC 791: If the timestamp area is already full then increment the overflow flag and forward the datagram without inserting the timestamp. If there is room but not enough for a full timestamp to be inserted then signal an ICMP error. Otherwise insert the timestamp or the timestamp and the internet address depending on the flag; 0 indicates timestamp only, 1 indicates timestamp and address, 3 indicates that the address is prespecified.")

          (COND
             ((IGREATERP PTR LENGTH)
              (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 3)
                     (IPLUS OFLW/FLG (LSH 1 4)))
              T)
             (T (SELECTQ (LOGAND 15 OFLW/FLG)
                    (0 (COND
                          ((ILESSP (IDIFFERENCE LENGTH PTR)
                                  3)
                           INDEX)
                          (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR)
                                    (\CLOCK0 (\CREATECELL \FIXP)))
                             (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                                    (LDB (BYTE 8 0)
                                         (IPLUS PTR 4)))
                             T)))
                    (1 (COND
                          ((IGREATERP 8 (IDIFFERENCE LENGTH (SUB1 PTR)))
                           INDEX)
                          (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR)
                                    (CAR \IP.LOCAL.ADDRESSES))
                             (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR 4)
                                    (\CLOCK0 (\CREATECELL \FIXP)))
                             (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                                    (LDB (BYTE 8 0)
                                         (IPLUS PTR 8)))
                             T)))
                    (3 [COND
                          ((IGREATERP 8 (IDIFFERENCE LENGTH (SUB1 PTR)))
                           INDEX)
                          (T (COND
                                ((MEMBER (\GETBASEFIXP OPTIONSSTART (IPLUS INDEX PTR))
                                        \IP.LOCAL.ADDRESSES)
                                 (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR 4)
                                        (\CLOCK0 (\CREATECELL \FIXP)))
                                 (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                                        (LDB (BYTE 8 0)
                                             (IPLUS PTR 8)))
                                 T)
                                (T NIL])
                    INDEX])
)



(* ;; "Packet Transmission and routing")


(RPAQ? \IP.ROUTING.TABLE (CONS))

(RPAQ? \IP.DEFAULT.GATEWAY )

(RPAQ? \IP.LOCAL.NETWORKS )

(RPAQ? \IP.GATEWAY.FORWARDING.FUNCTIONS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS \IP.GATEWAY.FORWARDING.FUNCTIONS
       )
)
(DEFINEQ

(\IP.SETUPIP
  [LAMBDA (IP DESTHOST ID SOCKET REQUEUE)                (* ejs%: "31-Mar-86 15:01")

         (* * Initialize IP header of packet.)

    (OR IP (SETQ IP (\ALLOCATE.ETHERPACKET)))
    (replace (IP IPVERSION) of IP with \IP.PROTOCOLVERSION)
    (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI \IPOVLEN BYTESPERCELL))
    (freplace (IP IPTOTALLENGTH) of IP with \IPOVLEN)
    [freplace (IP IPID) of IP with (OR (SMALLP ID)
                                                   (LOGAND (DAYTIME)
                                                          (MASK.1'S 0 16]
    (freplace (IP IPMOREFRAGMENTS) of IP with NIL)
    (freplace (IP IPFRAGMENTOFFSET) of IP with 0)
    (freplace (IP IPTIMETOLIVE) of IP with \IP.DEFAULT.TIME.TO.LIVE)
    (freplace (IP IPPROTOCOL) of IP with (fetch (IPSOCKET PROTOCOL) of SOCKET))
    (freplace (IP IPSOURCEADDRESS) of IP with (CAR \IP.LOCAL.ADDRESSES))
    (freplace (IP IPDESTINATIONADDRESS) of IP with DESTHOST)
    (freplace EPREQUEUE of IP with REQUEUE)
    IP])

(\IP.TRANSMIT
  [LAMBDA (IP ROUTINGREADONLY)                           (* ejs%: "27-Jan-86 15:59")

         (* * Sends an IP packet, after first computing the IP header checksum)

    (PROG (NDB)
          (SETQ IP (\DTEST IP 'ETHERPACKET))
          (until \IP.READY do (AWAIT.EVENT \IP.READY.EVENT))
          (\RCLK (LOCF (ffetch EPTIMESTAMP of IP)))
          (replace EPTYPE of IP with \EPT.IP)
          (RETURN (COND
                     ((ffetch EPTRANSMITTING of IP)
                      (AND IPTRACEFLG (printout IPTRACEFILE 
                                             "[Put fails--packet already being transmitted]"))
                      'AlreadyQueued)
                     ((NOT (SETQ NDB (\IP.ROUTE.PACKET IP ROUTINGREADONLY)))
                      (AND IPTRACEFLG (PRINTPACKET IP 'PUT IPTRACEFILE "[Put fails--no routing]"))
                      (\REQUEUE.ETHERPACKET IP)
                      'NoRouting)
                     (T (\IP.SET.CHECKSUM IP (ffetch (IP IPBASE) of IP)
                               (LLSH (ffetch (IP IPHEADERLENGTH) of IP)
                                     2)
                               (LOCF (ffetch (IP IPHEADERCHECKSUM) of IP)))
                        [COND
                           (IPTRACEFLG (COND
                                          ((EQ IPTRACEFLG T)
                                           (PRINTPACKET IP 'PUT IPTRACEFILE))
                                          (T (PRIN1 "!" IPTRACEFILE]
                        (TRANSMIT.ETHERPACKET NDB IP)
                        NIL])

(\IP.ROUTE.PACKET
  [LAMBDA (IP READONLY)                                  (* ; "Edited 19-Jan-89 18:00 by bvm")

    (* ;; "Encapsulates XIP, choosing the right network and immediate destination host.  Returns an NDB for the transmission.  Unless READONLY is true, defaults source and destination nets if needed")

    (DECLARE (GLOBALVARS \10MBLOCALNDB \3MBLOCALNDB \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY))
    (PROG ((DESTADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP))
           DESTNET SUBNETMASK SOURCEHOSTADDRESS SUBNETINUSE PDH ROUTE NDB EPTYPE BROADCASTP)
          (SETQ DESTNET (\IPNETADDRESS DESTADDRESS))

     (* ;; "Try to resolve a destination network of 0.0 If we have two attached networks, fail.")

          [COND
             ((AND (EQ 0 DESTADDRESS)
                   \10MBLOCALNDB \3MBLOCALNDB)
              (RETURN))
             ((EQ 0 DESTADDRESS)
              '[SETQ DESTADDRESS (\IP.MAKE.BROADCAST.ADDRESS (fetch NDBIPHOST#
                                                                    of (OR \10MBLOCALNDB 
                                                                               \3MBLOCALNDB]
              (SETQ DESTADDRESS -1)
              (SETQ BROADCASTP T)
              '(SETQ DESTNET (\IPNETADDRESS DESTADDRESS))
              (SETQ DESTNET (CAAR \IP.LOCAL.NETWORKS]

     (* ;; "First see if the destination network is one of our local networks")

          [COND
             [(AND (SETQ NDB (CDR (SASSOC DESTNET \IP.LOCAL.NETWORKS)))
                   (SETQ SUBNETMASK (CDR (SASSOC (SETQ SOURCEHOSTADDRESS (fetch (NDB NDBIPHOST#)
                                                                            of NDB))
                                                \IP.SUBNET.MASKS)))
                   (OR (AND (\IP.BROADCAST.ADDRESS DESTADDRESS)
                            (SETQ BROADCASTP T))
                       (EQP (LOGAND SOURCEHOSTADDRESS SUBNETMASK)
                            (LOGAND DESTADDRESS SUBNETMASK))
                       (PROGN (SETQ SUBNETINUSE T)
                              NIL)))

              (* ;; "A local net.  Try to find the Ethernet address of the host")

              (COND
                 [(SETQ PDH (SELECTQ (fetch (NDB NETTYPE) of NDB)
                                (10 (SETQ EPTYPE \EPT.IP)
                                    (COND
                                       (BROADCASTP BROADCASTNSHOSTNUMBER)
                                       (T (\AR.TRANSLATE.TO.10MB DESTADDRESS))))
                                (3 (SETQ EPTYPE \EET.IP)
                                   (\AR.TRANSLATE.TO.3MB DESTADDRESS))
                                (SHOULDNT]
                 (T                                          (* ; "Nope")
                    (RETURN]
             (T 
                (* ;; "The host is not on a local net.  See if we have a route to that host, or use the default route if necessary")

                (COND
                   [(SETQ ROUTE (OR [COND
                                       (SUBNETINUSE (CDR (SASSOC (LOGAND DESTADDRESS SUBNETMASK)
                                                                \IP.ROUTING.TABLE)))
                                       (T (CDR (SASSOC DESTNET \IP.ROUTING.TABLE]
                                    \IP.DEFAULT.GATEWAY))

                    (* ;; "We've got the IP address of the gateway")

                    (COND
                       [(SETQ NDB (CDR (SASSOC (\IPNETADDRESS ROUTE)
                                              \IP.LOCAL.NETWORKS)))

                        (* ;; "We know what network it's on")

                        (COND
                           [(SETQ PDH (SELECTQ (fetch (NDB NETTYPE) of NDB)
                                          (10 (SETQ EPTYPE \EPT.IP)
                                              (\AR.TRANSLATE.TO.10MB ROUTE))
                                          (3 (SETQ EPTYPE \EET.IP)
                                             (\AR.TRANSLATE.TO.3MB ROUTE))
                                          (SHOULDNT]
                           (T (RETURN]
                       (T (ERROR "IP routing table contains non-local gateway address for network" 
                                 DESTNET]
                   (T (RETURN]
          (freplace EPNETWORK of IP with NDB)
          (ENCAPSULATE.ETHERPACKET NDB IP PDH (ffetch (IP IPTOTALLENGTH) of IP)
                 EPTYPE)
          (replace EPTYPE of IP with EPTYPE)
          [COND
             ((NOT READONLY)
              (COND
                 ((EQ 0 (fetch (IP IPDESTINATIONADDRESS) of IP))
                  (freplace (IP IPDESTINATIONADDRESS) of IP with DESTADDRESS)))
              (freplace (IP IPSOURCEADDRESS) of IP with (fetch NDBIPHOST#
                                                                       of NDB]
          (RETURN NDB])
)
(DEFINEQ

(IP.GET
  [LAMBDA (IPSOCKET WAIT)                                (* ejs%: "31-Mar-86 14:30")

         (* * Returns the next IP packet on the queue, or NIL if none exist and WAIT is 
       NIL. If WAIT is T, this function waits forever.
       If WAIT is an integer, it is interpreted as the number of milliseconds to wait 
       before returning NIL or a packet which arrives during that time.
       This function therefore is like GETXIP and GETPUP)

    (PROG ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET))
           IP TIMER)
      LP  (UNINTERRUPTABLY
              (COND
                 ((SETQ IP (\DEQUEUE QUEUE))
                  (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET)
                         -1))))
          [COND
             ((NULL IP)
              (COND
                 (WAIT (COND
                          ((EQ WAIT T))
                          [TIMER (COND
                                    ((TIMEREXPIRED? TIMER)
                                     (RETURN]
                          (T (OR (FIXP WAIT)
                                 (LISPERROR "NON-NUMERIC ARG" WAIT))
                             (SETQ TIMER (SETUPTIMER WAIT))
                             T))
                       (AWAIT.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)
                              TIMER T)
                       (GO LP))
                 (T (BLOCK]
          (RETURN IP])

(IP.SEND
  [LAMBDA (IP)                                           (* ejs%: "31-Mar-86 15:07")
    (\IP.TRANSMIT IP])

(IP.PACKET.WATCHER
  [LAMBDA (IPSOCKET PACKET.FUNCTION)                     (* ejs%: "31-Mar-86 15:50")

         (* * Infinite loop which waits for packet on IPSOCKET, and calls 
       PACKET.FUNCTION whenever one arrives)

    (COND
       ((NOT (type? IPSOCKET IPSOCKET))
        (ERROR "ARG NOT IPSOCKET" IPSOCKET))
       ((NOT (FNTYP PACKET.FUNCTION))
        (ERROR "UNDEFINED FUNCTION" PACKET.FUNCTION))
       (T (while T do (APPLY* PACKET.FUNCTION (IP.GET IPSOCKET T)
                                     IPSOCKET])
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS IP.SEND MACRO (LAMBDA (IP)                     (* ejs%: "31-Mar-86 15:07")
                          (\IP.TRANSMIT IP]
)



(* ;; "Client functions for building packets")

(DEFINEQ

(\IP.APPEND.BYTE
  [LAMBDA (IP BYTE INHEADER)                             (* ejs%: "28-Dec-84 08:23")

         (* * Append a byte to an IP packet. If INHEADER is not NIL, we adjust the 
       header length field as well.)

    (PROG (NEWLENGTH)
          (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                 (fetch (IP IPTOTALLENGTH) of IP)
                 BYTE)
          (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP)
                                 1))
          [COND
             (INHEADER (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI NEWLENGTH 4]
          (RETURN NEWLENGTH])

(\IP.APPEND.CELL
  [LAMBDA (IP CELL INHEADER)                             (* ejs%: "28-Dec-84 08:33")

         (* * Append a cell to an IP packet. If INHEADER is not NIL, we adjust the 
       header length field as well.)

    (PROG (NEWLENGTH (OFFSET (fetch (IP IPTOTALLENGTH) of IP)))
          [COND
             ((EVENP OFFSET)
              (\PUTBASEFIXP (fetch (IP IPBASE) of IP)
                     (FOLDLO OFFSET 2)
                     CELL))
             (T (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       OFFSET
                       (LDB (BYTE 8 24)
                            CELL))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 1)
                       (LDB (BYTE 8 16)
                            CELL))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 2)
                       (LDB (BYTE 8 8)
                            CELL))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 3)
                       (LDB (BYTE 8 0)
                            CELL]
          (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP)
                                 4))
          (COND
             (INHEADER (add (ffetch (IP IPHEADERLENGTH) of IP)
                              1)))
          (RETURN NEWLENGTH])

(\IP.APPEND.STRING
  [LAMBDA (IP STRING)                                    (* ejs%: " 9-Feb-85 19:44")
    (PROG ((LENGTH (fetch (STRINGP LENGTH) of STRING)))
          (\MOVEBYTES (fetch (STRINGP BASE) of STRING)
                 (fetch (STRINGP OFFST) of STRING)
                 (fetch (IP IPBASE) of IP)
                 (fetch (IP IPTOTALLENGTH) of IP)
                 LENGTH)
          (RETURN (add (ffetch (IP IPTOTALLENGTH) of IP)
                         LENGTH])

(\IP.APPEND.WORD
  [LAMBDA (IP WORD INHEADER)                             (* ejs%: "28-Dec-84 08:28")

         (* * Append a word to an IP packet. If INHEADER is not NIL, we adjust the 
       header length field as well.)

    (PROG (NEWLENGTH (OFFSET (fetch (IP IPTOTALLENGTH) of IP)))
          [COND
             ((EVENP OFFSET)
              (\PUTBASE (fetch (IP IPBASE) of IP)
                     (FOLDLO OFFSET 2)
                     WORD))
             (T (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       OFFSET
                       (LDB (BYTE 8 8)
                            WORD))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 1)
                       (LDB (BYTE 8 0)
                            WORD]
          (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP)
                                 2))
          [COND
             (INHEADER (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI NEWLENGTH 4]
          (RETURN NEWLENGTH])

(\IP.GET.BYTE
  [LAMBDA (IP BYTE INHEADER)                             (* ejs%: "30-Mar-86 14:49")

         (* * Retrieve a byte from an IP packet.
       If INHEADER is T, BYTE is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

    (\GETBASEBYTE (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           BYTE])

(\IP.GET.CELL
  [LAMBDA (IP CELL INHEADER)                             (* ejs%: "30-Mar-86 15:07")

         (* * Retrieve a cell from an IP packet.
       If INHEADER is not NIL, the cell is written to the header portion of the IP 
       packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

    (\GETBASEFIXP (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           CELL])

(\IP.GET.STRING
  [LAMBDA (IP BYTEOFFSET NCHARS INHEADER)                (* ejs%: "30-Mar-86 15:13")

         (* * Retrieve a string from an IP packet.
       If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else 
       it's an offset from the start of the IP data section)

    (\GETBASESTRING (COND
                       (INHEADER (fetch (IP IPBASE) of IP))
                       (T (\IPDATABASE IP)))
           BYTEOFFSET NCHARS])

(\IP.GET.WORD
  [LAMBDA (IP WORD INHEADER)                             (* ejs%: "30-Mar-86 14:51")

         (* * Retrieve a word from an IP packet.
       If INHEADER is T, WORD is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

    (\GETBASE (COND
                 (INHEADER (fetch (IP IPBASE) of IP))
                 (T (\IPDATABASE IP)))
           WORD])

(\IP.PUT.BYTE
  [LAMBDA (IP BYTE VALUE INHEADER)                       (* ejs%: "30-Mar-86 14:52")

         (* * Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

    (\PUTBASEBYTE (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           BYTE VALUE])

(\IP.PUT.CELL
  [LAMBDA (IP CELL VALUE INHEADER)                       (* ejs%: "30-Mar-86 15:06")

         (* * Store a cell in an IP packet. If INHEADER is not NIL, the cell is written 
       to the header portion of the IP packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

    (\PUTBASEFIXP (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           CELL VALUE])

(\IP.PUT.STRING
  [LAMBDA (IP BYTEOFFSET STRING INHEADER)                (* ejs%: "30-Mar-86 15:13")

         (* * Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset 
       from the start of the packet, else it's an offset from the start of the IP data 
       section)

    (\PUTBASESTRING (COND
                       (INHEADER (fetch (IP IPBASE) of IP))
                       (T (\IPDATABASE IP)))
           BYTEOFFSET STRING])

(\IP.PUT.WORD
  [LAMBDA (IP WORD VALUE INHEADER)                       (* ejs%: "30-Mar-86 14:50")

         (* * Store a word in an IP packet. If INHEADER is T, WORD is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

    (\PUTBASE (COND
                 (INHEADER (fetch (IP IPBASE) of IP))
                 (T (\IPDATABASE IP)))
           WORD VALUE])
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS \IP.GET.BYTE DMACRO (LAMBDA (IP BYTE INHEADER) (* ejs%: "30-Mar-86 14:49")

         (* * Retrieve a byte from an IP packet.
       If INHEADER is T, BYTE is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

                                (\GETBASEBYTE (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       BYTE]

[PUTPROPS \IP.GET.CELL DMACRO (LAMBDA (IP CELL INHEADER) (* ejs%: "30-Mar-86 15:07")

         (* * Retrieve a cell from an IP packet.
       If INHEADER is not NIL, the cell is written to the header portion of the IP 
       packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

                                (\GETBASEFIXP (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       CELL]

[PUTPROPS \IP.GET.STRING DMACRO (LAMBDA (IP BYTEOFFSET NCHARS INHEADER)
                                                             (* ejs%: "30-Mar-86 15:13")

         (* * Retrieve a string from an IP packet.
       If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else 
       it's an offset from the start of the IP data section)

                                  (\GETBASESTRING (COND
                                                     (INHEADER (fetch (IP IPBASE) of IP))
                                                     (T (\IPDATABASE IP)))
                                         BYTEOFFSET NCHARS]

[PUTPROPS \IP.GET.WORD DMACRO (LAMBDA (IP WORD INHEADER) (* ejs%: "30-Mar-86 14:51")

         (* * Retrieve a word from an IP packet.
       If INHEADER is T, WORD is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

                                (\GETBASE (COND
                                             (INHEADER (fetch (IP IPBASE) of IP))
                                             (T (\IPDATABASE IP)))
                                       WORD]

[PUTPROPS \IP.PUT.BYTE DMACRO (LAMBDA (IP BYTE VALUE INHEADER)
                                                             (* ejs%: "30-Mar-86 14:52")

         (* * Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

                                (\PUTBASEBYTE (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       BYTE VALUE]

[PUTPROPS \IP.PUT.CELL DMACRO (LAMBDA (IP CELL VALUE INHEADER)
                                                             (* ejs%: "30-Mar-86 15:06")

         (* * Store a cell in an IP packet. If INHEADER is not NIL, the cell is written 
       to the header portion of the IP packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

                                (\PUTBASEFIXP (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       CELL VALUE]

[PUTPROPS \IP.PUT.STRING DMACRO (LAMBDA (IP BYTEOFFSET STRING INHEADER)
                                                             (* ejs%: "30-Mar-86 15:13")

         (* * Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset 
       from the start of the packet, else it's an offset from the start of the IP data 
       section)

                                  (\PUTBASESTRING (COND
                                                     (INHEADER (fetch (IP IPBASE) of IP))
                                                     (T (\IPDATABASE IP)))
                                         BYTEOFFSET STRING]

[PUTPROPS \IP.PUT.WORD DMACRO (LAMBDA (IP WORD VALUE INHEADER)
                                                             (* ejs%: "30-Mar-86 14:50")

         (* * Store a word in an IP packet. If INHEADER is T, WORD is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

                                (\PUTBASE (COND
                                             (INHEADER (fetch (IP IPBASE) of IP))
                                             (T (\IPDATABASE IP)))
                                       WORD VALUE]
)

(MOVD? 'NILL 'IP.DEFAULT.CONFIGURATION)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS 
       \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST)
)
)
(PUTPROPS TCPLLIP COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (33488 35161 (\SYSQUEUE.DEFPRINT 33498 . 33847) (\IPSOCKET.DEFPRINT 33849 . 35159)) (
36483 52693 (\CANONICALIZE.IP.HOSTNAME 36493 . 36686) (DODIP.HOSTP 36688 . 37144) (IPHOSTADDRESS 37146
 . 37814) (IPHOSTNAME 37816 . 38028) (IPTRACE 38030 . 38227) (IPTRACEWINDOW.BUTTONFN 38229 . 38826) (
PRINTIP 38828 . 41424) (PRINTIPDATA 41426 . 42106) (\IPADDRESSCLASS 42108 . 42705) (\IPEVENTFN 42707
 . 43055) (\IPHOSTADDRESS 43057 . 43873) (\IPNETADDRESS 43875 . 44739) (\IP.ADDRESS.TO.STRING 44741 . 
45229) (\IP.BROADCAST.ADDRESS 45231 . 48921) (\IP.LEGAL.ADDRESS 48923 . 49271) (
\IP.MAKE.BROADCAST.ADDRESS 49273 . 49713) (\IP.PRINT.ADDRESS 49715 . 50333) (\IP.READ.STRING.ADDRESS 
50335 . 52200) (\DOMAIN.NAME.QUALIFY.FULLY 52202 . 52691)) (53342 70901 (STOPIP 53352 . 53628) (
\IPINIT 53630 . 55639) (\IPLISTENER 55641 . 56413) (\IP.REINITIALIZE.FROM.SCRATCH 56415 . 61690) (
\IP.RESTART.FROM.CONFIGURATION 61692 . 66877) (\IP.MAYBE.READ.HOSTS.TXT 66879 . 68355) (
\IP.READ.INIT.FILE 68357 . 70174) (\IP.PROMPT.FOR.FILE.NAME 70176 . 70899)) (75225 84872 (
\HANDLE.RAW.IP 75235 . 77533) (\FORWARD.IP 77535 . 80265) (\IP.LOCAL.DESTINATION 80267 . 82052) (
\IPCHECKSUM 82054 . 84204) (\IP.CHECKSUM.OK 84206 . 84382) (\IP.SET.CHECKSUM 84384 . 84870)) (85442 
97726 (\IP.HAND.TO.PROTOCOL 85452 . 86504) (\IP.DEFAULT.INPUTFN 86506 . 87105) (\IP.DEFAULT.NOSOCKETFN
 87107 . 87491) (\IP.ADD.PROTOCOL 87493 . 89620) (\IP.DELETE.PROTOCOL 89622 . 90351) (
\IP.FIND.PROTOCOL 90353 . 90740) (\IP.FIND.PROTOCOL.SOCKET 90742 . 92342) (\IP.FIND.SOCKET 92344 . 
93234) (\IP.OPEN.SOCKET 93236 . 96216) (\IP.CLOSE.SOCKET 96218 . 97724)) (98507 118821 (
\HANDLE.RAW.IP.FRAGMENT 98517 . 99124) (\IP.NEW.FRAGMENT.LST 99126 . 102391) (
\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER 102393 . 102894) (\IP.ADD.FRAGMENT 102896 . 111986) (
\IP.FIND.MATCHING.FRAGMENTS 111988 . 114409) (\IP.FRAGMENTED.PACKET 114411 . 114700) (
\IP.CHECK.REASSEMBLY.TIMEOUTS 114702 . 116007) (\IP.DELETE.FRAGMENT 116009 . 116501) (
\IP.PRINT.FRAGMENT 116503 . 118819)) (119865 128230 (\IP.PROCESS.OPTIONS 119875 . 122592) (
\IP.OPTION.RECORD.ROUTE 122594 . 123607) (\IP.OPTION.STRICT.SOURCE.ROUTE 123609 . 125209) (
\IP.OPTION.TIMESTAMP 125211 . 128228)) (128581 136430 (\IP.SETUPIP 128591 . 129761) (\IP.TRANSMIT 
129763 . 131402) (\IP.ROUTE.PACKET 131404 . 136428)) (136431 138607 (IP.GET 136441 . 137907) (IP.SEND 
137909 . 138041) (IP.PACKET.WATCHER 138043 . 138605)) (138832 146433 (\IP.APPEND.BYTE 138842 . 139504)
 (\IP.APPEND.CELL 139506 . 140978) (\IP.APPEND.STRING 140980 . 141518) (\IP.APPEND.WORD 141520 . 
142611) (\IP.GET.BYTE 142613 . 143077) (\IP.GET.CELL 143079 . 143589) (\IP.GET.STRING 143591 . 144084)
 (\IP.GET.WORD 144086 . 144538) (\IP.PUT.BYTE 144540 . 144994) (\IP.PUT.CELL 144996 . 145496) (
\IP.PUT.STRING 145498 . 145987) (\IP.PUT.WORD 145989 . 146431)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPNAMES b/obsolete/tcp/TCPNAMES
new file mode 100644
index 00000000..13c7aa25
--- /dev/null
+++ b/obsolete/tcp/TCPNAMES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 8-Oct-90 17:23:42" |{LISPDEV:LAIR:OHIO-STATE}<WELCH>TCPNAMES.;2| 70558  

      changes to%:  (VARS TCPNAMESCOMS)
                    (FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.MSDOS 
                         REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.VMS 
                         REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.TOPS20 
                         REPACKFILENAME.STRING.UNIX \REPACKFILENAME.NEW.TRANSLATION 
                         \REPACKFILENAME.NEW.TRANSLATIONS)

      previous date%: "12-Sep-90 17:37:35" {DSK}<users>gadener>medley>work>tcp>tcpnames.;2)


(* ; "
Copyright (c) 1985, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPNAMESCOMS)

(RPAQQ TCPNAMESCOMS [(PROP MAKEFILE-ENVIRONMENT TCPNAMES)
                         (PROP FILETYPE TCPNAMES)
                         (FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D 
                              REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.TI 
                              REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.3600 
                              REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX 
                              \REPACKFILENAME.NEW.TRANSLATION \REPACKFILENAME.NEW.TRANSLATIONS)
                         (INITVARS (\REPACKFILENAME.OSTYPE.TABLE (HASHARRAY 30 1.1)))
                         (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE)
                         (P (\REPACKFILENAME.NEW.TRANSLATIONS (INTERLISP IFS)
                                   REPACKFILENAME.STRING.D
                                   (TOPS-20 TOPS20)
                                   REPACKFILENAME.STRING.TOPS20
                                   (SYMBOLICS-3600 LISPM GENERA)
                                   REPACKFILENAME.STRING.3600 VMS REPACKFILENAME.STRING.VMS UNIX 
                                   REPACKFILENAME.STRING.UNIX MS-DOS REPACKFILENAME.STRING.MSDOS))
                         (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
                                (ADDVARS (NLAMA \REPACKFILENAME.NEW.TRANSLATIONS)
                                       (NLAML)
                                       (LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20
                                             REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.VMS 
                                             REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.MSDOS 
                                             REPACKFILENAME.STRING.D])

(PUTPROPS TCPNAMES MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10))

(PUTPROPS TCPNAMES FILETYPE :BCOMPL)
(DEFINEQ

(REPACKFILENAME.STRING
  [LAMBDA (NAME FOROSTYPE)                               (* ; "Edited 29-Sep-90 11:47 by welch")
    (DECLARE (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE))
    (LET ((REPACKFUNCTION (GETHASH FOROSTYPE \REPACKFILENAME.OSTYPE.TABLE)))
         (COND
            ((NULL REPACKFUNCTION)
             NAME)
            (T (APPLY REPACKFUNCTION (UNPACKFILENAME.STRING NAME])

(REPACKFILENAME.STRING.D
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:23 by welch")

         (* * Convert file names to native format)

    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.D)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY DIR NAME EXTENSION 
             VERSION PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.D VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE \)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE >]
                                        (LIST "<" DIRECTORY ">"))
                                 (LIST "<" DIRECTORY ">"))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (CHARCODE >)
                                                                    (LIST (CHARCODE \)
                                                                          (CHARCODE /]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE >]
                                        (LIST "<" SUBDIRECTORY ">"))
                                 (LIST "<" SUBDIRECTORY ">"))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (CHARCODE >)
                                                                    (LIST (CHARCODE \)
                                                                          (CHARCODE /]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        >]
                                        (LIST "<" RELATIVEDIRECTORY ">"))
                                 (LIST "<" RELATIVEDIRECTORY ">"))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '; VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '; (SUBSTRING VERSION 2 -1)))
                                            (LIST '; VERSION])

(REPACKFILENAME.STRING.MSDOS
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:48 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.MSDOS)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR RELATIVEDIRECTORY 
             SUBDIRECTORY VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY 
                                NAME EXTENSION VERSION))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.MSDOS VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            (AND DEVICE (NEQ DEVICE BLIP)
                                 (LIST ":" DEVICE))
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE \]
                                        (LIST "\" DIRECTORY "\"))
                                 (LIST "\" DIRECTORY "\"))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE \]
                                        (LIST "\" SUBDIRECTORY "\"))
                                 (LIST "\" SUBDIRECTORY "\"))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        \]
                                        (LIST "\" RELATIVEDIRECTORY "\"))
                                 (LIST "\" RELATIVEDIRECTORY "\"))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((OR (AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                                  (CHARCODE %.)))
                                               (OR (NULL EXTENSION)
                                                   (EQ EXTENSION BLIP)
                                                   (STREQUAL EXTENSION "")))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP])

(REPACKFILENAME.STRING.TI
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:59 by welch")

         (* * Can you believe this???)

    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.TI)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION 
             PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY 
                                NAME EXTENSION VERSION))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.TI VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST HOST ":"))
                            (AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE |':|)))
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE %.]
                                        (LIST DIRECTORY ";")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.]
                                        (LIST SUBDIRECTORY ";")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        %.]
                                        (LIST RELATIVEDIRECTORY ";")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '%# VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (%# (LIST VERSION))
                                            ((%. ! ;) 
                                                 (LIST '%# (SUBSTRING VERSION 2 -1)))
                                            (L (LIST '%# 'OLDEST))
                                            ((H 0) 
                                                 (LIST '%# '>))
                                            (LIST '%# VERSION])

(REPACKFILENAME.STRING.VMS
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:52 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.VMS)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION 
             TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY 
                                NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.VMS VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE %.]
                                        (LIST "[" DIRECTORY "]")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.]
                                        (LIST "[" SUBDIRECTORY "]")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        %.]
                                        (LIST "[" RELATIVEDIRECTORY "]")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '; VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '; (SUBSTRING VERSION 2 -1)))
                                            (LIST '; VERSION])

(REPACKFILENAME.STRING.3600
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:46 by welch")

         (* * Can you believe this???)

    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.3600)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP 
             RELATIVEDIRECTORY SUBDIRECTORY)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION 
                                SUBDIRECTORY RELATIVEDIRECTORY))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.3600 VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST HOST ":"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE >]
                                        (LIST ">" DIRECTORY ">")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE >]
                                        (LIST ">" SUBDIRECTORY ">")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        >]
                                        (LIST ">" RELATIVEDIRECTORY ">")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '%. VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '%. (SUBSTRING VERSION 2 -1)))
                                            (L (LIST '%. 'OLDEST))
                                            ((H 0) 
                                                 (LIST '%. 'NEWEST))
                                            (LIST '%. VERSION])

(REPACKFILENAME.STRING.TOPS20
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:42 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.TOPS20)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY RELATIVEDIRECTORY 
             SUBDIRECTORY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY 
                                PROTECTION ACCOUNT))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.TOPS20 VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (SELECTQ TEMPORARY
                ((T S ;S)                                    (* hack for Interlisp-D!)
                     (OR HOST DEVICE (PROGN (SETQ HOST 'CORE)
                                            (SETQ TEMPORARY))))
                NIL)
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE %.]
                                        (LIST "<" DIRECTORY ">")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.]
                                        (LIST "<" SUBDIRECTORY ">")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        %.]
                                        (LIST "<" RELATIVEDIRECTORY ">")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            [AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '%. VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '%. (SUBSTRING VERSION 2 -1)))
                                            (L (LIST '%. -2))
                                            (H (LIST '%. 0))
                                            (LIST '%. VERSION]
                            (AND TEMPORARY (NEQ TEMPORARY BLIP)
                                 (LIST '; (SELECTQ TEMPORARY
                                              ((S ;S) 
                                                   'S)
                                              T])

(REPACKFILENAME.STRING.UNIX
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:48 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.UNIX)
                     (ARG N 1))
      else (PROG ((BLIP "")
                      (I 1)
                      HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY DIR NAME 
                      EXTENSION VERSION PACKLIST VAR VAL TEMP)
                     (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME RELATIVEDIRECTORY 
                                         SUBDIRECTORY EXTENSION VERSION))
                 LP  (COND
                        ((NOT (IGREATERP I N))
                         (COND
                            ((LISTP (SETQ VAR (ARG N I)))
                             (SETQ VAL (CDR VAR))
                             (SETQ VAR (CAR VAR)))
                            ((NOT (IGREATERP (SETQ I (ADD1 I))
                                         N))
                             (SETQ VAL (ARG N I)))
                            (T (SETQ VAL)))
                         (OR (STRINGP VAL)
                             (ATOM VAL)
                             (ERRORX (LIST 27 VAL)))         (* fields must be atom)
                         (SELECTQ VAR
                             (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                                  ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                                   (REPACKFILENAME.STRING.UNIX
                                                                    VAL))
                                                                  (T VAL)))
                                        [FUNCTION (LAMBDA (X)(* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                                    (OR (EVALV (CAR X))
                                                        (SET (CAR X)
                                                             (OR (CADR X)
                                                                 BLIP]
                                        (FUNCTION CDDR)))
                             (HOST (OR HOST (SETQ HOST
                                             (if VAL
                                                 then (SELCHARQ (CHCON1 VAL)
                                                               (({ %[ %() 
                                                                    (SUBSTRING VAL 2
                                                                           (SELCHARQ (NTHCHARCODE
                                                                                      VAL -1)
                                                                                ((} %] %)) 
                                                                                     -2)
                                                                                -1)))
                                                               VAL)
                                               else BLIP))))
                             (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                             (if VAL
                                                                 then (CONCAT (
                                                                                  CL:STRING-LEFT-TRIM
                                                                                   "<"
                                                                                   (
                                                                              CL:DIRECTORY-NAMESTRING
                                                                                    
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                                    ))
                                                                                 VAL)
                                                               else BLIP))))
                             (RELATIVEDIRECTORY 
                                  (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                         (if VAL
                                                             then (CONCAT (CL:STRING-LEFT-TRIM
                                                                               "<"
                                                                               (
                                                                              CL:DIRECTORY-NAMESTRING
                                                                                
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                                ))
                                                                             VAL)
                                                           else BLIP))))
                             (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                             ((DEVICE HOST NAME EXTENSION VERSION) 
                                  (OR (EVALV VAR)
                                      (SET VAR (OR VAL BLIP))))
                             (\ILLEGAL.ARG VAR))
                         (SETQ I (ADD1 I))
                         (GO LP)))
                     (RETURN (CONCATLIST
                              (NCONC (AND HOST (NEQ HOST BLIP)
                                          (LIST "{" HOST "}"))
                                     (AND DEVICE (NEQ DEVICE BLIP)
                                          (LIST "/" DEVICE))
                                     (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                          (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                                 [for C from 1 to (NCHARS DIRECTORY)
                                                    do (COND
                                                              ((EQ (NTHCHARCODE DIRECTORY C)
                                                                   (CONSTANT (CHARCODE >)))
                                                               (RPLCHARCODE DIRECTORY C (CHARCODE
                                                                                         /]
                                                 (LIST "/" DIRECTORY "/"))
                                          (LIST "/" DIRECTORY "/"))
                                     (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                          (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                                 [for C from 1 to (NCHARS SUBDIRECTORY)
                                                    do (COND
                                                              ((EQ (NTHCHARCODE SUBDIRECTORY C)
                                                                   (CONSTANT (CHARCODE >)))
                                                               (RPLCHARCODE SUBDIRECTORY C
                                                                      (CHARCODE /]
                                                 (LIST "/" SUBDIRECTORY "/"))
                                          (LIST "/" SUBDIRECTORY "/"))
                                     (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                          (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                                 [for C from 1 to (NCHARS 
                                                                                    RELATIVEDIRECTORY
                                                                                     )
                                                    do (COND
                                                              ((EQ (NTHCHARCODE RELATIVEDIRECTORY C)
                                                                   (CONSTANT (CHARCODE >)))
                                                               (RPLCHARCODE RELATIVEDIRECTORY C
                                                                      (CHARCODE /]
                                                 (LIST "/" RELATIVEDIRECTORY "/"))
                                          (LIST "/" RELATIVEDIRECTORY "/"))
                                     (AND NAME (NEQ NAME BLIP)
                                          (LIST NAME))
                                     (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                              (AND VERSION (NEQ VERSION BLIP)))
                                          (LIST (COND
                                                   ((OR (AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                                           (CHARCODE %.)))
                                                        (OR (NULL EXTENSION)
                                                            (EQ EXTENSION BLIP)
                                                            (STREQUAL EXTENSION "")))
                                                    BLIP)
                                                   (T '%.))
                                                (OR EXTENSION BLIP])

(\REPACKFILENAME.NEW.TRANSLATION
  [LAMBDA (OSTYPE FUNCTION)
    (DECLARE (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE))
                                                             (* ejs%: "27-Apr-85 13:36")
    (PUTHASH OSTYPE FUNCTION \REPACKFILENAME.OSTYPE.TABLE])

(\REPACKFILENAME.NEW.TRANSLATIONS
  [NLAMBDA NAMES                                         (* ejs%: "27-Apr-85 13:36")

         (* * Supply a property-list format argument of ostypes and translating 
       functions to be added to ostype table)

    (for TAIL on NAMES by (CDDR TAIL) do (for OSTYPE inside (CAR TAIL)
                                                            do (\REPACKFILENAME.NEW.TRANSLATION
                                                                    OSTYPE
                                                                    (CADR TAIL])
)

(RPAQ? \REPACKFILENAME.OSTYPE.TABLE (HASHARRAY 30 1.1))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE)
)

(\REPACKFILENAME.NEW.TRANSLATIONS (INTERLISP IFS)
       REPACKFILENAME.STRING.D
       (TOPS-20 TOPS20)
       REPACKFILENAME.STRING.TOPS20
       (SYMBOLICS-3600 LISPM GENERA)
       REPACKFILENAME.STRING.3600 VMS REPACKFILENAME.STRING.VMS UNIX REPACKFILENAME.STRING.UNIX 
       MS-DOS REPACKFILENAME.STRING.MSDOS)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \REPACKFILENAME.NEW.TRANSLATIONS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.3600
                         REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.TI 
                         REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.D)
)
(PUTPROPS TCPNAMES COPYRIGHT ("Xerox Corporation" 1985 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2757 69593 (REPACKFILENAME.STRING 2767 . 3171) (REPACKFILENAME.STRING.D 3173 . 12368) (
REPACKFILENAME.STRING.MSDOS 12370 . 21255) (REPACKFILENAME.STRING.TI 21257 . 30611) (
REPACKFILENAME.STRING.VMS 30613 . 39537) (REPACKFILENAME.STRING.3600 39539 . 49180) (
REPACKFILENAME.STRING.TOPS20 49182 . 58763) (REPACKFILENAME.STRING.UNIX 58765 . 68684) (
\REPACKFILENAME.NEW.TRANSLATION 68686 . 68967) (\REPACKFILENAME.NEW.TRANSLATIONS 68969 . 69591)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPOPS b/obsolete/tcp/TCPOPS
new file mode 100644
index 00000000..5e47a466
--- /dev/null
+++ b/obsolete/tcp/TCPOPS
@@ -0,0 +1,212 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED "22-May-90 10:55:20" |{DSK}/home/neptune/jds/TCPOPS.;17| 14660  
+
+      |changes| |to:|  (FNS TCP-ACCEPT TCP-LISTEN UDP-RECV)
+
+      |previous| |date:| " 3-May-90 11:40:39" |{DSK}/home/neptune/jds/TCPOPS.;16|)
+
+
+; Copyright (c) 1989, 1990 by Savoir, Inc..  All rights reserved.
+
+(PRETTYCOMPRINT TCPOPSCOMS)
+
+(RPAQQ TCPOPSCOMS ((FILES CHARDEVICE) (ADDVARS (\\INITSUBRS (TCP 144))) (COMS (* |;;| "TCP Streams") (FNS \\TCP-DEV-INIT \\TCP-OPENFILE \\TCP-FORCEOUTPUT \\TCP-GETNEXTBUFFER \\TCP-EOFP \\TCP-CLOSEFILE \\TCP-EVENTFN \\TCP.BUFFERED.BOUTS) (P (\\TCP-DEV-INIT))) (COMS (* |;;| "User-level TCP operations") (FNS TCP OPENTCPSTREAM TCP-ACCEPT TCP-LISTEN TCP-CLOSE) (FNS UDP-LISTEN UDP-SEND UDP-RECV) (FNS GETHOSTFROMNAME GETHOSTFROMADDR GETHOSTFROMSOCKET GETHOSTNAME)) (DECLARE\: EVAL@LOAD DONTCOPY (COMS (* |;;| "Debugging functions &c") (VARS (BUFFER (\\ALLOCBLOCK 100))) (FNS TCPRECV TCPSEND SEEBUFFER FOON)))))
+
+(FILESLOAD CHARDEVICE)
+
+(ADDTOVAR \\INITSUBRS (TCP 144))
+
+
+
+(* |;;| "TCP Streams")
+
+(DEFINEQ
+
+(\\TCP-DEV-INIT
+(LAMBDA NIL (* \; "Edited 20-Feb-90 12:51 by jds") (* |;;| "Initialization for buffered Unix-character-oriented device (e.g. for TCP streams on SUN)") (SETQ \\TCP-FDEV (|create| FDEV DEVICENAME _ "TCP" FDBINABLE _ T FDBOUTABLE _ T BUFFERED _ T BIN _ (FUNCTION \\BUFFERED.BIN) BOUT _ (FUNCTION \\BUFFCHAR-OTHER-BOUT) OPENFILE _ (FUNCTION \\BUFFCHAR-DEV-OPENFILE) EVENTFN _ (FUNCTION \\CHAR-DEV-EVENTFN) REOPENFILE _ (FUNCTION \\BUFFCHAR-DEV-OPENFILE) CLOSEFILE _ (FUNCTION \\TCP-CLOSEFILE) FORCEOUTPUT _ (FUNCTION \\TCP-FORCEOUTPUT) EOFP _ (FUNCTION \\TCP-EOFP) BLOCKIN _ (FUNCTION \\BUFFERED.BINS) BLOCKOUT _ (FUNCTION \\TCP.BUFFERED.BOUTS) READP _ (FUNCTION \\GENERIC.READP) PEEKBIN _ (FUNCTION \\BUFFERED.PEEKBIN) GETNEXTBUFFER _ (FUNCTION \\TCP-GETNEXTBUFFER))) (\\DEFINEDEVICE (QUOTE TCP) \\TCP-FDEV))
+)
+
+(\\TCP-OPENFILE
+(LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) (* \; "Edited  7-Mar-90 10:11 by jds") (LET ((UNIX-NAME (SUBSTRING NAME (ADD1 (STRPOS "}" NAME)))) (ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (SELECTQ ACCESS (INPUT (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (SETQ ACCESS-VALUE 0)) (OUTPUT (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (REPLACE F2 OF STREAM WITH (SETQ OTHER-STREAM (|create| STREAM BINABLE _ NIL BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC))) (SETQ ACCESS-VALUE 1)) (BOTH (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (REPLACE F2 OF STREAM WITH (SETQ OTHER-STREAM (|create| STREAM BINABLE _ NIL BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC))) (SETQ ACCESS-VALUE 2)) (APPEND (\\ILLEGAL.ARG ACCESS)) (\\ILLEGAL.ARG ACCESS)) (COND ((SETQ IODESCRIPTOR (SUBRCALL CHAR-OPENFILE UNIX-NAME ACCESS-VALUE ERRNO)) (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| IODESCRIPTOR) (COND (OTHER-STREAM (|replace| (STREAM F1) |of| OTHER-STREAM |with| IODESCRIPTOR)))) (T (\\CHAR-ERROR ERRNO NAME))) STREAM))
+)
+
+(\\TCP-FORCEOUTPUT
+  (LAMBDA (STREAM WAIT)                                  (* \; "Edited 15-Dec-89 16:09 by jds")
+
+(* |;;;| "Generic buffer refiller for Buffered character streams (e.g. TCP streams on Sun, or the Lisp side of a shell CHAT, eventually)")
+
+    (PROG (ERRCODE (OTHER-STREAM (|fetch| F2 |of| STREAM))
+                 (ERRNO (\\CREATECELL \\FIXP))
+                 BUFFER)
+          (COND
+             ((NULL (|fetch| CPPTR |of| OTHER-STREAM))
+
+              (* |;;| "No buffer allocated yet; create one.")
+
+              (REPLACE CPPTR OF OTHER-STREAM WITH (NCREATE 'VMEMPAGEP))
+              (REPLACE CBUFSIZE OF OTHER-STREAM WITH 512)
+              (REPLACE CBUFMAXSIZE OF OTHER-STREAM WITH 512)
+              (REPLACE COFFSET OF OTHER-STREAM WITH 0)
+              T)
+             ((ZEROP (|fetch| COFFSET |of| OTHER-STREAM))
+              T)
+             ((SETQ ERRCODE (\\CHAR-BOUTS OTHER-STREAM (|fetch| CPPTR |of| OTHER-STREAM)
+                                   0
+                                   (|fetch| COFFSET |of| OTHER-STREAM)
+                                   NIL))
+
+              (* |;;| "WRITE HAPPENED.")
+
+              (|replace| CBUFSIZE |of| OTHER-STREAM |with| 512)
+              (|replace| CBUFMAXSIZE |of| OTHER-STREAM |with| 512)
+              (|replace| COFFSET |of| OTHER-STREAM |with| 0)
+              T)))))
+
+(\\TCP-GETNEXTBUFFER
+(LAMBDA (STREAM WHATFOR NOERRORFLG EOF-TEST) (* \; "Edited 20-Feb-90 12:43 by jds") (* |;;;| "Generic buffer refiller for Buffered character streams (e.g. TCP streams on Sun, or the Lisp side of a shell CHAT, eventually).") (PROG (ERRCODE (ERRNO (\\CREATECELL \\FIXP)) BUFFER) READ-LOOP (RETURN (SELECTQ WHATFOR (READ (* |;;| "READING; GET A FRESH BUFFER FULL OF UN-READ CHARACTERS.") (SETQ BUFFER (OR (FETCH (STREAM CPPTR) OF STREAM) (NCREATE (QUOTE VMEMPAGEP)))) (|replace| CPPTR |of| STREAM |with| BUFFER) (COND ((ZEROP (SETQ ERRCODE (TCP 6 (|fetch| (STREAM F1) |of| STREAM) BUFFER 512))) (AND (NULL NOERRORFLG) (\\EOF.ACTION STREAM)) NIL) ((EQ ERRCODE T) (AND EOF-TEST (RETURN T)) (BLOCK) (GO READ-LOOP)) (ERRCODE (* |;;| "Read succeeded, and ERRCODE has # of chars read.") (|replace| CPPTR |of| STREAM |with| BUFFER) (|replace| COFFSET |of| STREAM |with| 0) (|replace| CBUFSIZE |of| STREAM |with| ERRCODE) (|replace| CBUFMAXSIZE |of| STREAM |with| ERRCODE) T) ((NULL NOERRORFLG) (\\CHAR-ERROR ERRNO STREAM)))) (WRITE (COND ((NULL (FETCH CPPTR OF STREAM)) (* |;;| "No buffer allocated yet; create one.") (REPLACE CPPTR OF STREAM WITH (NCREATE (QUOTE VMEMPAGEP))) (REPLACE CBUFSIZE OF STREAM WITH 512) (REPLACE CBUFMAXSIZE OF STREAM WITH 512) (REPLACE COFFSET OF STREAM WITH 0) T) ((ZEROP (FETCH COFFSET OF STREAM)) T) ((SETQ ERRCODE (\\CHAR-BOUTS STREAM (FETCH CPPTR OF STREAM) 0 (FETCH COFFSET OF STREAM) NOERRORFLG)) (* |;;| "WRITE HAPPENED.") (REPLACE CBUFSIZE OF STREAM WITH 512) (REPLACE CBUFMAXSIZE OF STREAM WITH 512) (REPLACE COFFSET OF STREAM WITH 0) T))) (SHOULDNT)))))
+)
+
+(\\TCP-EOFP
+(LAMBDA (STREAM) (* \; "Edited 20-Feb-90 12:42 by jds") (* |;;| "T if there will be no more data on the stream") (AND (OR (NOT (|fetch| (STREAM CPPTR) |of| STREAM)) (IEQP (FETCH (STREAM COFFSET) OF STREAM) (FETCH (STREAM CBUFSIZE) OF STREAM))) (NOT (\\TCP-GETNEXTBUFFER STREAM (QUOTE READ) T T))))
+)
+
+(\\TCP-CLOSEFILE
+  (LAMBDA (STREAM)                                       (* \; "Edited 18-Dec-89 11:17 by jds")
+
+    (* |;;| "Close a TCP connection or listening-socket cleanly.")
+
+    (TCP 3 (|fetch| (STREAM F1) |of| STREAM))
+    STREAM))
+
+(\\TCP-EVENTFN
+  (LAMBDA (FDEV EVENT)                                   (* \; "Edited 30-Jan-90 13:56 by jds")
+    (SELECTQ EVENT
+        ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS BEFORESAVEVM) 
+                                                                (* |;;| 
+                              "Clean up existing connections, and remember any LISTENS in progress")
+
+             )
+        ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) 
+
+                                                  (* |;;| 
+"Try to reopen streams that had been open, and re-establish any LISTENs in progress when we exited.")
+
+             )
+        NIL)))
+
+(\\TCP.BUFFERED.BOUTS
+(LAMBDA (STREAM SBASE OFFSET NBYTES) (\\BUFFERED.BOUTS (FETCH F2 OF STREAM) SBASE OFFSET NBYTES)))
+)
+
+(\\TCP-DEV-INIT)
+
+
+
+(* |;;| "User-level TCP operations")
+
+(DEFINEQ
+
+(TCP
+(LAMBDA (A B C D E F G H I J K L M) (* \; "Edited  4-Apr-90 17:29 by jds") (* |;;| "Generic TCP-operation hider function.  Hides the fact of TCP ops being SUBRCALLs.") (* |;;| "Returns whatever result the TCP operation returns.") (SUBRCALL TCP A B C D E F G H I J K L M))
+)
+
+(OPENTCPSTREAM
+(LAMBDA (HOST PORT) (* \; "Edited  3-May-90 11:38 by jds") (LET ((ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (|replace| (STREAM ACCESS) |of| STREAM |with| (QUOTE BOTH)) (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (|replace| F2 |of| STREAM |with| (SETQ OTHER-STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ NIL USERVISIBLE _ NIL EOLCONVENTION _ LF.EOLC))) (COND ((SETQ IODESCRIPTOR (TCP 4 HOST PORT)) (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| IODESCRIPTOR) (|replace| (STREAM F1) |of| OTHER-STREAM |with| IODESCRIPTOR)) (T (\\CHAR-ERROR ERRNO HOST))) STREAM))
+)
+
+(TCP-ACCEPT
+(LAMBDA (WAITING-SOCKET) (* \; "Edited 22-May-90 10:18 by jhb") (LET ((ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM SOCKET) (|while| (OR (NOT SOCKET) (< SOCKET 0)) |do| (BLOCK) (SETQ SOCKET (TCP 8 WAITING-SOCKET))) (PRINTOUT *TRACE-OUTPUT* "SOCKET ACCEPTED " SOCKET T) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ (GETHOSTFROMSOCKET SOCKET) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (|replace| (STREAM ACCESS) |of| STREAM |with| (QUOTE BOTH)) (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (|replace| F2 |of| STREAM |with| (SETQ OTHER-STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ NIL USERVISIBLE _ NIL EOLCONVENTION _ LF.EOLC))) (COND (SOCKET (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| SOCKET) (|replace| (STREAM F1) |of| OTHER-STREAM |with| SOCKET)) (T (\\CHAR-ERROR ERRNO HOST))) STREAM))
+)
+
+(TCP-LISTEN
+(LAMBDA (SOCKET-NUMBER ACCEPT-FUNCTION ACCEPT-DATA) (* \; "Edited 22-May-90 10:54 by jhb") (LET ((SOCKET (TCP 7 SOCKET-NUMBER))) (SETQ \\MAIKO.IO-INTERRUPT-VECTOR (CONS (LIST (LLSH 1 SOCKET) ACCEPT-FUNCTION SOCKET ACCEPT-DATA) \\MAIKO.IO-INTERRUPT-VECTOR)) SOCKET))
+)
+
+(TCP-CLOSE
+(LAMBDA (DESCRIPTOR-NUMBER) (* \; "Edited  4-Apr-90 14:51 by jds") (LET ((ACCEPTOR (ASSOC (LLSH 1 DESCRIPTOR-NUMBER) \\MAIKO.IO-INTERRUPT-VECTOR))) (TCP 3 DESCRIPTOR-NUMBER) (* \; "Close the TCP connection") (DREMOVE ACCEPTOR \\MAIKO.IO-INTERRUPT-VECTOR) (* \; "REmove any acceptor.") DESCRIPTOR-NUMBER))
+)
+)
+(DEFINEQ
+
+(UDP-LISTEN
+(LAMBDA (SOCKET-NUMBER ACCEPT-FUNCTION ACCEPT-INFO) (* \; "Edited  4-Apr-90 15:49 by jds") (* |;;| "Listen on a particular UDP socket for incoming packet traffic.  Also has the effect of opening the socket for outgoing traffic.") (LET ((SOCKET (TCP 128 SOCKET-NUMBER))) (SETQ \\MAIKO.IO-INTERRUPT-VECTOR (CONS (LIST (LLSH 1 SOCKET) ACCEPT-FUNCTION SOCKET ACCEPT-INFO) \\MAIKO.IO-INTERRUPT-VECTOR)) SOCKET))
+)
+
+(UDP-SEND
+(LAMBDA (SOCKET BUFFER LEN ADDR PORT) (TCP 130 SOCKET ADDR PORT BUFFER LEN)))
+
+(UDP-RECV
+(LAMBDA (SOCKET) (* \; "Edited  3-May-90 11:40 by jds") (* |;;| "Xall recvfrom() to get an incoming packet on a UDP socket.") (* |;;| "Returns 4 results:") (* |;;| "   The 1500-byte buffer containing the packet") (* |;;| "   The length of the incoming packet") (* |;;| "   The address of the guy who sent it") (* |;;| "   The port to answer him on (or where he sent it from)") (LET ((BUFFER (NCREATE (QUOTE VMEMPAGEP))) LEN (ADDR (\\CREATECELL \\FIXP)) (PORT (\\CREATECELL \\FIXP))) (SETQ LEN (TCP 131 SOCKET BUFFER 512 ADDR PORT)) (CL:VALUES BUFFER LEN ADDR PORT)))
+)
+)
+(DEFINEQ
+
+(GETHOSTFROMNAME
+  (LAMBDA (NAME)                                         (* \; "Edited  1-Feb-90 11:26 by jds")
+
+    (* |;;| 
+  "Given a host name, return the IP address for that host.  If the host isn't found, return NIL.")
+
+    (TCP 0 NAME)))
+
+(GETHOSTFROMADDR
+(LAMBDA (ADDR) (* \; "Edited  6-Apr-90 20:23 by jds") (* |;;| "Given a host's IP address, return the string name of the host, or NIL if it can't be found.") (LET* ((BUF (\\ALLOCBLOCK 100 NIL)) (LEN (TCP 66 ADDR BUF))) (COND ((ZEROP LEN) NIL) (T (\\GETBASESTRING BUF 0 LEN)))))
+)
+
+(GETHOSTFROMSOCKET
+  (LAMBDA (SOCKET)                                       (* \; "Edited  1-Feb-90 11:30 by jds")
+
+    (* |;;| "Given the socket FD of a TCP connection, return the NAME of the remote host, or NIL if it can't be found.")
+
+    (LET* ((BUF (\\ALLOCBLOCK 100 NIL))
+           (LEN (TCP 65 SOCKET BUF)))
+          (COND
+             ((ZEROP LEN)
+              NIL)
+             (T (CONCATLIST (FOR I FROM 0 TO (SUB1 LEN) COLLECT (\\GETBASEBYTE BUF I)
+                                   )))))))
+
+(GETHOSTNAME
+(LAMBDA NIL (* \; "Edited  6-Apr-90 20:25 by jds") (* |;;| "Given a host's IP address, return the string name of the host, or NIL if it can't be found.") (LET* ((BUF (\\ALLOCBLOCK 100 NIL)) (LEN (TCP 67 BUF))) (COND ((ZEROP LEN) NIL) (T (\\GETBASESTRING BUF 0 LEN)))))
+)
+)
+(DECLARE\: EVAL@LOAD DONTCOPY 
+
+
+
+(* |;;| "Debugging functions &c")
+
+
+(RPAQ BUFFER (\\ALLOCBLOCK 100))
+(DEFINEQ
+
+(TCPRECV
+  (LAMBDA (PORT)
+    (LET ((LEN (TCP 6 PORT BUFFER 100)))
+         (|for| I |from| 0 |to| (SUB1 LEN) |do| (PRIN1 (CHARACTER (\\GETBASEBYTE
+                                                                                   BUFFER I))))
+         (TERPRI))))
+
+(TCPSEND
+  (LAMBDA (PORT BASE LEN)                                (* \; "Edited 15-Dec-89 15:13 by jds")
+    (TCP 5 PORT BASE OFFSET LEN)))
+
+(SEEBUFFER
+(LAMBDA (BUF) (|for| I |from| 0 |to| 11 |do| (PRIN1 (CHARACTER (\\GETBASEBYTE BUF I))))))
+
+(FOON
+(LAMBDA (INFO) (* \; "Edited  4-Apr-90 17:35 by jds") (LET ((RES (CL:MULTIPLE-VALUE-LIST (UDP-RECV (CADDR INFO))))) (AND (CADR RES) (SETQ RESULT RES))))
+)
+)
+)
+(PUTPROPS TCPOPS COPYRIGHT ("Savoir, Inc." 1989 1990))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (1081 8055 (\\TCP-DEV-INIT 1091 . 1918) (\\TCP-OPENFILE 1920 . 3557) (\\TCP-FORCEOUTPUT 
+3559 . 5060) (\\TCP-GETNEXTBUFFER 5062 . 6672) (\\TCP-EOFP 6674 . 6989) (\\TCP-CLOSEFILE 6991 . 7259) 
+(\\TCP-EVENTFN 7261 . 7927) (\\TCP.BUFFERED.BOUTS 7929 . 8053)) (8119 11214 (TCP 8129 . 8411) (
+OPENTCPSTREAM 8413 . 9441) (TCP-ACCEPT 9443 . 10604) (TCP-LISTEN 10606 . 10889) (TCP-CLOSE 10891 . 
+11212)) (11215 12328 (UDP-LISTEN 11225 . 11649) (UDP-SEND 11651 . 11742) (UDP-RECV 11744 . 12326)) (
+12329 13743 (GETHOSTFROMNAME 12339 . 12608) (GETHOSTFROMADDR 12610 . 12909) (GETHOSTFROMSOCKET 12911
+ . 13452) (GETHOSTNAME 13454 . 13741)) (13851 14580 (TCPRECV 13861 . 14149) (TCPSEND 14151 . 14306) (
+SEEBUFFER 14308 . 14412) (FOON 14414 . 14578)))))
+STOP
diff --git a/obsolete/tcp/TCPTFTP b/obsolete/tcp/TCPTFTP
new file mode 100644
index 00000000..9f1b3327
--- /dev/null
+++ b/obsolete/tcp/TCPTFTP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 17:44:14" {DSK}<usr>local>lde>lispcore>library>TCPTFTP.;2 53424  

      changes to%:  (VARS TCPTFTPCOMS)

      previous date%: " 1-Jul-87 10:52:03" {DSK}<usr>local>lde>lispcore>library>TCPTFTP.;1)


(* ; "
Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPTFTPCOMS)

(RPAQQ TCPTFTPCOMS
       ((COMS 
              (* ;; "Trivial File Transfer Protocol")

              (INITVARS (\TFTP.DEVICE)
                     (TFTP.MAXRETRIES 20))
              (GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES)
              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS TFTPCON TFTP TFTPSTREAM)
                                                      (CONSTANTS (\TFTPOVLEN 4)
                                                             (\TFTP.SOCKET 69))
                                                      (CONSTANTS * TFTPOPCODES)))
              (INITVARS (TFTP.MAXRETRIES 20))
              (FNS \TFTP.ACKNOWLEDGE \TFTP.CLOSEFILE \TFTP.EOFP \TFTP.ERROR \TFTP.GETNEXTBUFFER 
                   \TFTP.INIT \TFTP.INPUT.BUFFER \TFTP.OPENFILE \TFTP.READP \TFTP.SEND.ERROR 
                   \TFTP.SETUP)
              (FILES (SYSLOAD)
                     TCPUDP))
        (COMS 
              (* ;; "TFTP Server functions")

              (INITVARS (\TFTP.SERVER.CONNECTIONS))
              (GLOBALVARS \TFTP.SERVER.CONNECTIONS)
              (FNS TFTP.SERVER.PROCESS \TFTP.GET.FILE \TFTP.SEND.FILE))
        (COMS 
              (* ;; "User functions")

              (FNS TFTP.SERVER TFTP.GET TFTP.PUT))
        (COMS 
              (* ;; "Tracing functions")

              (FNS PRINTTFTP \TFTP.PRINT.ACK \TFTP.PRINT.DATA \TFTP.PRINT.ERROR \TFTP.PRINT.REQUEST))
        (P (\TFTP.INIT))))



(* ;; "Trivial File Transfer Protocol")


(RPAQ? \TFTP.DEVICE )

(RPAQ? TFTP.MAXRETRIES 20)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES)
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST))

(ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM)))
                    (BLOCKRECORD TFTPBASE ((OPCODE WORD)
                                           (BLOCK# WORD)))
                    [ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS)
                                                                of DATUM)
                                                          (FOLDHI \TFTPOVLEN BYTESPERWORD]
                    (BLOCKRECORD TFTPBASE ((NIL WORD)
                                           (ERRORCODE WORD))))

(ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM)
                                  (replace (STREAM F1) of DATUM with NEWVALUE))
                           (LASTPACKETIN (fetch (STREAM F2) of DATUM)
                                  (replace (STREAM F2) of DATUM with NEWVALUE))))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TFTPOVLEN 4)

(RPAQQ \TFTP.SOCKET 69)


(CONSTANTS (\TFTPOVLEN 4)
       (\TFTP.SOCKET 69))
)

(RPAQQ TFTPOPCODES ((\TFTP.RRQ 1)
                        (\TFTP.WRQ 2)
                        (\TFTP.DATA 3)
                        (\TFTP.ACK 4)
                        (\TFTP.ERROR 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TFTP.RRQ 1)

(RPAQQ \TFTP.WRQ 2)

(RPAQQ \TFTP.DATA 3)

(RPAQQ \TFTP.ACK 4)

(RPAQQ \TFTP.ERROR 5)


(CONSTANTS (\TFTP.RRQ 1)
       (\TFTP.WRQ 2)
       (\TFTP.DATA 3)
       (\TFTP.ACK 4)
       (\TFTP.ERROR 5))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? TFTP.MAXRETRIES 20)
(DEFINEQ

(\TFTP.ACKNOWLEDGE
  [LAMBDA (STREAM ACK#)                                      (* MPL " 2-Jun-85 17:07")
    (LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM))
          (ACK (\ALLOCATE.ETHERPACKET)))
         (\TFTP.SETUP ACK TFTPCON \TFTP.ACK 'FREE)
         (UDP.APPEND.WORD ACK ACK#)
         (UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                ACK)
         (BLOCK)
         (COND
            ((AND (EQ (fetch (STREAM ACCESS) of STREAM)
                      'INPUT)
                  (fetch (TFTPSTREAM LASTPACKETIN) of STREAM))
             (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON])

(\TFTP.CLOSEFILE
  [LAMBDA (STREAM)                                           (* ejs%: " 9-Feb-85 23:47")
    (LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM)))
         (SELECTQ (fetch (STREAM ACCESS) of STREAM)
             (OUTPUT [COND
                        ((AND (fetch (STREAM CBUFPTR) of STREAM)
                              (NOT (fetch (TFTPSTREAM LASTPACKETIN) of STREAM)))
                         (\TFTP.GETNEXTBUFFER STREAM 'WRITE])
             NIL)
         (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                T)
         (replace (STREAM ACCESS) of STREAM with NIL)
         STREAM])

(\TFTP.EOFP
  [LAMBDA (STREAM)                                           (* ejs%: " 9-Feb-85 21:23")
    (OR (NULL (fetch (STREAM CBUFPTR) of STREAM))
        (AND (fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
             (EQ (fetch (STREAM COFFSET) of STREAM)
                 (fetch (STREAM CBUFSIZE) of STREAM])

(\TFTP.ERROR
  [LAMBDA (TFTP TFTPCON)                                     (* ejs%: " 9-Feb-85 19:04")
          
          (* * Called upon receipt of error packet in TFTP stream)

    (LET [(ERRORSTRING (ALLOCSTRING (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
                                           (CONSTANT (IPLUS \UDPOVLEN (ADD1 \TFTPOVLEN]
         (\MOVEBYTES (fetch (TFTP TFTPCONTENTS) of TFTP)
                0
                (fetch (STRINGP BASE) of ERRORSTRING)
                (fetch (STRINGP OFFST) of ERRORSTRING)
                (fetch (STRINGP LENGTH) of ERRORSTRING))
         (ERROR (CONCAT "TFTP error message: " ERRORSTRING " for code")
                (fetch (TFTP ERRORCODE) of TFTP])

(\TFTP.GETNEXTBUFFER
  [LAMBDA (STREAM WHATFOR NOERRORFLG)                        (* MPL " 2-Jun-85 19:48")
    (DECLARE (GLOBALVARS TFTP.MAXRETRIES))
    (LET*
     ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM))
      (IPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
      (RETRYCOUNT 0)
      (BUFFER (fetch (STREAM CBUFPTR) of STREAM))
      UDP)
     (SELECTQ WHATFOR
         (READ [COND
                  [(fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
                   (replace (STREAM ACCESS) of STREAM with NIL)
                   (\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM))
                   (replace (STREAM CBUFPTR) of STREAM with NIL)
                   (COND
                      (NOERRORFLG NIL)
                      (T (\EOF.ACTION STREAM]
                  (T (PROG [(NEXT# (COND
                                      (BUFFER (ADD1 (fetch (TFTP BLOCK#) of BUFFER)))
                                      (T 1]
                       LP  [for I from 1 to TFTP.MAXRETRIES until UDP
                              do (SETQ UDP (UDP.GET IPSOCKET \ETHERTIMEOUT))
                                 (COND
                                    ((NOT UDP)
                                     (\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#]
                           (COND
                              [UDP (COND
                                      [(EQ (fetch (TFTP OPCODE) of UDP)
                                           \TFTP.DATA)
                                       (COND
                                          ((IEQP (fetch (TFTP BLOCK#) of UDP)
                                                 NEXT#)
                                           (\TFTP.INPUT.BUFFER STREAM UDP)
                                           (\TFTP.ACKNOWLEDGE STREAM NEXT#)
                                           (RETURN T))
                                          [(ILESSP (fetch (TFTP BLOCK#) of UDP)
                                                  NEXT#)
                                           [COND
                                              (IPTRACEFLG (COND
                                                             ((EQ IPTRACEFLG T)
                                                              (printout IPTRACEFILE 
                                                                     "Retransmitting ACK for block "
                                                                     (SUB1 NEXT#)
                                                                     T))
                                                             (T (PRIN1 "R" IPTRACEFILE]
                                           (\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#))
                                           (\RELEASE.ETHERPACKET UDP)
                                           (SETQ UDP NIL)
                                           (COND
                                              ((EQ (add RETRYCOUNT 1)
                                                   TFTP.MAXRETRIES)
                                               (\TFTP.SEND.ERROR TFTPCON 0 
                                                      "Timeout awaiting next data packet; aborting")
                                               (replace (STREAM STRMBINFN) of STREAM
                                                  with (FUNCTION \STREAM.NOT.OPEN))
                                               (ERROR "Timeout awaiting next data packet; aborting" 
                                                      STREAM))
                                              (T (GO LP]
                                          (T (\TFTP.SEND.ERROR TFTPCON 0 
                                                    "Protocol error: Block # too high.  Aborting...")
                                             (replace (STREAM STRMBINFN) of STREAM
                                                with (FUNCTION \STREAM.NOT.OPEN))
                                             (ERROR "Protocol error: Block # too high.  Aborting..." 
                                                    STREAM]
                                      ((EQ (fetch (TFTP OPCODE) of UDP)
                                           \TFTP.ERROR)
                                       (replace (STREAM STRMBINFN) of STREAM
                                          with (FUNCTION STREAM.NOT.OPEN))
                                       (\TFTP.ERROR UDP TFTPCON))
                                      (T [\TFTP.SEND.ERROR TFTPCON 0
                                                (CONCAT 
                                        "Protocol error: Illegal TFTP opcode, expected DATA but got "
                                                       (SELECTC (fetch (TFTP OPCODE) of UDP)
                                                           (\TFTP.RRQ "read request.")
                                                           (\TFTP.WRQ "write request.")
                                                           (\TFTP.ACK "ack.")
                                                           (CONCAT "unknown type "
                                                                  (fetch (TFTP OPCODE) of UDP)
                                                                  "."]
                                         (replace (STREAM STRMBINFN) of STREAM
                                            with (FUNCTION \STREAM.NOT.OPEN))
                                         (ERROR "Illegal TFTP opcode rec'd" STREAM]
                              (T (\TFTP.SEND.ERROR TFTPCON 0 
                                        "Timeout awaiting next data packet; aborting")
                                 (replace (STREAM STRMBINFN) of STREAM with (FUNCTION 
                                                                             \STREAM.NOT.OPEN))
                                 (ERROR "Timeout awaiting next data packet; aborting" STREAM])
         (WRITE [COND
                   [(fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
                    (replace (STREAM ACCESS) of STREAM with NIL)
                    (COND
                       (NOERRORFLG NIL)
                       (T (\EOF.ACTION STREAM]
                   (T (PROG (ACK# NBYTES)
                            (SETQ ACK# (fetch (TFTP BLOCK#) of BUFFER))
                            (SETQ NBYTES (IDIFFERENCE (fetch (STREAM COFFSET) of STREAM)
                                                (UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP 
                                                                                         TFTPCONTENTS
                                                                                          )
                                                                                of BUFFER))
                                                               (\LOLOC BUFFER))
                                                       BYTESPERWORD)))
                            [replace (IP IPTOTALLENGTH) of BUFFER
                               with (IPLUS NBYTES (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN \IPOVLEN]
                            [replace (UDP UDPLENGTH) of BUFFER with (IPLUS NBYTES
                                                                           (CONSTANT (IPLUS \UDPOVLEN 
                                                                                           \TFTPOVLEN
                                                                                            ]
                            (COND
                               ((ILESSP NBYTES 512)
                                (replace (TFTPSTREAM LASTPACKETIN) of STREAM with T)))
                        LP  (for I from 1 to TFTP.MAXRETRIES until UDP
                               do (SETQ UDP (UDP.EXCHANGE IPSOCKET BUFFER)))
                            (COND
                               [(AND UDP (EQ (fetch (TFTP OPCODE) of UDP)
                                             \TFTP.ACK))
                                (COND
                                   ((EQ (fetch (TFTP BLOCK#) of UDP)
                                        ACK#)
                                    [COND
                                       ((EQ NBYTES 512)
                                        (\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL)
                                        (UDP.APPEND.WORD UDP (ADD1 ACK#))
                                        (replace (UDP UDPLENGTH) of UDP
                                           with (CONSTANT (IPLUS 512 \UDPOVLEN \TFTPOVLEN)))
                                        (\TFTP.INPUT.BUFFER STREAM UDP))
                                       (T (replace (STREAM CBUFPTR) of STREAM with NIL)
                                          (replace (STREAM ACCESS) of STREAM with NIL)
                                          (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON]
                                    (RETURN T))
                                   [(ILESSP (fetch (TFTP BLOCK#) of UDP)
                                           ACK#)
                                    [COND
                                       (IPTRACEFLG (COND
                                                      ((EQ IPTRACEFLG T)
                                                       (printout IPTRACEFILE 
                                                              "TFTP retransmission on block# " ACK# T
                                                              ))
                                                      (T (PRIN1 "R" IPTRACEFILE]
                                    (\RELEASE.ETHERPACKET UDP)
                                    (SETQ UDP NIL)
                                    (COND
                                       [(EQ (add RETRYCOUNT 1)
                                            TFTP.MAXRETRIES)
                                        (\TFTP.SEND.ERROR TFTPCON 0 
                                               "Timeout awaiting acknowledgement.  Aborting...")
                                        (replace (STREAM STRMBOUTFN) of STREAM
                                           with (FUNCTION \STREAM.NOT.OPEN))
                                        (COND
                                           (NOERRORFLG NIL)
                                           (T (\EOF.ACTION STREAM]
                                       (T (GO LP]
                                   (T (\TFTP.SEND.ERROR TFTPCON 0 
                                             "Protocol error: Block # too high.  Aborting...")
                                      (replace (STREAM STRMBOUTFN) of STREAM
                                         with (FUNCTION \STREAM.NOT.OPEN))
                                      (COND
                                         (NOERRORFLG NIL)
                                         (T (\EOF.ACTION STREAM]
                               ((AND UDP (EQ (fetch (TFTP OPCODE) of UDP)
                                             \TFTP.ERROR))
                                (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION 
                                                                             \STREAM.NOT.OPEN))
                                (\TFTP.ERROR UDP TFTPCON))
                               [UDP [\TFTP.SEND.ERROR TFTPCON 0
                                           (CONCAT 
                                         "Protocol error: Illegal TFTP opcode, expected ACK but got "
                                                  (SELECTC (fetch (TFTP OPCODE) of UDP)
                                                      (\TFTP.RRQ "read request.")
                                                      (\TFTP.WRQ "write request.")
                                                      (\TFTP.DATA "data.")
                                                      (CONCAT "unknown type " (fetch (TFTP OPCODE)
                                                                                 of UDP)
                                                             "."]
                                    (replace (STREAM STRMBOUTFN) of STREAM
                                       with (FUNCTION \STREAM.NOT.OPEN))
                                    (COND
                                       (NOERRORFLG NIL)
                                       (T (\EOF.ACTION STREAM]
                               (T (\TFTP.SEND.ERROR TFTPCON 0 "Protocol error, aborting...")
                                  (replace (STREAM STRMBOUTFN) of STREAM
                                     with (FUNCTION \STREAM.NOT.OPEN))
                                  (COND
                                     (NOERRORFLG NIL)
                                     (T (\EOF.ACTION STREAM])
         (ERROR "Illegal ACCESS" WHATFOR])

(\TFTP.INIT
  [LAMBDA NIL                                                (* ejs%: " 2-Feb-86 12:00")
    (DECLARE (GLOBALVARS \TFTP.DEVICE))
    (OR \TFTP.DEVICE
        (\DEFINEDEVICE NIL
               (SETQ \TFTP.DEVICE
                (create FDEV
                       FDBINABLE _ T
                       FDBOUTABLE _ T
                       NODIRECTORIES _ T
                       RESETABLE _ NIL
                       RANDOMACCESSP _ NIL
                       BUFFERED _ T
                       PAGEMAPPED _ NIL
                       DEVICENAME _ 'TFTP
                       HOSTNAMEP _ (FUNCTION NILL)
                       EVENTFN _ (FUNCTION NILL)
                       FORCEOUTPUT _ (FUNCTION NILL)
                       BIN _ (FUNCTION \BUFFERED.BIN)
                       BOUT _ (FUNCTION \BUFFERED.BOUT)
                       GETNEXTBUFFER _ (FUNCTION \TFTP.GETNEXTBUFFER)
                       READP _ (FUNCTION \TFTP.READP)
                       EOFP _ (FUNCTION \TFTP.EOFP)
                       CLOSEFILE _ (FUNCTION \TFTP.CLOSEFILE])

(\TFTP.INPUT.BUFFER
  [LAMBDA (STREAM UDP)                                       (* ejs%: " 9-Feb-85 20:51")
          
          (* * Sets up the fields of the stream necessary to support buffered operation, 
          with UDP as the next packet)

    (LET [(OFFSET (UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP TFTPCONTENTS) of UDP))
                                 (\LOLOC UDP))
                         BYTESPERWORD))
          (LENGTH (IDIFFERENCE (fetch (UDP UDPLENGTH) of UDP)
                         (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN]
         [COND
            ((type? ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM))
             (\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM]
         (replace (STREAM CBUFPTR) of STREAM with UDP)
         (replace (STREAM COFFSET) of STREAM with OFFSET)
         (replace (STREAM CBUFSIZE) of STREAM with (replace (STREAM CBUFMAXSIZE) of STREAM
                                                      with (IPLUS OFFSET LENGTH)))
         (COND
            ((ILESSP LENGTH 512)
             (replace (TFTPSTREAM LASTPACKETIN) of STREAM with T])

(\TFTP.OPENFILE
  [LAMBDA (FILENAME ACCESS RECOG PARAMETERS)                 (* ejs%: "15-Sep-85 17:48")
          
          (* * Open a file using TFTP)

    (LET* ((HOSTNAME (FILENAMEFIELD FILENAME 'HOST))
           [DEVICE (COND
                      ((DODIP.HOSTP HOSTNAME)
                       (create FDEV using \TFTP.DEVICE DEVICENAME _ HOSTNAME))
                      (T (ERROR "Unknown IP host: " HOSTNAME]
           (STREAM (create STREAM
                          DEVICE _ DEVICE))
           [TFTPCON (replace (FDEV DEVICEINFO) of DEVICE with (create TFTPCON
                                                                     UDPSOCKET _ (UDP.OPEN.SOCKET)
                                                                     STREAM _ STREAM
                                                                     HOST _ (DODIP.HOSTP HOSTNAME]
           (UDP (\ALLOCATE.ETHERPACKET))
           UDPIN)
          (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET)
                                                     (AND RESETSTATE (UDP.CLOSE.SOCKET SOCKET T]
                                         (fetch (TFTPCON UDPSOCKET) of TFTPCON)))
                 (replace (TFTPCON DESTSOCKET) of TFTPCON with \TFTP.SOCKET)
                 (\TFTP.SETUP UDP TFTPCON (SELECTQ ACCESS
                                              (INPUT \TFTP.RRQ)
                                              (OUTPUT \TFTP.WRQ)
                                              (ERROR "ACCESS must be INPUT or OUTPUT" ACCESS)))
                 (UDP.APPEND.STRING UDP (SUBATOM FILENAME (STRPOS '} FILENAME NIL NIL NIL T)))
                 (UDP.APPEND.BYTE UDP 0)
                 (UDP.APPEND.STRING UDP (COND
                                           ((EQ (CADR (FASSOC 'TYPE PARAMETERS))
                                                'BINARY)
                                            "OCTET")
                                           (T "NETASCII")))
                 (UDP.APPEND.BYTE UDP 0)
                 (for I from 1 to \MAXETHERTRIES do (SETQ UDPIN (UDP.EXCHANGE (fetch (TFTPCON 
                                                                                            UDPSOCKET
                                                                                            )
                                                                                 of TFTPCON)
                                                                       UDP)) until UDPIN
                    finally (\RELEASE.ETHERPACKET UDP))
                 (COND
                    [UDPIN (SELECTC (fetch (TFTP OPCODE) of UDPIN)
                               (\TFTP.ACK (COND
                                             ((AND (EQ ACCESS 'OUTPUT)
                                                   (EQ (fetch (TFTP BLOCK#) of UDPIN)
                                                       0))
                                              (replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON)
                                              (replace (STREAM ACCESS) of STREAM with ACCESS)
                                              (replace (STREAM FULLFILENAME) of STREAM with FILENAME)
                                              (replace (TFTPCON DESTSOCKET) of TFTPCON
                                                 with (fetch (UDP UDPSOURCEPORT) of UDPIN))
                                              (\TFTP.SETUP UDPIN TFTPCON \TFTP.DATA NIL)
                                              (UDP.APPEND.WORD UDPIN 1)
                                              (add (fetch (UDP UDPLENGTH) of UDPIN)
                                                   512)
                                              (\TFTP.INPUT.BUFFER STREAM UDPIN)
                                              STREAM)))
                               (\TFTP.DATA (COND
                                              ((AND (EQ ACCESS 'INPUT)
                                                    (EQ (fetch (TFTP BLOCK#) of UDPIN)
                                                        1))
                                               (replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON)
                                               (replace (STREAM ACCESS) of STREAM with ACCESS)
                                               (replace (STREAM FULLFILENAME) of STREAM with FILENAME
                                                      )
                                               (replace (TFTPCON DESTSOCKET) of TFTPCON
                                                  with (fetch (UDP UDPSOURCEPORT) of UDPIN))
                                               (\TFTP.INPUT.BUFFER STREAM UDPIN)
                                               (\TFTP.ACKNOWLEDGE STREAM 1)
                                               STREAM)))
                               (\TFTP.ERROR (\TFTP.ERROR UDPIN))
                               (ERROR "Unknown TFTP opcode" (fetch (TFTP OPCODE) of UDPIN]
                    (T (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                              T)
                       NIL])

(\TFTP.READP
  [LAMBDA (STREAM)                                           (* ejs%: " 9-Feb-85 20:48")
    (ILESSP (fetch (STREAM COFFSET) of STREAM)
           (fetch (STREAM CBUFSIZE) of STREAM])

(\TFTP.SEND.ERROR
  [LAMBDA (TFTPCON ERRORCODE ERRORSTRING)                    (* ejs%: " 1-Jun-85 15:34")
          
          (* * Send an error back to the requestor)

    (LET ((TFTP (\ALLOCATE.ETHERPACKET)))
         (\TFTP.SETUP TFTP TFTPCON \TFTP.ERROR NIL)
         (UDP.APPEND.WORD TFTP ERRORCODE)
         (UDP.APPEND.STRING TFTP ERRORSTRING)
         (UDP.APPEND.BYTE TFTP 0)
         (UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                TFTP])

(\TFTP.SETUP
  [LAMBDA (UDP TFTPCON OPCODE REQUEUE)                       (* ejs%: " 9-Feb-85 20:32")
    (UDP.SETUP UDP (fetch (TFTPCON HOST) of TFTPCON)
           (fetch (TFTPCON DESTSOCKET) of TFTPCON)
           0
           (fetch (TFTPCON UDPSOCKET) of TFTPCON))
    (replace EPREQUEUE of UDP with REQUEUE)
    (UDP.APPEND.WORD UDP OPCODE])
)

(FILESLOAD (SYSLOAD)
       TCPUDP)



(* ;; "TFTP Server functions")


(RPAQ? \TFTP.SERVER.CONNECTIONS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TFTP.SERVER.CONNECTIONS)
)
(DEFINEQ

(TFTP.SERVER.PROCESS
  [LAMBDA (LOGSTREAM)                                        (* ejs%: " 3-Jun-85 01:52")
          
          (* * A server for TFTP file transfer)

    (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
    (LET*
     ((DEVICE (create FDEV using \TFTP.DEVICE DEVICENAME _ 'TFTPSERVER))
      (SERVERSOCKET (UDP.OPEN.SOCKET \TFTP.SOCKET T))
      CONNECTION)
     [COND
        ((NULL LOGSTREAM)
         (COND
            ((NOT (HASTTYWINDOWP))
             (\CREATE.TTYDISPLAYSTREAM)))
         (SETQ LOGSTREAM (TTYDISPLAYSTREAM]
     (SETQ \TFTP.SERVER.CONNECTIONS NIL)
     (COND
        (SERVERSOCKET
         (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET)
                                                    (UDP.CLOSE.SOCKET SOCKET T]
                                        SERVERSOCKET))
                (while T
                   do (LET ((UDP (UDP.GET SERVERSOCKET T)))
                           (SETQ CONNECTION (CONS (fetch (IP IPSOURCEADDRESS) of UDP)
                                                  (fetch (UDP UDPSOURCEPORT) of UDP)))
                           (COND
                              [(NOT (MEMBER CONNECTION \TFTP.SERVER.CONNECTIONS))
                               (push \TFTP.SERVER.CONNECTIONS CONNECTION)
                               (SELECTC (fetch (TFTP OPCODE) of UDP)
                                   (\TFTP.RRQ (ADD.PROCESS `(\TFTP.SEND.FILE %, UDP
                                                                   (QUOTE %, (create TFTPCON 
                                                                                    UDPSOCKET _
                                                                                    (UDP.OPEN.SOCKET)
                                                                                    ))
                                                                   %, DEVICE %, LOGSTREAM)))
                                   (\TFTP.WRQ (ADD.PROCESS `(\TFTP.GET.FILE %, UDP
                                                                   (QUOTE %, (create TFTPCON 
                                                                                    UDPSOCKET _
                                                                                    (UDP.OPEN.SOCKET)
                                                                                    ))
                                                                   %, DEVICE %, LOGSTREAM)))
                                   (PROGN (printout LOGSTREAM "TFTP Server: Unexpected opcode "
                                                 (fetch (TFTP OPCODE) of UDP)
                                                 T)
                                          (SETQ \TFTP.SERVER.CONNECTIONS (DREMOVE CONNECTION 
                                                                             \TFTP.SERVER.CONNECTIONS
                                                                                ))
                                          (\RELEASE.ETHERPACKET UDP]
                              (T                             (* Duplicate request)
                                 (\RELEASE.ETHERPACKET UDP])

(\TFTP.GET.FILE
  [LAMBDA (UDP TFTPCON DEVICE LOGSTREAM)                     (* ; "Edited 14-Apr-87 20:19 by FS")
          
          (* ;; "Try to start receiving a file from the requestor as directed by the contents of the received UDP packet")

    (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
    (LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
                                                                                 of UDP)
                                                                       I))
                              finally (RETURN (IDIFFERENCE I BYTESPERWORD]
           (FILENAME (ALLOCSTRING FILENAMELENGTH))
           [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                          until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP)
                                             I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD 
                                                                                       FILENAMELENGTH 
                                                                                       1]
           (MODE (ALLOCSTRING MODELENGTH))
           (HOST (fetch (IP IPSOURCEADDRESS) of UDP))
           FILE TYPE TFTPSTREAM RESULT)
          (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON)
                                                     (LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET)
                                                                          of TFTPCON))
                                                            (CONNECTION (CONS (fetch (TFTPCON HOST)
                                                                                 of TFTPCON)
                                                                              (fetch (TFTPCON 
                                                                                           DESTSOCKET
                                                                                            )
                                                                                 of TFTPCON]
                                                           (SETQ \TFTP.SERVER.CONNECTIONS
                                                            (REMOVE CONNECTION 
                                                                   \TFTP.SERVER.CONNECTIONS))
                                                           (AND RESETSTATE (UDP.CLOSE.SOCKET 
                                                                                  UDPSOCKET T]
                                         TFTPCON))
                 (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT)
                                                                  of UDP))
                 (replace (TFTPCON HOST) of TFTPCON with HOST)
          
          (* ;; "Read the filename out of the packet")

                 (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                        BYTESPERWORD
                        (fetch (STRINGP BASE) of FILENAME)
                        (fetch (STRINGP OFFST) of FILENAME)
                        FILENAMELENGTH)
          
          (* ;; "Read the mode out of the packet")

                 (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                        (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                        (fetch (STRINGP BASE) of MODE)
                        (fetch (STRINGP OFFST) of MODE)
                        MODELENGTH)
                 (SETQ MODE (U-CASE MODE))
                 (printout LOGSTREAM "TFTP Server: Will attempt to receive " FILENAME " in " MODE 
                        " mode from host " (\IP.ADDRESS.TO.STRING HOST)
                        T)
                 (SETQ RESULT
                  (COND
                     [[AND (SETQ TYPE (COND
                                         ((STREQUAL MODE "NETASCII")
                                          'TEXT)
                                         ((STREQUAL MODE "OCTET")
                                          'BINARY)
                                         (T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT 
                                                                            "Unknown transfer type--" 
                                                                               MODE))
                                            NIL)))
                           (SETQ FILE (LET [(OUTSTREAM
                                             (CAR (NLSETQ (OPENSTREAM FILENAME 'OUTPUT 'NEW
                                                                 (LIST (LIST 'TYPE TYPE]
                                           (COND
                                              ((NULL OUTSTREAM)
                                               (\TFTP.SEND.ERROR TFTPCON 1 (CONCAT 
                                                                                  "Can't open file--" 
                                                                                  FILENAME))
                                               NIL)
                                              (T OUTSTREAM]
          
          (* ;; "Mode is OK, and file is open for input.  Open the TFTP stream back to the requestor")

                      (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FILE)
                                                       (COND
                                                          (RESETSTATE (CLOSEF? FILE)
                                                                 (DELFILE (FULLNAME FILE]
                                           FILE))
                      (SETQ TFTPSTREAM (create STREAM
                                              DEVICE _ DEVICE))
                      (replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM)
                      (replace (STREAM ACCESS) of TFTPSTREAM with 'INPUT)
                      (replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON)
          
          (* ;; "Send the first acknowledgement")

                      (\TFTP.ACKNOWLEDGE TFTPSTREAM 0)
                      (\RELEASE.ETHERPACKET UDP)
                      (printout LOGSTREAM "TFTP Server: receiving " (FULLNAME FILE)
                             T)
                      (COND
                         ((NLSETQ (COPYBYTES TFTPSTREAM FILE))
                          (printout LOGSTREAM "TFTP Server: Done receiving " (FULLNAME FILE)
                                 T)
                          (CLOSEF? FILE))
                         (T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE)
                                   T)
                            (DELFILE (FULLNAME (CLOSEF? FILE]
                     (T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE)
                               T)
                        (\RELEASE.ETHERPACKET UDP)
                        NIL)))
          
          (* ;; "Remove connection from list.")

                 (LET (UDPSOCKET CONNECTION)
                      (SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
                      (SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON)
                                             (fetch (UDP UDPDESTPORT) of UDPSOCKET)))
                      (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS)))
                 RESULT])

(\TFTP.SEND.FILE
  [LAMBDA (UDP TFTPCON DEVICE LOGSTREAM)                     (* ; "Edited 30-Jun-87 22:12 by scp")
          
          (* ;; "Try to start sending a file to the requestor as directed by the contents of the received UDP packet")

    (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
    (LET*
     ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
                                                                            of UDP)
                                                                  I))
                         finally (RETURN (IDIFFERENCE I BYTESPERWORD]
      (FILENAME (ALLOCSTRING FILENAMELENGTH))
      [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                     until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP)
                                        I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD 
                                                                                  FILENAMELENGTH 1]
      (MODE (ALLOCSTRING MODELENGTH))
      (HOST (fetch (IP IPSOURCEADDRESS) of UDP))
      FILE TYPE TFTPSTREAM RESULT)
     (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON)
                                                (LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET)
                                                                     of TFTPCON))
                                                       (CONNECTION (CONS (fetch (TFTPCON HOST)
                                                                            of TFTPCON)
                                                                         (fetch (TFTPCON DESTSOCKET)
                                                                            of TFTPCON]
                                                      (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE 
                                                                                           CONNECTION 
                                                                             \TFTP.SERVER.CONNECTIONS
                                                                                            ))
                                                      (AND RESETSTATE (UDP.CLOSE.SOCKET UDPSOCKET T]
                                    TFTPCON))
            (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT) of UDP))
            (replace (TFTPCON HOST) of TFTPCON with HOST)
          
          (* ;; "Read the filename out of the packet")

            (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                   BYTESPERWORD
                   (fetch (STRINGP BASE) of FILENAME)
                   (fetch (STRINGP OFFST) of FILENAME)
                   FILENAMELENGTH)
          
          (* ;; "Read the mode out of the packet")

            (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                   (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                   (fetch (STRINGP BASE) of MODE)
                   (fetch (STRINGP OFFST) of MODE)
                   MODELENGTH)
            (SETQ MODE (U-CASE MODE))
            (printout LOGSTREAM "TFTP Server: Will attempt to send " FILENAME " in " MODE 
                   " mode to host " (\IP.ADDRESS.TO.STRING HOST)
                   T)
            (SETQ RESULT
             (COND
                ([AND (SETQ TYPE (COND
                                    ((STREQUAL MODE "NETASCII")
                                     'TEXT)
                                    ((STREQUAL MODE "OCTET")
                                     'BINARY)
                                    (T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT "Unknown transfer type--" 
                                                                          MODE))
                                       NIL)))
                      (SETQ FILE
                       (LET* [(FULLFILENAME (INFILEP FILENAME))
                              (INSTREAM (AND FULLFILENAME
                                             (CAR (NLSETQ (OPENSTREAM FULLFILENAME 'INPUT
                                                                 'OLD
                                                                 (LIST (LIST 'TYPE TYPE]
                             (COND
                                ((NULL INSTREAM)
                                 (\TFTP.SEND.ERROR TFTPCON 1 (CONCAT "Can't open file--" FILENAME))
                                 NIL)
                                (T INSTREAM]
          
          (* ;; "Mode is OK, and file is open for input.  Open the TFTP stream back to the requestor")

                 (SETQ TFTPSTREAM (create STREAM
                                         DEVICE _ DEVICE))
                 (replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM)
                 (replace (STREAM ACCESS) of TFTPSTREAM with 'OUTPUT)
                 (replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON)
          
          (* ;; "Use the incoming packet as the first data packet on the way out")

                 (\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL)
          
          (* ;; "This is block number 1")

                 (UDP.APPEND.WORD UDP 1)
                 (add (fetch (UDP UDPLENGTH) of UDP)
                      512)
                 (\TFTP.INPUT.BUFFER TFTPSTREAM UDP)
                 (printout LOGSTREAM "TFTP Server: Sending " FILENAME T)
                 (COND
                    ((NLSETQ (PROGN (COPYBYTES FILE TFTPSTREAM)
                                    (\TFTP.GETNEXTBUFFER TFTPSTREAM 'WRITE T)
                                    (\TFTP.CLOSEFILE TFTPSTREAM)))
                     (printout LOGSTREAM "TFTP Server: Done sending " FILENAME T))
                    (T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T)))
                 (CLOSEF? FILE))
                (T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T)
                   (\RELEASE.ETHERPACKET UDP)
                   NIL)))
          
          (* ;; "Remove connection from list.")

            (LET (UDPSOCKET CONNECTION)
                 (SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
                 (SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON)
                                        (fetch (UDP UDPDESTPORT) of UDPSOCKET)))
                 (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS)))
            RESULT])
)



(* ;; "User functions")

(DEFINEQ

(TFTP.SERVER
  [LAMBDA (LOGSTREAM)                                        (* MPL " 2-Jun-85 19:39")
          
          (* * Create a new TFTP server. LOGSTREAM defaults to a popup window)

    (ADD.PROCESS `(TFTP.SERVER.PROCESS %, LOGSTREAM) 'RESTARTABLE 'HARDRESET])

(TFTP.GET
  [LAMBDA (FROM TO PARAMETERS)                               (* MPL " 2-Jun-85 17:15")
    (LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS)))
          (TYPE (FASSOC 'TYPE PARAMETERS))
          (FROMNAME FROM)
          (TONAME TO))
         (RESETLST [SETQ TO (OPENSTREAM TO 'OUTPUT 'NEW NIL (COND
                                                               (TYPE (LIST TYPE]
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (COND
                                                    ((AND STREAM RESETSTATE)
                                                     (CLOSEF? STREAM)
                                                     (DELFILE (FULLNAME STREAM]
                                     TO))
                (SETQ FROM (\TFTP.OPENFILE FROM 'INPUT 'OLD PARAMETERS))
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (AND STREAM RESETSTATE (CLOSEF STREAM]
                                     FROM))
                (COND
                   (EOLCONVENTION (replace (STREAM EOLCONVENTION) of FROM with EOLCONVENTION)))
                (COND
                   ((AND FROM TO)
                    (COPYCHARS FROM TO)
                    (AND (OPENP FROM)
                         (CLOSEF FROM))
                    (FULLNAME (CLOSEF TO)))
                   (TO (ERRORX (LIST 9 FROMNAME)))
                   (FROM (ERRORX (LIST 9 TONAME])

(TFTP.PUT
  [LAMBDA (FROM TO PARAMETERS)                               (* ; "Edited 15-Apr-87 20:55 by FS")
    (LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS)))
          (TYPE (FASSOC 'TYPE PARAMETERS)))
          
          (* ;; "Why is TYPE not used anywhere?")

         (RESETLST (SETQ FROM (OPENSTREAM FROM 'INPUT 'OLD))
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (AND RESETSTATE (CLOSEF STREAM]
                                     FROM))
                (SETQ TO (\TFTP.OPENFILE TO 'OUTPUT 'NEW PARAMETERS))
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (AND RESETSTATE (CLOSEF STREAM]
                                     TO))
                (COND
                   (EOLCONVENTION (replace (STREAM EOLCONVENTION) of TO with EOLCONVENTION)))
                (COPYCHARS FROM TO)
                (CLOSEF FROM)
          
          (* ;; "Removed (FULLNAME (CLOSEF TO))")

                (CLOSEF TO])
)



(* ;; "Tracing functions")

(DEFINEQ

(PRINTTFTP
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 14:00")
    (DECLARE (GLOBALVARS TFTPOPCODES))
    (PRINTCONSTANT (fetch (TFTP OPCODE) of TFTP)
           TFTPOPCODES FILE "TFTP Opcode: ")
    (SELECTC (fetch (TFTP OPCODE) of TFTP)
        (\TFTP.RRQ (printout FILE " ")
                   (\TFTP.PRINT.REQUEST TFTP FILE))
        (\TFTP.WRQ (printout FILE " ")
                   (\TFTP.PRINT.REQUEST TFTP FILE))
        (\TFTP.ACK (printout FILE " ")
                   (\TFTP.PRINT.ACK TFTP FILE))
        (\TFTP.DATA (printout FILE " ")
                    (\TFTP.PRINT.DATA TFTP FILE))
        (\TFTP.ERROR (printout FILE " ")
                     (\TFTP.PRINT.ERROR TFTP FILE))
        NIL)
    (TERPRI FILE)
    (TERPRI FILE])

(\TFTP.PRINT.ACK
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 12:48")
    (printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP)
           T])

(\TFTP.PRINT.DATA
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 14:00")
    (printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP)
           T)
    (PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP)
           \TFTPOVLEN
           '(CHARS 12 |...|)
           (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
                  (CONSTANT (IPLUS \TFTPOVLEN \UDPOVLEN])

(\TFTP.PRINT.ERROR
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 13:15")
    (printout FILE "Error code: " (fetch (TFTP ERRORCODE) of TFTP)
           T)
    (PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP)
           0
           '(CHARS |...|)
           (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
                  (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN)))
           FILE])

(\TFTP.PRINT.REQUEST
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 13:16")
          
          (* * Try to start sending a file to the requestor as directed by the contents 
          of the received TFTP packet)

    (LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
                                                                                 of TFTP)
                                                                       I))
                              finally (RETURN (IDIFFERENCE I BYTESPERWORD]
           (FILENAME (ALLOCSTRING FILENAMELENGTH))
           [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                          until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of TFTP)
                                             I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD 
                                                                                       FILENAMELENGTH 
                                                                                       1]
           (MODE (ALLOCSTRING MODELENGTH)))
          
          (* * Read the filename out of the packet)

          (\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP)
                 BYTESPERWORD
                 (fetch (STRINGP BASE) of FILENAME)
                 (fetch (STRINGP OFFST) of FILENAME)
                 FILENAMELENGTH)
          
          (* * Read the mode out of the packet)

          (\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP)
                 (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                 (fetch (STRINGP BASE) of MODE)
                 (fetch (STRINGP OFFST) of MODE)
                 MODELENGTH)
          (printout FILE (SELECTC (fetch (TFTP OPCODE) of TFTP)
                             (\TFTP.RRQ "Read request for ")
                             (\TFTP.WRQ "Write request for ")
                             (SHOULDNT))
                 FILENAME " in mode " MODE T])
)

(\TFTP.INIT)
(PUTPROPS TCPTFTP COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3785 28418 (\TFTP.ACKNOWLEDGE 3795 . 4474) (\TFTP.CLOSEFILE 4476 . 5171) (\TFTP.EOFP 
5173 . 5530) (\TFTP.ERROR 5532 . 6308) (\TFTP.GETNEXTBUFFER 6310 . 19593) (\TFTP.INIT 19595 . 20684) (
\TFTP.INPUT.BUFFER 20686 . 21902) (\TFTP.OPENFILE 21904 . 27296) (\TFTP.READP 27298 . 27522) (
\TFTP.SEND.ERROR 27524 . 28019) (\TFTP.SETUP 28021 . 28416)) (28610 46223 (TFTP.SERVER.PROCESS 28620
 . 31874) (\TFTP.GET.FILE 31876 . 39527) (\TFTP.SEND.FILE 39529 . 46221)) (46256 49207 (TFTP.SERVER 
46266 . 46555) (TFTP.GET 46557 . 48098) (TFTP.PUT 48100 . 49205)) (49243 53309 (PRINTTFTP 49253 . 
50082) (\TFTP.PRINT.ACK 50084 . 50285) (\TFTP.PRINT.DATA 50287 . 50726) (\TFTP.PRINT.ERROR 50728 . 
51181) (\TFTP.PRINT.REQUEST 51183 . 53307)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPUDP b/obsolete/tcp/TCPUDP
new file mode 100644
index 00000000..9f0f5b90
--- /dev/null
+++ b/obsolete/tcp/TCPUDP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 17:46:11" {DSK}<usr>local>lde>lispcore>library>TCPUDP.;2 11429  

      changes to%:  (VARS TCPUDPCOMS)

      previous date%: " 6-Jan-89 16:37:55" {DSK}<usr>local>lde>lispcore>library>TCPUDP.;1)


(* ; "
Copyright (c) 1985, 1986, 1987, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPUDPCOMS)

(RPAQQ TCPUDPCOMS
       [(COMS 
              (* ;; "User Datagram Protocol --- Definitions")

              [DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS UDP)
                                                      (CONSTANTS (\UDPOVLEN 8]
              (FILES (SYSLOAD)
                     TCPLLIP))
        (COMS 
              (* ;; "Internal functions")

              (FNS UDP.GET.BYTE UDP.GET.CELL UDP.GET.STRING UDP.GET.WORD \UDP.FLUSH.SOCKET.QUEUE 
                   \UDP.PORTCOMPARE \UDP.CHECKSUM \UDP.SET.CHECKSUM)
              (FNS \UDP.HANDLE.ICMP))
        (COMS 
              (* ;; "External functions")

              (FNS PRINTUDP UDP.INIT UDP.STOP UDP.OPEN.SOCKET UDP.CLOSE.SOCKET UDP.SOCKET.EVENT 
                   UDP.SOCKET.NUMBER UDP.GET UDP.SEND UDP.EXCHANGE UDP.SETUP UDP.APPEND.BYTE 
                   UDP.APPEND.CELL UDP.APPEND.STRING UDP.APPEND.WORD UDP.INCREMENT.LENGTH)
              (ADDVARS (IPPRINTMACROS (17 . PRINTUDP)))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? 'NILL 'PRINTRPCDATA)
                                                 (UDP.INIT])



(* ;; "User Datagram Protocol --- Definitions")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS UDP ((UDPBASE (\IPDATABASE DATUM)))
                   (BLOCKRECORD UDPBASE ((UDPSOURCEPORT WORD)
                                         (UDPDESTPORT WORD)
                                         (UDPLENGTH WORD)
                                         (UDPCHECKSUM WORD)))
                   [ACCESSFNS UDP ((UDPCONTENTS (\ADDBASE (\IPDATABASE DATUM)
                                                       (FOLDHI \UDPOVLEN BYTESPERWORD])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \UDPOVLEN 8)


(CONSTANTS (\UDPOVLEN 8))
)

(* "END EXPORTED DEFINITIONS")

)

(FILESLOAD (SYSLOAD)
       TCPLLIP)



(* ;; "Internal functions")

(DEFINEQ

(UDP.GET.BYTE
(LAMBDA (UDP BYTE#) (* ejs%: "25-Jun-85 21:04") (* * Return a byte from the UDP data area) (COND ((AND (IGEQ BYTE# 0) (ILESSP BYTE# (fetch (UDP UDPLENGTH) of UDP))) (\GETBASEBYTE (fetch (UDP UDPCONTENTS) of UDP) BYTE#))))
)

(UDP.GET.CELL
(LAMBDA (UDP CELL#) (* ejs%: "25-Jun-85 21:09") (* * Return a cell from the UDP data area) (COND ((AND (IGEQ CELL# 0) (ILESSP CELL# (FOLDLO (fetch (UDP UDPLENGTH) of UDP) BYTESPERCELL))) (\MAKENUMBER (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) (UNFOLD CELL# WORDSPERCELL)) (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) (ADD1 (UNFOLD CELL# WORDSPERCELL)))))))
)

(UDP.GET.STRING
(LAMBDA (UDP OFFSET) (* ejs%: "25-Jun-85 21:12") (* * Fetch a string out of the UDP packet) (OR (SMALLP OFFSET) (SETQ OFFSET 0)) (LET* ((LENGTH (IDIFFERENCE (fetch (UDP UDPLENGTH) of UDP) OFFSET)) (STRING (ALLOCSTRING LENGTH))) (\MOVEBYTES (fetch (UDP UDPCONTENTS) of UDP) OFFSET (fetch (STRINGP BASE) of STRING) (fetch (STRINGP OFFST) of STRING) LENGTH) STRING))
)

(UDP.GET.WORD
(LAMBDA (UDP WORD#) (* ejs%: "25-Jun-85 21:06") (* * Return a word from the UDP data area) (COND ((AND (IGEQ WORD# 0) (ILESSP WORD# (FOLDLO (fetch (UDP UDPLENGTH) of UDP) BYTESPERWORD))) (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) WORD#))))
)

(\UDP.FLUSH.SOCKET.QUEUE
(LAMBDA (IPSOCKET) (* ; "Edited 25-Aug-88 12:57 by bvm") (* ;;; "Called to flush input packet queue on an IPSOCKET") (LET ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) PACKET) (UNINTERRUPTABLY (while (SETQ PACKET (\DEQUEUE QUEUE)) do (\RELEASE.ETHERPACKET PACKET) finally (replace (IPSOCKET IPSQUEUELENGTH) of IPSOCKET with 0)))))
)

(\UDP.PORTCOMPARE
(LAMBDA (UDP IPSOCKET) (* ejs%: " 9-Feb-85 14:37") (* * Compare IPSOCKET until we find the one this UDP was destined for) (EQ (fetch (UDP UDPDESTPORT) of UDP) (fetch (IPSOCKET IPSOCKET) of IPSOCKET)))
)

(\UDP.CHECKSUM
(LAMBDA (UDP ZeroCheckSumIsOK) (* HAS%: "19-Aug-86 16:47") (* * Compute the UDP checksum for the packet UDP. The packet is assumed to have been setup by UDP.SETUP so that source and destination addresses, protocol, and UDP length have already been set.) (COND ((AND ZeroCheckSumIsOK (EQ (fetch (UDP UDPCHECKSUM) of UDP) 0)) (* * BSD Unix strikes again!) 0) (T (LET ((SOURCE (fetch (IP IPSOURCEADDRESS) of UDP)) (DEST (fetch (IP IPDESTINATIONADDRESS) of UDP)) (LENGTH (fetch (UDP UDPLENGTH) of UDP)) CHECKSUM) (SETQ CHECKSUM (IPLUS (bind (BASE _ (LOCF (fetch (IP IPSOURCEADDRESS) of UDP))) for I from 0 to (CONSTANT (SUB1 (TIMES 2 WORDSPERCELL))) sum (\GETBASE BASE I)) (ffetch (IP IPPROTOCOL) of UDP) LENGTH (\IPCHECKSUM UDP (\IPDATABASE UDP) LENGTH))) (SETQ CHECKSUM (IPLUS (LDB (BYTE 16 16) CHECKSUM) (LDB (BYTE 16 0) CHECKSUM))) (COND ((NOT (EQ (LDB (BYTE 16 16) CHECKSUM) 0)) (SETQ CHECKSUM (IPLUS (LDB (BYTE 16 16) CHECKSUM) (LDB (BYTE 16 0) CHECKSUM))))) CHECKSUM))))
)

(\UDP.SET.CHECKSUM
(LAMBDA (UDP) (* ejs%: " 3-Jun-85 00:19") (* * Called to set the UDP checksum in a packet ready to be transmitted) (LET (CHECKSUM) (replace (UDP UDPCHECKSUM) of UDP with 0) (SETQ CHECKSUM (\UDP.CHECKSUM UDP)) (replace (UDP UDPCHECKSUM) of UDP with (COND ((NEQ CHECKSUM MAX.SMALLP) (LOGAND (LOGNOT CHECKSUM) (CONSTANT (MASK.1'S 0 16)))) (T MAX.SMALLP)))))
)
)
(DEFINEQ

(\UDP.HANDLE.ICMP
(LAMBDA (ICMP SENTIP PROTOCOL) (* ; "Edited 13-Sep-88 14:26 by bvm") (* ;; "Handle an ICMP packet sent to a UDP socket.  We allow each UDP client to decide how to handle these.") (LET ((SOCKET (\IP.FIND.SOCKET (ffetch (UDP UDPSOURCEPORT) of SENTIP) PROTOCOL)) FN) (if (OR (NULL SOCKET) (EQ (SETQ FN (ffetch (IPSOCKET IPSICMPFN) of SOCKET)) (QUOTE \UDP.HANDLE.ICMP))) then (* ; "Sender went away already, or else didn't specify a handler (so inherited the default)") (\RELEASE.ETHERPACKET ICMP) else (CL:FUNCALL FN ICMP SENTIP SOCKET))))
)
)



(* ;; "External functions")

(DEFINEQ

(PRINTUDP
(LAMBDA (UDP FILE) (* ; "Edited  6-Jan-89 16:18 by Briggs") (printout FILE "UDP Source port: " (fetch (UDP UDPSOURCEPORT) of UDP) " Dest port: " (fetch (UDP UDPDESTPORT) of UDP) T "Length: " (fetch (UDP UDPLENGTH) of UDP) " Checksum: " (fetch (UDP UDPCHECKSUM) of UDP) T) (COND ((OR (EQ (fetch (UDP UDPDESTPORT) of UDP) \TFTP.SOCKET) (EQ (fetch (UDP UDPSOURCEPORT) of UDP) \TFTP.SOCKET)) (PRINTTFTP UDP FILE)) (T (PRINTRPCDATA (fetch (UDP UDPCONTENTS) of UDP) (- (fetch (UDP UDPLENGTH) of UDP) \UDPOVLEN) FILE))))
)

(UDP.INIT
(LAMBDA NIL (* ; "Edited 25-Aug-88 12:54 by bvm") (COND ((OR \IPFLG (SELECTQ (ASKUSER 15 (QUOTE Y) "IP is not running.  Shall I attempt to initialize it? ") (Y (\IPINIT) \IPFLG) NIL)) (\IP.ADD.PROTOCOL \UDP.PROTOCOL (FUNCTION \UDP.PORTCOMPARE) NIL NIL (FUNCTION \UDP.HANDLE.ICMP)))))
)

(UDP.STOP
(LAMBDA NIL (* ejs%: " 9-Feb-85 14:43") (\IP.DELETE.PROTOCOL \UDP.PROTOCOL)))

(UDP.OPEN.SOCKET
(LAMBDA (SKT# IFCLASH ICMPFN) (* ; "Edited 25-Aug-88 13:03 by bvm") (LET ((UDPCHAIN (\IP.FIND.PROTOCOL \UDP.PROTOCOL))) (if (OR UDPCHAIN (SETQ UDPCHAIN (UDP.INIT))) then (if (NULL SKT#) then (* ; "Open any free socket") (\IP.OPEN.SOCKET \UDP.PROTOCOL NIL NIL NIL NIL NIL ICMPFN) else (* ; "Check for clash") (LET ((IPSOCKET (\IP.FIND.SOCKET SKT# UDPCHAIN))) (if (NULL IPSOCKET) then (\IP.OPEN.SOCKET \UDP.PROTOCOL SKT# NIL NIL NIL NIL ICMPFN) else (SELECTQ IFCLASH ((T ACCEPT) (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) IPSOCKET) ((DON'T FAIL) NIL) (ERROR "UDP Port is already in use" SKT#))))) else (* ; "IP not inited") (SELECTQ IFCLASH ((DON'T FAIL) NIL) (ERROR!)))))
)

(UDP.CLOSE.SOCKET
(LAMBDA (IPSOCKET NOERRORFLG) (* ejs%: " 9-Feb-85 15:00") (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) (\IP.CLOSE.SOCKET (fetch (IPSOCKET IPSOCKET) of IPSOCKET) \UDP.PROTOCOL NOERRORFLG))
)

(UDP.SOCKET.EVENT
(LAMBDA (IPSOCKET) (* ejs%: " 9-Feb-85 15:07") (fetch (IPSOCKET IPSEVENT) of IPSOCKET)))

(UDP.SOCKET.NUMBER
(LAMBDA (IPSOCKET) (* ejs%: " 9-Feb-85 15:08") (fetch (IPSOCKET IPSOCKET) of IPSOCKET)))

(UDP.GET
(LAMBDA (IPSOCKET WAIT) (* ; "Edited 13-Sep-88 11:59 by bvm") (* ;;; "Returns the next UDP packet on the queue, or NIL if none exist and WAIT is NIL.  If WAIT is T, this function waits forever.  If WAIT is an integer, it is interpreted as the number of milliseconds to wait before returning NIL or a packet which arrives during that time.  This function therefore is like GETXIP and GETPUP") (PROG ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) UDP TIMER) LP (UNINTERRUPTABLY (COND ((SETQ UDP (\DEQUEUE QUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1)))) (COND ((NULL UDP) (COND (WAIT (COND ((EQ WAIT T) (* ; "Wait forever")) (TIMER (COND ((TIMEREXPIRED? TIMER) (RETURN)))) (T (OR (FIXP WAIT) (LISPERROR "NON-NUMERIC ARG" WAIT)) (SETQ TIMER (SETUPTIMER WAIT)) T)) (AWAIT.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET) TIMER T) (GO LP)) (T (BLOCK)))) ((AND (EQ (fetch (IP IPPROTOCOL) of UDP) \UDP.PROTOCOL) (NEQ (fetch (UDP UDPCHECKSUM) of UDP) 0) (NOT (\IP.CHECKSUM.OK (\UDP.CHECKSUM UDP)))) (* ; "Bad checksum on UDP packet.  Any other kind of packet must have been put there by someone else") (\RELEASE.ETHERPACKET UDP) (GO LP))) (RETURN UDP)))
)

(UDP.SEND
(LAMBDA (IPSOCKET UDP) (* ejs%: " 9-Feb-85 15:24") (* * Sends a UDP packet. IP and UDP header assumed set up by UDP.SETUP and \IP.SETUPIP) (\UDP.SET.CHECKSUM UDP) (\IP.TRANSMIT UDP))
)

(UDP.EXCHANGE
(LAMBDA (IPSOCKET OUTUDP TIMEOUT) (* ejs%: " 9-Feb-85 22:28") (* * Send a UDP packet and wait for TIMEOUT to receive a packet (TIMEOUT defaults to \ETHERTIMEOUT)) (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) (UDP.SEND IPSOCKET OUTUDP) (BLOCK) (UDP.GET IPSOCKET (OR (FIXP TIMEOUT) \ETHERTIMEOUT)))
)

(UDP.SETUP
(LAMBDA (UDP DESTHOST DESTSOCKET ID IPSOCKET REQUEUE) (* ejs%: " 9-Feb-85 16:04") (\IP.SETUPIP UDP DESTHOST ID IPSOCKET REQUEUE) (add (fetch (IP IPTOTALLENGTH) of UDP) \UDPOVLEN) (AND (SMALLP DESTSOCKET) (replace (UDP UDPDESTPORT) of UDP with DESTSOCKET)) (replace (UDP UDPSOURCEPORT) of UDP with (fetch (IPSOCKET IPSOCKET) of IPSOCKET)) (replace (UDP UDPLENGTH) of UDP with \UDPOVLEN) UDP)
)

(UDP.APPEND.BYTE
(LAMBDA (UDP BYTE) (* ejs%: " 9-Feb-85 16:07") (\IP.APPEND.BYTE UDP BYTE) (add (fetch (UDP UDPLENGTH) of UDP) 1))
)

(UDP.APPEND.CELL
(LAMBDA (UDP CELL) (* ejs%: " 9-Feb-85 16:06") (\IP.APPEND.CELL UDP CELL) (add (fetch (UDP UDPLENGTH) of UDP) BYTESPERCELL))
)

(UDP.APPEND.STRING
(LAMBDA (UDP STRING) (* ejs%: " 9-Feb-85 16:10") (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (\IP.APPEND.STRING UDP STRING) (add (fetch (UDP UDPLENGTH) of UDP) (NCHARS STRING)))
)

(UDP.APPEND.WORD
(LAMBDA (UDP WORD) (* ejs%: " 9-Feb-85 16:07") (\IP.APPEND.WORD UDP WORD) (add (fetch (UDP UDPLENGTH) of UDP) WORDSPERCELL))
)

(UDP.INCREMENT.LENGTH
(LAMBDA (UDP INCREMENT) (* ejs%: "12-Apr-86 18:50") (add (fetch (IP IPTOTALLENGTH) of UDP) INCREMENT) (add (fetch (UDP UDPLENGTH) of UDP) INCREMENT) INCREMENT)
)
)

(ADDTOVAR IPPRINTMACROS (17 . PRINTUDP))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MOVD? 'NILL 'PRINTRPCDATA)

(UDP.INIT)
)
(PUTPROPS TCPUDP COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2357 5603 (UDP.GET.BYTE 2367 . 2608) (UDP.GET.CELL 2610 . 2984) (UDP.GET.STRING 2986 . 
3371) (UDP.GET.WORD 3373 . 3632) (\UDP.FLUSH.SOCKET.QUEUE 3634 . 3998) (\UDP.PORTCOMPARE 4000 . 4224) 
(\UDP.CHECKSUM 4226 . 5220) (\UDP.SET.CHECKSUM 5222 . 5601)) (5604 6176 (\UDP.HANDLE.ICMP 5614 . 6174)
) (6213 11197 (PRINTUDP 6223 . 6752) (UDP.INIT 6754 . 7053) (UDP.STOP 7055 . 7146) (UDP.OPEN.SOCKET 
7148 . 7833) (UDP.CLOSE.SOCKET 7835 . 8036) (UDP.SOCKET.EVENT 8038 . 8148) (UDP.SOCKET.NUMBER 8150 . 
8261) (UDP.GET 8263 . 9439) (UDP.SEND 9441 . 9639) (UDP.EXCHANGE 9641 . 9947) (UDP.SETUP 9949 . 10356)
 (UDP.APPEND.BYTE 10358 . 10494) (UDP.APPEND.CELL 10496 . 10643) (UDP.APPEND.STRING 10645 . 10857) (
UDP.APPEND.WORD 10859 . 11006) (UDP.INCREMENT.LENGTH 11008 . 11195)))))
STOP
\ No newline at end of file
