(FILECREATED "26-Jun-85 14:58:46" {ERIS}<LISPCORE>LIBRARY>TCPLLIP.;26 76234
changes to: (FNS \HANDLE.RAW.IP)
previous date: "25-Jun-85 21:14:10" {ERIS}<LISPCORE>LIBRARY>TCPLLIP.;25)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TCPLLIPCOMS)
(RPAQQ TCPLLIPCOMS ((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)))
(INITVARS (IPONLYTYPES)
(IPIGNORETYPES)
(IPPRINTMACROS)
(IPTRACEFLG)
(IPTRACEFILE)
(\IP.INIT.FILE)
(\IP.DEFAULT.CONFIGURATION)
(\IP.HOSTNAMES (HASHARRAY 40 1.1))
(\IP.HOSTNUMBERS))
(INITRECORDS IP IPSOCKET IPADDRESS)
(GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS
\IP.HOSTNAMES \IP.INIT.FILE \IP.DEFAULT.CONFIGURATION
\IP.HOSTNUMBERS)
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
TCPHTE TCPLLICMP TCPLLAR)
(ADDVARS (\PACKET.PRINTERS (2048 . PRINTIP)))
(FNS DODIP.HOSTP IPHOSTADDRESS IPHOSTNAME IPTRACE IPTRACEWINDOW.BUTTONFN
PRINTIP PRINTIPDATA \IPADDRESSCLASS \IPHOSTADDRESS \IPNETADDRESS
\IP.ADDRESS.TO.STRING \IP.BROADCAST.ADDRESS \IP.LEGAL.ADDRESS
\IP.MAKE.BROADCAST.ADDRESS \IP.PRINT.ADDRESS \IP.READ.STRING.ADDRESS))
(COMS (* * Startup and shutdown)
(INITVARS (\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)
(FNS STOPIP \IPINIT \IPLISTENER))
(COMS (* * Early IP reception functions)
(DECLARE: DONTCOPY (EXPORT (CONSTANTS * IPADDRESSTYPES)))
(INITVARS (\IP.LOCAL.ADDRESSES))
(GLOBALVARS \IP.LOCAL.ADDRESSES)
(MACROS \IP.FIX.DEST.HOST \IP.FIX.DEST.NET \IP.FIX.SOURCE.HOST \IP.FIX.SOURCE.NET
\IPDATABASE)
(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)))
(INITRECORDS AssemblyRecord FragmentRecord)
(INITVARS (\IP.FRAGMENTS)
(\IP.FRAGMENT.NET)
(\IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock")))
(GLOBALVARS \IP.FRAGMENTS \IP.FRAGMENT.NET \IP.FRAGMENT.LOCK)
(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))
(COMS (* * Option Processing)
(DECLARE: DONTCOPY (EXPORT (CONSTANTS * IPOPTIONTYPES)
(CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)))))
(FNS \IP.PROCESS.OPTIONS))
(COMS (* * Packet Transmission and routing)
(INITVARS (\IP.ROUTING.TABLE (CONS))
(\IP.DEFAULT.GATEWAY)
(\IP.LOCAL.NETWORKS))
(GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS)
(FNS \IP.SETUPIP \IP.TRANSMIT \IP.ROUTE.PACKET \IP.LOCATE.NET))
(COMS (* * Client functions for building packets)
(FNS \IP.APPEND.BYTE \IP.APPEND.CELL \IP.APPEND.STRING \IP.APPEND.WORD))
(ADVISE \CANONICAL.HOSTNAME)))
(* 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 BITS 1) (* Don't fragment me)
(IPMOREFRAGMENTS BITS 1) (* 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 (fetch (IP IPSERVICE)
of 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))
(BLOCKRECORD IPADDRESS ((CLASSA BITS 1)
(CLASSANET BITS 7)
(CLASSAHOSTHI BITS 8)
(CLASSAHOSTLO BITS 16)))
(ACCESSFNS IPADDRESS ((CLASSAHOST (\MAKENUMBER (FETCH CLASSAHOSTHI
OF DATUM)
(FETCH CLASSAHOSTLO
OF DATUM))
(PROGN (REPLACE CLASSAHOSTHI OF DATUM
WITH (LRSH NEWVALUE 16))
(REPLACE CLASSAHOSTLO OF DATUM
WITH (LOGAND NEWVALUE 65535))
DATUM))))
(BLOCKRECORD IPADDRESS ((CLASSB BITS 2)
(CLASSBNETLO BITS 14)
(CLASSBHOSTWORD BITS 16)))
(ACCESSFNS IPADDRESS ((CLASSBNET (\HINUM DATUM)
(replace CLASSBNETLO of DATUM with NEWVALUE)))
)
(ACCESSFNS IPADDRESS ((CLASSBHOST (fetch CLASSBHOSTWORD of DATUM)
(replace CLASSBHOSTWORD of DATUM
with (LOGAND NEWVALUE 65535)))))
(BLOCKRECORD IPADDRESS ((CLASSC BITS 3)
(CLASSCNETHI BITS 13)
(CLASSCNETLO BITS 8)
(CLASSCHOSTBYTE BITS 8)))
(ACCESSFNS IPADDRESS ((CLASSCNET (LOGOR (LLSH (\HINUM DATUM)
8)
(FETCH CLASSCNETLO OF DATUM))
(PROGN (REPLACE CLASSCNETHI OF DATUM
WITH (LRSH NEWVALUE 8))
(REPLACE CLASSCNETLO OF DATUM
WITH (LOGAND NEWVALUE
(MASK.1'S 0 8)))
DATUM))))
(ACCESSFNS IPADDRESS ((CLASSCHOST (fetch CLASSCHOSTBYTE of DATUM)
(replace CLASSCHOSTBYTE of DATUM
with (LOGAND 255 NEWVALUE))))))
]
(/DECLAREDATATYPE (QUOTE IPSOCKET)
(QUOTE (BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER
POINTER))
(QUOTE ((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)))
(QUOTE 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)
)
(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 )
(/DECLAREDATATYPE (QUOTE IPSOCKET)
(QUOTE (BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER
POINTER))
(QUOTE ((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)))
(QUOTE 18))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS \IP.HOSTNAMES
\IP.INIT.FILE \IP.DEFAULT.CONFIGURATION \IP.HOSTNUMBERS)
)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
TCPHTE TCPLLICMP TCPLLAR)
(ADDTOVAR \PACKET.PRINTERS (2048 . PRINTIP))
(DEFINEQ
(DODIP.HOSTP
(LAMBDA (NAME) (* ejs: " 9-Feb-85 13:44")
(OR (NUMBERP NAME)
(IPHOSTADDRESS NAME))))
(IPHOSTADDRESS
(LAMBDA (NAME) (* ejs: "27-Apr-85 18:57")
(LET ((ENTRY (GETHASH (U-CASE 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 (MODE) (* ejs: " 2-Jun-85 13:04")
(COND
((WINDOWP IPTRACEFILE)
(OPENW IPTRACEFILE))
(T (SETQ IPTRACEFILE (CREATEW NIL "IP Trace File"))
(DSPSCROLL (QUOTE ON)
IPTRACEFILE)
(DSPFONT (QUOTE (GACHA 8))
IPTRACEFILE)
(WINDOWPROP IPTRACEFILE (QUOTE BUTTONEVENTFN)
(FUNCTION IPTRACEWINDOW.BUTTONFN))))
(SETQ IPTRACEFLG MODE)))
(IPTRACEWINDOW.BUTTONFN
(LAMBDA (WINDOW) (* ejs: " 2-Jun-85 13:05")
(COND
((MOUSESTATE (NOT UP))
(SETQ IPTRACEFLG (SELECTQ IPTRACEFLG
(NIL T)
(T (QUOTE PEEK))
(PEEK NIL)
NIL))
(printout WINDOW T "[Tracing " (SELECTQ IPTRACEFLG
(T "on")
(PEEK "peek")
"off")
"]" T)))))
(PRINTIP
(LAMBDA (IP CALLER FILE PRE.NOTE DOFILTER) (* ejs: " 9-Feb-85 18:07")
(OR FILE (SETQ FILE IPTRACEFILE))
(PROG ((PROTOCOL (fetch (IP IPPROTOCOL) of IP))
MACRO LENGTH)
(COND
(DOFILTER (COND
((COND
(IPONLYTYPES (NOT (FMEMB PROTOCOL IPONLYPROTOCOLS)))
(IPIGNORETYPES (FMEMB PROTOCOL IPIGNORETYPES)))
(RETURN (PRIN1 (SELECTQ CALLER
((PUT RAWPUT)
(QUOTE !))
((GET RAWGET)
(QUOTE +))
(QUOTE ?))
FILE))))))
(AND PRE.NOTE (printout FILE T PRE.NOTE))
(printout FILE "From " (\IP.ADDRESS.TO.STRING (fetch (IP IPSOURCEADDRESS) of IP))
" to "
(\IP.ADDRESS.TO.STRING (fetch (IP IPDESTINATIONADDRESS) of IP))
T)
(COND
((SETQ MACRO (CDR (FASSOC PROTOCOL IPPRINTMACROS)))
(* Macro is a function to which to dispatch for the
printing.)
(AND (NLISTP MACRO)
(RETURN (RESETFORM (OUTPUT FILE)
(APPLY* MACRO IP FILE))))))
(printout FILE "Length = " .P2 (SETQ LENGTH (fetch (IP IPTOTALLENGTH) of IP))
" bytes" " (header + " .P2 (IDIFFERENCE LENGTH \IPOVLEN)
")" T "Protocol = ")
(PRINTCONSTANT PROTOCOL IPPROTOCOLTYPES FILE)
(TERPRI FILE)
(COND
((IGREATERP LENGTH \IPOVLEN) (* MACRO tells how to print data.)
(PRIN1 "Contents: " FILE)
(PRINTIPDATA IP (OR MACRO (QUOTE (BYTES 12 ...)))
NIL FILE)))
(TERPRI FILE)
(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) (* ejs: " 4-Apr-85 15:19")
(COND
((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of IPADDRESS))
(QUOTE \IP.CLASS.A))
((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of IPADDRESS))
(QUOTE \IP.CLASS.B))
((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of IPADDRESS))
(QUOTE \IP.CLASS.C))
(T (ERROR "Illegal address class" IPADDRESS)))))
(\IPHOSTADDRESS
(LAMBDA (IPADDRESS) (* ejs: "27-Dec-84 15:04")
(COND
((EQ \IP.CLASS.A (LDB \IP.CLASS.A.BYTESPEC IPADDRESS))
(LDB \IP.CLASS.A.HOST.BYTESPEC IPADDRESS))
((EQ \IP.CLASS.B (LDB \IP.CLASS.B.BYTESPEC IPADDRESS))
(LDB \IP.CLASS.B.HOST.BYTESPEC IPADDRESS))
((EQ \IP.CLASS.C (LDB \IP.CLASS.C.BYTESPEC IPADDRESS))
(LDB \IP.CLASS.C.HOST.BYTESPEC IPADDRESS))
(T (ERROR "Illegal address class" IPADDRESS)))))
(\IPNETADDRESS
(LAMBDA (IPADDRESS) (* ejs: "22-Apr-85 17:38")
(COND
((EQ \IP.CLASS.A (LDB \IP.CLASS.A.BYTESPEC IPADDRESS))
(LDB \IP.CLASS.A.NET.BYTESPEC IPADDRESS))
((EQ \IP.CLASS.B (LDB \IP.CLASS.B.BYTESPEC IPADDRESS))
(LDB \IP.CLASS.B.NET.BYTESPEC IPADDRESS))
((EQ \IP.CLASS.C (LDB \IP.CLASS.C.BYTESPEC IPADDRESS))
(LDB \IP.CLASS.C.NET.BYTESPEC IPADDRESS))
(T (ERROR "Illegal address class" 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) (* ejs: "27-Dec-84 16:01")
(PROG ((HOSTADDRESS (\IPHOSTADDRESS IPADDRESS)))
(RETURN (SELECTQ (\IPADDRESSCLASS IPADDRESS)
(\IP.CLASS.A (EQP (MASK.1'S 0 24)
HOSTADDRESS))
(\IP.CLASS.B (EQ (MASK.1'S 0 16)
HOSTADDRESS))
(\IP.CLASS.C (EQ (MASK.1'S 0 8)
HOSTADDRESS))
NIL)))))
(\IP.LEGAL.ADDRESS
(LAMBDA (ADDRESS) (* ejs: " 4-Jun-85 23:28")
(OR (EQ 0 (\IPNETADDRESS ADDRESS))
(AND (NOT (EQ ADDRESS 0))
(OR (EQ (fetch (IPADDRESS CLASSA) of ADDRESS)
\IP.CLASS.A)
(EQ (fetch (IPADDRESS CLASSB) of ADDRESS)
\IP.CLASS.B)
(EQ (fetch (IPADDRESS CLASSC) of ADDRESS)
\IP.CLASS.C))))))
(\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) (* ejs: "27-Dec-84 15:42")
(* * Convert a dotted notation -- 36.9.0.9 -- to an internal notation)
(bind (CELL ←(ARRAY 4 (QUOTE BYTE)
0 0))
(INDEX ← 0)
(TEMP ← 0) for CHAR instring (MKSTRING STRING.OR.ATOM)
while (AND (ILEQ INDEX 3)
(ILEQ TEMP (MASK.1'S 0 8)))
do (COND
((EQ CHAR (CHARCODE %.))
(\BYTESETA CELL INDEX TEMP)
(SETQ TEMP 0)
(add INDEX 1))
((AND (IGEQ CHAR (CHARCODE 0))
(ILEQ CHAR (CHARCODE 9)))
(SETQ TEMP (IPLUS (ITIMES TEMP 10)
(IDIFFERENCE CHAR (CHARCODE 0))))))
finally (COND
((ILEQ TEMP (MASK.1'S 0 8))
(\BYTESETA CELL INDEX TEMP)))
(RETURN (COND
((EQ INDEX 3)
(create FIXP
HINUM ←(create WORD
HIBYTE ←(\BYTELT CELL 0)
LOBYTE ←(\BYTELT CELL 1))
LONUM ←(create WORD
HIBYTE ←(\BYTELT CELL 2)
LOBYTE ←(\BYTELT CELL 3)))))))))
)
(* * Startup and shutdown)
(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)
)
(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 (QUOTE \IPLISTENER))
(SETQ \IPFLG (SETQ \IP.READY NIL))))
(\IPINIT
(LAMBDA (EVENT) (* ejs: "25-Jun-85 19:21")
(* Initialize IP protocol)
(DECLARE (GLOBALVARS (\IP.HTE.FILE \IP.HOSTNAME \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY
\IP.INIT.FILE)))
(SELECTQ EVENT
((AFTERSYSOUT AFTERMAKESYS AFTERLOGOUT)
(SETQ \IP.DEFAULT.CONFIGURATION NIL)
(SETQ \IP.INIT.FILE NIL)
(SETQ \IP.LOCAL.ADDRESSES NIL)
(SETQ \IP.DEFAULT.GATEWAY NIL)
(SETQ \IP.ROUTING.TABLE (CONS))
(SETQ \IP.LOCAL.NETWORKS NIL))
NIL)
(SETQ \AR.IP.TO.10MB.ALIST NIL)
(PROG ((PROC (FIND.PROCESS (QUOTE \IPLISTENER)))
NDB ADDRESS.STRING)
(* * This is a kludge until we know more about IP routing and reverse address resolution)
(CLEARBUF T)
(COND
((NOT \IP.INIT.FILE)
(SETQ \IP.INIT.FILE (OR (INFILEP (QUOTE {DSK}IP.INIT))
(bind NAME thereis (SETQ NAME (INFILEP (PROMPTFORWORD
"Please enter the name of the IP initialization file for this host: ")))
finally (RETURN NAME))))))
(COND
((NULL \IP.DEFAULT.CONFIGURATION)
(COND
((NULL (SETQ \IP.DEFAULT.CONFIGURATION (LET ((STREAM (OPENSTREAM \IP.INIT.FILE
(QUOTE INPUT)
(QUOTE OLD))))
(COND
(STREAM (PROG1 (READ STREAM)
(CLOSEF STREAM)))))))
(ERROR "Problem with local IP init file")))))
(COND
((NOT (fetch (IPINIT HTE.FILE) of \IP.DEFAULT.CONFIGURATION))
(bind NAME until (replace (IPINIT HTE.FILE) of \IP.DEFAULT.CONFIGURATION
with (INFILEP (SETQ NAME (PROMPTFORWORD
"Please supply the name of a HOSTS.TXT file, or <CR> to ignore this: "))))
do (COND
((NULL NAME)
(GO $$OUT))))))
(COND
((fetch (IPINIT HTE.FILE) of \IP.DEFAULT.CONFIGURATION)
(\HTE.READ.FILE (fetch (IPINIT HTE.FILE) of \IP.DEFAULT.CONFIGURATION))))
(COND
((AND (NOT (fetch (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION))
(NOT (replace (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION
with (U-CASE (MKATOM (ETHERHOSTNAME))))))
(replace (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION
with (U-CASE (MKATOM (PROMPTFORWORD
"Please give this machine a name (or <CR> for no name): ")))))
)
(COND
((fetch (IPINIT LOCAL.ADDRESSES) of \IP.DEFAULT.CONFIGURATION)
(SETQ \IP.LOCAL.ADDRESSES (for ADDR in (fetch (IPINIT LOCAL.ADDRESSES) of
\IP.DEFAULT.CONFIGURATION)
collect (\IP.READ.STRING.ADDRESS ADDR))))
((AND (fetch (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION)
(DODIP.HOSTP (fetch (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION)))
(SETQ \IP.LOCAL.ADDRESSES (LIST (DODIP.HOSTP (fetch (IPINIT HOSTNAME) of
\IP.DEFAULT.CONFIGURATION)))))
(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
((fetch (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION)
(PUTHASH (fetch (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION)
(create HOSTS.TXT.ENTRY
HTE.TYPE ←(QUOTE HOST)
HTE.ADDRESSES ← \IP.LOCAL.ADDRESSES
HTE.NAMES ←(LIST (fetch (IPINIT HOSTNAME) of
\IP.DEFAULT.CONFIGURATION))
HTE.MACHINE.TYPE ←(SELECTQ (MACHINETYPE)
(DANDELION (QUOTE XEROX-1108))
(DOLPHIN (QUOTE XEROX-1100))
(DORADO (QUOTE XEROX-1132))
(QUOTE XEROX-11XX))
HTE.OS.TYPE ←(QUOTE INTERLISP)
HTE.PROTOCOLS ←(QUOTE ((TCP)
(IP))))
\IP.HOSTNAMES)))))
(COND
((fetch (IPINIT DEFAULT.GATEWAY) of \IP.DEFAULT.CONFIGURATION)
(SETQ \IP.DEFAULT.GATEWAY (\IP.READ.STRING.ADDRESS (fetch (IPINIT DEFAULT.GATEWAY)
of \IP.DEFAULT.CONFIGURATION)))))
(COND
((EQLENGTH (fetch (IPINIT LOCAL.NETWORKS) of \IP.DEFAULT.CONFIGURATION)
(LENGTH \IP.LOCAL.ADDRESSES))
(SETQ \IP.LOCAL.NETWORKS (bind NDB for NET.AND.TYPE in (fetch (IPINIT LOCAL.NETWORKS)
of \IP.DEFAULT.CONFIGURATION)
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)))))
(T (COND
((EQLENGTH \IP.LOCAL.ADDRESSES 1)
(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)))
((NULL \IP.LOCAL.NETWORKS)
(SHOULDNT "Error in IP init file. \IP.LOCAL.NETWORKS is not specified"))
(T (SHOULDNT
"Error in IP init file. \IP.LOCAL.NETWORKS and \IP.LOCAL.ADDRESSES do not correlate.")))))
(SETQ \IPFLG T)
(\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.IP))
(\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.AR))
(\IP.ADD.PROTOCOL \ICMP.PROTOCOL (FUNCTION TRUE)
(FUNCTION NILL)
(FUNCTION \ICMP.INPUT))
(COND
(PROC (RESTART.PROCESS PROC))
(T (ADD.PROCESS (QUOTE (\IPLISTENER))
(QUOTE RESTARTABLE)
(QUOTE SYSTEM)
(QUOTE AFTEREXIT)
\IP.READY.EVENT)))
(SETQ \IP.READY T)
(NOTIFY.EVENT \IP.READY.EVENT))))
(\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)))))))
)
(* * 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 )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \IP.LOCAL.ADDRESSES)
)
(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))))
(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))))
)
(DEFINEQ
(\HANDLE.RAW.IP
(LAMBDA (IP TYPE) (* ejs: "26-Jun-85 14:18")
(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 (QUOTE GET)
IPTRACEFILE "[Packet dropped--bad IP header checksum]"))
(\RELEASE.ETHERPACKET IP))
((ZEROP (add (ffetch (IP IPTIMETOLIVE) of IP)
-1))
(\ICMP.TIME.EXCEEDED IP \ICMP.TRANSIT.TIME.EXCEEDED))
((\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)
(PRINTPACKET IP (QUOTE GETFRAGMENT)
IPTRACEFILE NIL T))
(T (PRIN1 "+" IPTRACEFILE)))))
(\IP.HAND.TO.PROTOCOL IP))))
(T (COND
(IPTRACEFLG (COND
((EQ IPTRACEFLG T)
(PRINTPACKET IP (QUOTE GET)
IPTRACEFILE NIL T))
(T (PRIN1 "+" IPTRACEFILE)))))
(\IP.HAND.TO.PROTOCOL IP)))))
(RETURN T))))
(\FORWARD.IP
(LAMBDA (IP) (* ejs: "26-Dec-84 18:06")
(\RELEASE.ETHERPACKET IP)))
(\IP.LOCAL.DESTINATION
(LAMBDA (IP) (* ejs: "21-Jun-85 18:25")
(* * Return T if IP packet is destined for us)
(LET ((DESTADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP))
(LOCALNETADDRESS (fetch NDBIPNET# of (fetch EPNETWORK of IP))))
(COND
((EQ 0 DESTADDRESS)
NIL)
((MEMBER DESTADDRESS \IP.LOCAL.ADDRESSES)
T)
((NOT (\IP.LEGAL.ADDRESS DESTADDRESS)) (* Bogus destination address)
NIL)
((EQ 0 (\IPNETADDRESS DESTADDRESS)) (* Source doesn't know its network?)
(SETQ DESTADDRESS (replace (IP IPDESTINATIONADDRESS) of IP
with (LOGOR (LLSH LOCALNETADDRESS (SELECTQ (INTEGERLENGTH
LOCALNETADDRESS)
(8 24)
(16 16)
(24 8)
0))
DESTADDRESS)))
(COND
((AND (\IP.BROADCAST.ADDRESS DESTADDRESS)
(EQ LOCALNETADDRESS (\IPNETADDRESS DESTADDRESS)))
T)
((MEMBER DESTADDRESS \IP.LOCAL.ADDRESSES)
T)))
((AND (\IP.BROADCAST.ADDRESS DESTADDRESS)
(EQ LOCALNETADDRESS (\IPNETADDRESS DESTADDRESS)))
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: " 2-Jan-85 20:23")
(PROG ((PROTOCOL (ffetch (IP IPPROTOCOL) of IP))
PROTOCOLCHAIN IPSOCKET)
(COND
((NOT (SETQ PROTOCOLCHAIN (\IP.FIND.PROTOCOL PROTOCOL \IP.PROTOCOLS)))
(\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) (* MPL " 2-Jun-85 20:05")
(COND
((OR (NOT (ZEROP (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)
(* ejs: " 3-Jun-85 02:29")
(* * Find an existing protocol, or create a new one, and return the socket chain head)
(CAR (OR (SOME \IP.PROTOCOLS (FUNCTION (LAMBDA (SOCKET)
(EQ (fetch (IPSOCKET PROTOCOL) of SOCKET)
PROTOCOL))))
(push \IP.PROTOCOLS (create IPSOCKET
PROTOCOL ← PROTOCOL
IPSDESTSOCKETCOMPAREFN ← SOCKETCOMPAREFN
IPSINPUTFN ←(OR INPUTFN (FUNCTION \IP.DEFAULT.INPUTFN))
IPSNOSOCKETFN ←(OR NOSOCKETFN (FUNCTION
\IP.DEFAULT.NOSOCKETFN))
IPSICMPFN ←(OR ICMPFN (FUNCTION \RELEASE.ETHERPACKET))))))))
(\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) (* ejs: "28-Dec-84 19:54")
(OR PROTOCOLCHAIN (SETQ PROTOCOLCHAIN (\IP.FIND.PROTOCOL (ffetch (IP IPPROTOCOL) of IP))))
(bind RESULT while PROTOCOLCHAIN do (COND
((SETQ RESULT (APPLY* (ffetch (IPSOCKET
IPSDESTSOCKETCOMPAREFN)
of PROTOCOLCHAIN)
IP PROTOCOLCHAIN))
(RETURN (COND
((NEQ RESULT T)
RESULT)
(T PROTOCOLCHAIN))))
(T (SETQ PROTOCOLCHAIN (ffetch (IPSOCKET IPSLINK)
of PROTOCOLCHAIN)))))))
(\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)
(* ejs: "27-Dec-84 11:28")
(* * Open a new socket for a protocol. The last three fns default to those specified when the protocol was enabled)
(PROG ((MasterSocket (\IP.FIND.PROTOCOL PROTOCOL))
OldSocket NewSocket)
(RETURN (COND
((type? IPSOCKET MasterSocket)
(COND
((SETQ OldSocket (\IP.FIND.SOCKET SOCKET MasterSocket))
(COND
(NOERRORFLG OldSocket)
(T (ERROR "Attempt to open an existing socket" OldSocket))))
(T (SETQ NewSocket (create IPSOCKET
IPSLINK ←(fetch (IPSOCKET IPSLINK) of MasterSocket)
IPSOCKET ← SOCKET
PROTOCOL ← PROTOCOL
IPSDESTSOCKETCOMPAREFN ←(OR DESTSOCKETCOMPAREFN
(fetch (IPSOCKET
IPSDESTSOCKETCOMPAREFN)
of MasterSocket))
IPSNOSOCKETFN ←(OR NOSOCKETFN (fetch (IPSOCKET
IPSNOSOCKETFN)
of MasterSocket))
IPSINPUTFN ←(OR INPUTFN (fetch (IPSOCKET
IPSINPUTFN)
of MasterSocket))))
(replace (IPSOCKET IPSLINK) of MasterSocket with NewSocket)
NewSocket))))))))
(\IP.CLOSE.SOCKET
(LAMBDA (SOCKET PROTOCOL NOERRORFLG) (* ejs: " 3-Feb-85 22:57")
(* * Close the given socket. SOCKETCHAIN defaults as necessary. Call this only after the higher level protocol has
finished doing its closing operations)
(bind (SOCKETCHAIN ←(\IP.FIND.PROTOCOL PROTOCOL)) while SOCKETCHAIN
do (COND
((AND (fetch (IPSOCKET IPSLINK) of SOCKETCHAIN)
(EQ SOCKET (fetch (IPSOCKET IPSOCKET) of (fetch (IPSOCKET IPSLINK) of SOCKETCHAIN)))
)
(replace (IPSOCKET IPSLINK) of SOCKETCHAIN with (fetch (IPSOCKET IPSLINK)
of (fetch (IPSOCKET IPSLINK)
of SOCKETCHAIN)))
(RETURN))
(T (SETQ SOCKETCHAIN (fetch (IPSOCKET IPSLINK) of SOCKETCHAIN))))
finally (COND
((AND (NOT SOCKETCHAIN)
(NOT NOERRORFLG))
(ERROR "Socket not found" SOCKET))))))
)
(* * Fragmentation Handling)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(RECORD AssemblyRecord (Packet FirstHole Timeout)
Packet ←(\ALLOCATE.ETHERPACKET)
FirstHole ← 0)
(RECORD FragmentRecord (Start Length LastFragment))
]
(* END EXPORTED DEFINITIONS)
)
(RPAQ? \IP.FRAGMENTS )
(RPAQ? \IP.FRAGMENT.NET )
(RPAQ? \IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock"))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \IP.FRAGMENTS \IP.FRAGMENT.NET \IP.FRAGMENT.LOCK)
)
(DEFINEQ
(\HANDLE.RAW.IP.FRAGMENT
(LAMBDA (IP) (* ejs: "28-Dec-84 09:36")
(* * Handle an IP packet fragement. Return NIL if this packet does not complete a fragment, else return the newly
completed packet as an unfragmented IP packet)
(PROG ((FragmentLst (\IP.FIND.MATCHING.FRAGMENTS IP)))
(RETURN (COND
(FragmentLst (\IP.ADD.FRAGMENT FragmentLst IP))
(T (\IP.NEW.FRAGMENT.LST IP)
NIL))))))
(\IP.NEW.FRAGMENT.LST
(LAMBDA (IP) (* ejs: "27-Dec-84 10:26")
(* * Add a new fragment list to the fragment discrimination net.)
(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))
SubLst NewFragList AssemblyPacket AssemblyRecord)
(SETQ AssemblyRecord (create AssemblyRecord
Timeout ←(IPLUS (CLOCK 0)
(ITIMES 1000 (ffetch (IP IPTIMETOLIVE)
of IP)))))
(SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord))
(SETQ NewFragList
(BQUOTE (, ID (, Source (, Protocol (, Dest , AssemblyRecord ,
(create FragmentRecord
Start ←(LLSH (ffetch (IP IPFRAGMENTOFFSET)
of IP)
3)
Length ←(IDIFFERENCE
(ffetch (IP IPTOTALLENGTH) of IP)
(LLSH (ffetch (IP IPHEADERLENGTH)
of IP)
2)))))))))
(COND
((SETQ SubLst (for IDChain in \IP.FRAGMENT.NET thereis (EQ (CAR IDChain)
ID)))
(COND
((SETQ SubLst (for SourceChain in (CDR SubLst) thereis (EQP (CAR SourceChain)
Source)))
(COND
((SETQ SubLst (for ProtocolChain in (CDR SubLst) thereis (EQ (CAR ProtocolChain)
Protocol)))
(COND
((SETQ SubLst (for DestChain in (CDR SubLst) thereis (EQP (CAR DestChain)
Dest)))
(ERROR
"Tried to add a fragment list to the discrimination net and the same one already exists!"
NewFragList))
(T (push (CDR SubLst)
(CADDDR NewFragList)))))
(T (push (CDR SubLst)
(CADDR NewFragList)))))
(T (push (CDR SubLst)
(CADR NewFragList)))))
(T (push \IP.FRAGMENT.NET NewFragList)))
(\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER AssemblyPacket IP)
(push \IP.FRAGMENTS (CADDDR NewFragList)))))
(\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER
(LAMBDA (Packet Fragment) (* ejs: "27-Dec-84 19:52")
(* * 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
(LLSH (fetch (IP IPHEADERLENGTH) of Fragment)
2))))
(\IP.ADD.FRAGMENT
(LAMBDA (FragmentLst NewIP) (* ejs: "27-Dec-84 14:16")
(* * 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)
(PROG ((AssemblyRecord (CAR FragmentLst))
(NewFrag (create FragmentRecord
Start ←(LLSH (ffetch (IP IPFRAGMENTOFFSET) of NewIP)
3)
Length ←(IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of NewIP)
(LLSH (ffetch (IP IPHEADERLENGTH) of NewIP)
2))))
(Fragments (CDR FragmentLst))
Status NextHole AssemblyPacket)
(SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord))
(replace (AssemblyRecord Timeout) of AssemblyRecord
with (IMAX (IPLUS (CLOCK 0)
(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 Fragments))
(* Earlier than the earliest existing fragment)
(push (CDR FragmentLst)
NewFrag)
(SETQ Fragments (CDR FragmentLst))
(QUOTE INSERTED.FRAGMENT))
((EQ (fetch (FragmentRecord Start) of NewFrag)
(fetch (FragmentRecord Start) of Fragments))
(* Duplicate of earliest fragment)
(QUOTE 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 (QUOTE DUPLICATE))
T)
((ILESSP (fetch (FragmentRecord Start) of NewFrag)
(fetch (FragmentRecord Start) of (CADR OldFragTail)))
(* Found the hole to insert)
T))
finally (COND
(Status (RETURN Status))
((CDR OldFragTail)
(push (CDR OldFragTail)
NewFrag)
(RETURN (QUOTE INSERTED.FRAGMENT))))))))
(RETURN
(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 "Screwup in reassembly!" NewFrag))
((EQ (fetch (FragmentRecord Start) of NewFrag)
(fetch (AssemblyRecord FirstHole) of AssemblyRecord))
(COND
((AND (NOT (bind End 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)
T))))
(NOT (ffetch (IP IPMOREFRAGMENTS) of NewIP)))
(\IP.DELETE.FRAGMENT FragmentLst)
AssemblyPacket)))))
NIL)
(\RELEASE.ETHERPACKET NewIP))))))
(\IP.FIND.MATCHING.FRAGMENTS
(LAMBDA (IP) (* ejs: "27-Dec-84 10:46")
(* * Find the list of fragments matching this IP packet, or NIL if none exists)
(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))
SubLst)
(RETURN (COND
((SETQ SubLst (for IDChain in \IP.FRAGMENT.NET thereis (EQ (CAR IDChain)
ID)))
(COND
((SETQ SubLst (for SourceChain in (CDR SubLst) thereis (EQP (CAR SourceChain)
Source)))
(COND
((SETQ SubLst (for ProtocolChain in (CDR SubLst)
thereis (EQ (CAR ProtocolChain)
Protocol)))
(COND
((SETQ SubLst (for DestChain in (CDR SubLst)
thereis (EQP (CAR DestChain)
Dest)))
(CDR SubLst)))))))))))))
(\IP.FRAGMENTED.PACKET
(LAMBDA (IP) (* ejs: "27-Dec-84 10:47")
(* * Return T if IP packet is a fragment)
(NOT (AND (ZEROP (ffetch (IP IPMOREFRAGMENTS) of IP))
(ZEROP (ffetch (IP IPFRAGMENTOFFSET) of IP))))))
(\IP.CHECK.REASSEMBLY.TIMEOUTS
(LAMBDA NIL (* ejs: " 3-Jun-85 02:48")
(* * Kill any fragments in the process of reassembly if their timeout has expired. Report timeout via ICMP)
(for Fragment in \IP.FRAGMENTS when (IGREATERP (CLOCK 0)
(fetch (AssemblyRecord Timeout)
of (CAR Fragment)))
do (\ICMP.TIME.EXCEEDED (fetch (AssemblyRecord Packet) of (CAR Fragment))
\ICMP.FRAGMENT.TIME.EXCEEDED)
(\IP.DELETE.FRAGMENT Fragment))))
(\IP.DELETE.FRAGMENT
(LAMBDA (FragmentLst) (* ejs: "27-Dec-84 10:51")
(* * Delete the fragment record in FragmentLst from both the fragment discrimination net and the linear list of
fragment records)
(PROG ((IP (fetch (AssemblyRecord Packet) of (CAR FragmentLst)))
Source Dest Protocol ID SubLst Backpointers)
(SETQ Source (ffetch (IP IPSOURCEADDRESS) of IP))
(SETQ Dest (ffetch (IP IPDESTINATIONADDRESS) of IP))
(SETQ Protocol (ffetch (IP IPPROTOCOL) of IP))
(SETQ ID (ffetch (IP IPID) of IP))
(COND
((SETQ SubLst (for IDChain in \IP.FRAGMENT.NET thereis (EQ (CAR IDChain)
ID)))
(push Backpointers SubLst)
(COND
((SETQ SubLst (for SourceChain in (CDR SubLst) thereis (EQP (CAR SourceChain)
Source)))
(push Backpointers SubLst)
(COND
((SETQ SubLst (for ProtocolChain in (CDR SubLst) thereis (EQ (CAR ProtocolChain)
Protocol)))
(push Backpointers SubLst)
(COND
((SETQ SubLst (for DestChain in (CDR SubLst) thereis (EQP (CAR DestChain)
Dest)))
(DREMOVE SubLst (CAR Backpointers))))))))))
(while Backpointers
do (COND
((EQLENGTH (CAR Backpointers)
1)
(DREMOVE (CAR Backpointers)
(CADR Backpointers))))
(pop Backpointers))
(SETQ \IP.FRAGMENTS (DREMOVE FragmentLst \IP.FRAGMENTS))
(\RELEASE.ETHERPACKET IP))))
)
(* * 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) (* ejs: "28-Dec-84 19:48")
(* * Process option fields in IP header. Return T if OK, else handle internally needed actions like redirection or
reporting of parameter problems)
(PROG ((OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
(INDEX 0)
(RESULT T)
REROUTING OPTION)
(while (NOT (NUMBERP RESULT)) until (EQ INDEX (IDIFFERENCE (UNFOLD (fetch (IP
IPHEADERLENGTH)
of IP)
BYTESPERCELL)
\IPOVLEN))
do (SELECTC (SETQ OPTION (LDB (BYTE 5 0)
(\GETBASEBYTE OPTIONSSTART INDEX)))
(IPOPT.END (GO $$OUT))
(IPOPT.NOP (add INDEX 1))
(IPOPT.SECURITY (add INDEX 1))
(IPOPT.LSRR (COND
(REROUTING (SETQ RESULT INDEX))
((EQ (SETQ RESULT (\IP.OPTION.STRICT.SOURCE.ROUTE IP INDEX))
(QUOTE REROUTE))
(SETQ REROUTING T)
(add INDEX (\GETBASEBYTE OPTIONSSTART (ADD1 INDEX))))))
(IPOPT.SSSR (COND
(REROUTING (SETQ RESULT INDEX))
((EQ (SETQ RESULT (\IP.OPTION.STRICT.SOURCE.ROUTE IP INDEX))
(QUOTE REROUTE))
(SETQ REROUTING T)
(add INDEX (\GETBASEBYTE OPTIONSSTART (ADD1 INDEX))))))
(IPOPT.RECRT (SETQ RESULT (\IP.OPTION.RECORD.ROUTE IP INDEX))
(add INDEX (\GETBASEBYTE OPTIONSSTART (ADD1 INDEX))))
(IPOPT.STREAMID (add INDEX 1))
(IPOPT.TIMESTAMP (\IP.OPTION.TIMESTAMP IP INDEX)
(add INDEX (\GETBASEBYTE OPTIONSSTART (ADD1 INDEX))))
(ERROR "Unknown option code" OPTION)))
(RETURN (COND
((NUMBERP RESULT)
(\ICMP.PARAMETER.PROBLEM IP (IPLUS \IPOVLEN RESULT))
NIL)
(T RESULT))))))
)
(* * Packet Transmission and routing)
(RPAQ? \IP.ROUTING.TABLE (CONS))
(RPAQ? \IP.DEFAULT.GATEWAY )
(RPAQ? \IP.LOCAL.NETWORKS )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS)
)
(DEFINEQ
(\IP.SETUPIP
(LAMBDA (IP DESTHOST ID SOCKET REQUEUE) (* ejs: "27-Dec-84 18:55")
(* * Initialize IP header of packet. REQUEUE defaults to FREE)
(replace (IP IPVERSION) of IP with \IP.PROTOCOLVERSION)
(replace (IP IPHEADERLENGTH) of IP with (FOLDHI \IPOVLEN BYTESPERCELL))
(replace (IP IPTOTALLENGTH) of IP with \IPOVLEN)
(replace (IP IPID) of IP with ID)
(replace (IP IPMOREFRAGMENTS) of IP with 0)
(replace (IP IPFRAGMENTOFFSET) of IP with 0)
(replace (IP IPTIMETOLIVE) of IP with \IP.DEFAULT.TIME.TO.LIVE)
(replace (IP IPPROTOCOL) of IP with (fetch (IPSOCKET PROTOCOL) of SOCKET))
(replace (IP IPSOURCEADDRESS) of IP with (CAR \IP.LOCAL.ADDRESSES))
(replace (IP IPDESTINATIONADDRESS) of IP with DESTHOST)
(replace EPREQUEUE of IP with (OR REQUEUE (QUOTE FREE)))
IP))
(\IP.TRANSMIT
(LAMBDA (IP) (* MPL " 2-Jun-85 20:35")
(* * Sends an IP packet, after first computing the IP header checksum)
(PROG (NDB)
(SETQ IP (\DTEST IP (QUOTE 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]"))
(QUOTE AlreadyQueued))
((NOT (SETQ NDB (\IP.ROUTE.PACKET IP)))
(AND IPTRACEFLG (PRINTPACKET IP (QUOTE PUT)
IPTRACEFILE "[Put fails--no routing]"))
(\REQUEUE.ETHERPACKET IP)
(QUOTE 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 (QUOTE PUT)
IPTRACEFILE))
(T (PRIN1 "!" IPTRACEFILE)))))
(TRANSMIT.ETHERPACKET NDB IP)
NIL))))))
(\IP.ROUTE.PACKET
(LAMBDA (IP READONLY) (* wc " 4-Jun-85 15:54")
(* 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 PDH ROUTE NDB EPTYPE)
(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 DESTNET (\IPNETADDRESS DESTADDRESS))))
(* * First see if the destination network is one of our local networks)
(COND
((SETQ NDB (CDR (SASSOC DESTNET \IP.LOCAL.NETWORKS)))
(* * 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)
(\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 (CDR (SASSOC DESTNET \IP.ROUTING.TABLE))
\IP.DEFAULT.GATEWAY))
(* * We've go 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))))
(\IP.LOCATE.NET
(LAMBDA (ADDRESS DONTPROBE) (* ejs: " 2-Jan-85 19:45")
(PROG ((NET (\IPNETADDRESS ADDRESS)))
(RETURN (COND
(\10MBLOCALNDB (for (PREVTAIL ← \IP.ROUTING.TABLE) bind TAIL DATA
while (LISTP (SETQ TAIL (CDR PREVTAIL)))
do (SETQ DATA (CAR TAIL))
(COND
((OR (IEQP NET (fetch (ROUTING RTNET#) of DATA))
(AND (EQ 0 NET)
(EQ 0 (fetch (ROUTING RTHOPCOUNT) of DATA))))
(COND
((NEQ PREVTAIL \IP.ROUTING.TABLE)
(* Promote this entry to the front, so we find it
faster in the future)
(FRPLACD \IP.ROUTING.TABLE
(PROG1 TAIL (FRPLACD PREVTAIL (CDR TAIL))
(FRPLACD TAIL (CDR \IP.ROUTING.TABLE)
)))))
(RETURN (AND (ILESSP (fetch RTHOPCOUNT of DATA)
\RT.INFINITY)
DATA))))
(SETQ PREVTAIL TAIL)))
((for RT in \IP.ROUTING.TABLE thereis (AND (EQ (fetch (ROUTING RTNET#)
of RT)
NET)
(EQ (fetch (ROUTING RTTIMER)
of RT)
(LDB (BYTE 8 16)
ADDRESS)))))
(T (for RT in \IP.ROUTING.TABLE thereis (EQ (fetch (ROUTING RTNET#) of RT)
NET))))))))
)
(* * 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))))
)
(PUTPROPS \CANONICAL.HOSTNAME READVICE (NIL (AROUND NIL (COND ((NUMBERP NAME)
(IPHOSTNAME NAME))
((IPHOSTADDRESS NAME)
NAME)
(T *)))))
(READVISE \CANONICAL.HOSTNAME)
(PUTPROPS TCPLLIP COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (17147 26267 (DODIP.HOSTP 17157 . 17325) (IPHOSTADDRESS 17327 . 17796) (IPHOSTNAME 17798
. 18021) (IPTRACE 18023 . 18508) (IPTRACEWINDOW.BUTTONFN 18510 . 18911) (PRINTIP 18913 . 20722) (
PRINTIPDATA 20724 . 21370) (\IPADDRESSCLASS 21372 . 21863) (\IPHOSTADDRESS 21865 . 22376) (
\IPNETADDRESS 22378 . 22885) (\IP.ADDRESS.TO.STRING 22887 . 23267) (\IP.BROADCAST.ADDRESS 23269 .
23729) (\IP.LEGAL.ADDRESS 23731 . 24182) (\IP.MAKE.BROADCAST.ADDRESS 24184 . 24568) (\IP.PRINT.ADDRESS
24570 . 25092) (\IP.READ.STRING.ADDRESS 25094 . 26265)) (26631 34156 (STOPIP 26641 . 26957) (\IPINIT
26959 . 33498) (\IPLISTENER 33500 . 34154)) (37547 42828 (\HANDLE.RAW.IP 37557 . 39407) (\FORWARD.IP
39409 . 39553) (\IP.LOCAL.DESTINATION 39555 . 40819) (\IPCHECKSUM 40821 . 42268) (\IP.CHECKSUM.OK
42270 . 42452) (\IP.SET.CHECKSUM 42454 . 42826)) (43331 50387 (\IP.HAND.TO.PROTOCOL 43341 . 44089) (
\IP.DEFAULT.INPUTFN 44091 . 44648) (\IP.DEFAULT.NOSOCKETFN 44650 . 45055) (\IP.ADD.PROTOCOL 45057 .
45857) (\IP.DELETE.PROTOCOL 45859 . 46391) (\IP.FIND.PROTOCOL 46393 . 46730) (\IP.FIND.PROTOCOL.SOCKET
46732 . 47402) (\IP.FIND.SOCKET 47404 . 47964) (\IP.OPEN.SOCKET 47966 . 49376) (\IP.CLOSE.SOCKET
49378 . 50385)) (50961 62439 (\HANDLE.RAW.IP.FRAGMENT 50971 . 51492) (\IP.NEW.FRAGMENT.LST 51494 .
53793) (\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER 53795 . 54236) (\IP.ADD.FRAGMENT 54238 . 58629) (
\IP.FIND.MATCHING.FRAGMENTS 58631 . 59745) (\IP.FRAGMENTED.PACKET 59747 . 60070) (
\IP.CHECK.REASSEMBLY.TIMEOUTS 60072 . 60671) (\IP.DELETE.FRAGMENT 60673 . 62437)) (63324 65276 (
\IP.PROCESS.OPTIONS 63334 . 65274)) (65533 72619 (\IP.SETUPIP 65543 . 66556) (\IP.TRANSMIT 66558 .
67945) (\IP.ROUTE.PACKET 67947 . 71096) (\IP.LOCATE.NET 71098 . 72617)) (72670 75931 (\IP.APPEND.BYTE
72680 . 73297) (\IP.APPEND.CELL 73299 . 74483) (\IP.APPEND.STRING 74485 . 75001) (\IP.APPEND.WORD
75003 . 75929)))))
STOP