Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10 5/3/83; site k.cs.cmu.edu
Path: utzoo!watmath!clyde!burl!ulysses!mhuxr!mhuxn!ihnp4!qantel!lll-crg!seismo!rochester!pt.cs.cmu.edu!k.cs.cmu.edu!tim
From: tim@k.cs.cmu.edu (Tim Maroney)
Newsgroups: net.sources.mac
Subject: Macintosh Internet Protocols (4 of 12)
Message-ID: <663@k.cs.cmu.edu>
Date: Tue, 26-Nov-85 04:55:42 EST
Article-I.D.: k.663
Posted: Tue Nov 26 04:55:42 1985
Date-Received: Fri, 29-Nov-85 09:25:43 EST
Organization: Carnegie-Mellon University, Networking
Lines: 1858

echo extracting net/ip_lib.text...
cat >net/ip_lib.text <<'!E!O!F!'
{$X-}
{$M+}
{$R-}
{$0V-}
{$D-}
{$DECL DEBUG}
{$SETC DEBUG := false}
UNIT IP_Lib;

{ Please note the copyright notice in the file "copyright/notice" }

INTERFACE

{$L-}

   USES {$U-}
      {$U Obj-Memtypes	  } Memtypes,
      {$U Obj-QuickDraw	  } QuickDraw,
      {$U Obj-OSIntf	  } OSIntf,
      {$U Obj-ToolIntf	  } ToolIntf,
      {$U Obj-PackIntf	  } PackIntf,
      {$U Obj-ABPasIntf	  } ABPasIntf,
      {$U net-err_lib	  } Err_Lib,
      {$U net-Task_Lib	  } Task_Lib,
      {$U net-Timer_Lib	  } Timer_Lib,
      {$U net-cust_lib	  } Cust_Lib,
      {$U net-calls	  } Call_Lib;

{$L+}

CONST
    AB_IP_Socket = 72; { Just some socket that everyone agrees on }

TYPE

{ The buffer organization is somewhat intertwined with the queue organization.
	Each buffer is in a queue, either the free queue or the used queue
	(or the buffer is currently being used by a user program or the
	interrupt level routines, in which case it does not appear in a
	queue). When a buffer is in a queue, it has a pointer to the next
	buffer in the queue. If there is no next buffer, its pointer points
	at nullbuf. Also, each buffer knows its own length. }

    Packet = ^ net_buf;

    net_buf = PACKED RECORD
	nb_elt: Packet;	        { queue link }
	nb_type: QTypes;        { for Mac queues }
	nb_buff: PTR;	        { The buffer }
	nb_tstamp: LongInt;     { packet timestamp }
	nb_len: Integer;        { Length of buffer }
	END;

{ Internet connection information }

    ip_iob =  RECORD
	c_prot: byte;		     { protocol }
	c_handle: ProcPtr;      { int returning procedure - see below: }
	END;

    IPCONN = ^ip_iob;	        { The IP connection type }

    in_name = LongInt;

    Ref_in_name = ^ in_name;

    ip = PACKED RECORD
	ip_ver: 0..15;	        { Header version }
	ip_ihl: 0..15;	        { Internet header length in 32 bit words }
	ip_tsrv: byte;	        { Type of service }
	ip_len: integer;        { Total packet length including header }
	ip_id: integer;	        { ID for fragmentation }
	ip_flgs: 0..7;	        { flags }
	ip_foff: 0..8191;       { Fragment offset }
	ip_time: byte;	        { Time to live (secs) }
	ip_prot: byte;	        { protocol }
	ip_chksum: integer;     { Header checksum }
	ip_src: in_name;        { Source name }
	ip_dest: in_name;       { Destination name }
	END;

    Ref_IP = ^ IP;

{ IP header and internet names }

      in_lst_type = PACKED RECORD
		in_net: byte;
		in_nets: byte;
		in_netss: byte;
		in_host: byte;
		END;

       _ipname = PACKED RECORD CASE Integer OF
	       0: (in_lname: in_name);
	       1: (in_lst: in_lst_type);
	       END;

CONST
    AB_IP = 22;	   { Internet Protocol - unofficial number for debugging     }

	IP_PROTOCOL = 0;
	CHAOS	    = 1;
	PUP	    = 2;
	SLP	    = 3;
	ADR	    = 4;    { Dave Plummer's Address Resolution Protocol }

    IPHSIZ  = sizeof(ip)    { internet header size };
    INETLEN =	    576	    { maximum size of internet packet (bytes) };

	DSTNET	        = 0;
	DSTHOST	        = 1;
	DSTPROT	        = 2;
	DSTPORT	        = 3;
	DSTFRAG	        = 4;
	DSTSRC	        = 5;

VAR
	LocalIPAddress, GWIPAddress: in_name;
	DefaultHost:STR255;
	Use_AB: Boolean;
	ip_queue:QHdr;
	IPStack:INTEGER;

CONST
	Num_Name_Servers =      1;      { Number of name servers for which
					  we have addresses }
	Last_NS_Index	 =      0;      { = Num_Name_Servers - 1 }

VAR
	NSIPAddress: ARRAY [0..Last_NS_Index] OF in_name;

CONST
	Num_Time_Servers =      1;      { Number of time servers for which
					  we have addresses }
	Last_TS_Index	 =      0;      { = Num_Time_Servers - 1 }

VAR
	TSIPAddress: ARRAY [0..Last_TS_Index] OF in_name;

CONST
	Max_User_Name = 8;
VAR
	User_Name: STRING[Max_User_Name];

FUNCTION in_open(prot:byte; handler: ProcPtr):IPCONN;
FUNCTION in_alloc(datalen:Integer; optlen:Integer):PACKET;
FUNCTION in_write(conn: IPCONN; p:PACKET; datalen:Integer; fhost: in_name):INTEGER;
PROCEDURE in_free(p: PACKET);
FUNCTION in_more: Boolean;
PROCEDURE in_close;
FUNCTION inverify(p:Packet):Boolean;

PROCEDURE cvt_inaddr(fhost: in_name; VAR s:STR255);
PROCEDURE indemux(Fake:PTR);
PROCEDURE in_init;
FUNCTION in_data(pip:Ref_IP): PTR;
FUNCTION in_head(ppkt:Packet): Ref_IP;
FUNCTION CkSum(BufPtr:PTR; Count:Integer): Integer;
FUNCTION in_mymach(host: in_name): in_name;
PROCEDURE in_stats;

VAR
	freeq:QHdr;
	CurW_Hdl: ABRecHandle;

IMPLEMENTATION

{ Functions from ICMP_LIB }

FUNCTION icmp_destun(host: in_name; ip: Ref_IP; Packet_type: Integer):Integer;
	external;

PROCEDURE inroute(host: in_name; hop1: Ref_in_name); external;

CONST

{ Some useful definitions }

	Cur_IP_VER  = 4		        { internet version };
	IP_IHL_Off  = 5		        { IN header length in longwords };
	IP_TSRV = 0		        { default type of service };
	IP_ID   = 0		        { kernel fills in IN id };
	NO_IP_FLGS = 0		        { no fragmentation yet };
	Cur_IP_FOFF = 0		        { " " " };
	IP_TIME = 255		        { maximum time to live };
	FirstIPXSUM  = 0	        { initial checksum };
	FirstIPLEN = sizeof(ip)	        { internet header length };
	NBUFINIT        = 6;
	LBUFINIT        = 600;

{ The following goodly macros will have to be changed to functions }

FUNCTION in_head(ppkt:Packet): Ref_IP;
BEGIN
   in_head := {(struct ip *)} POINTER(ORD4( ppkt^.nb_buff ));
END;

FUNCTION in_data(pip:Ref_IP): PTR;
BEGIN
    { Note: This must be changed because of bit packing in the header }
    in_data := { (char *) } POINTER(ORD4(pip) + BitSL(pip^.ip_ihl,2));
END;

FUNCTION in_options(pip:Ref_IP): PTR;
BEGIN
    in_options := { (char *) } POINTER( ORD4(pip) + BitSL(IP_IHL_Off,2) );
END;

FUNCTION in_optlen(pip: Ref_IP):Byte;
BEGIN
  in_optlen := BitSL(pip^.ip_ihl - IP_IHL_Off,2);
END;

FUNCTION CkSum(BufPtr:PTR; Count:Integer): Integer; external;

{$IFC DEBUG}
{ This function dumps an internet packet to the screen. It uses some of the
	screen handling functions to help in this tedious chore. }

PROCEDURE in_dump(p:PACKET);
VAR
	i,j : Integer;
	pip: Ref_IP;
	data: PTR;
	xsum, osum: integer;
	out: STR255;
BEGIN
	pip := in_head(p);

	data := p^.nb_buff;

	WriteLn('Packet address = ',ORD4(p));
(*
	FOR i := 0 to 6 DO BEGIN
		WriteLong(ord4(data));Write(': ');
		FOR j := 0 to 23 DO BEGIN
			Num2HexStr(data^,out); out := copy(out,3,2);
			Write(out);
			data := POINTER(ORD4(Data) + 1); { Print a word at a time }
			END;
		WriteLn('');
		END;
*)
	{ Display header info in reasonable form }

	WriteLn('Header length = ',pip^.ip_ihl,
		', IP Length = ',{ bswap } (pip^.ip_len),
		', Total Length = ',p^.nb_len);

	WriteLn('Version = ',pip^.ip_ver,
		', Type of Ser = ',pip^.ip_tsrv,
		', tProtocol = ',pip^.ip_prot,
		', Time To Live = ',pip^.ip_time);

	WriteLn('Frag Offset = ',pip^.ip_foff,', Flags = ',pip^.ip_flgs);

	Write('Source = ');
	out_inaddr(pip^.ip_src);
	Write(', Destin = ');
	out_inaddr(pip^.ip_dest);
	WriteLn('');

	WriteLn('ID = ',pip^.ip_id);

	WriteLn('Checksum = ',pip^.ip_chksum);

	osum := pip^.ip_chksum;
	pip^.ip_chksum := 0;
	xsum := BitNOT(cksum(POINTER(ORD4(pip)), BitSL(pip^.ip_ihl,1)));
	WriteLn('Computed xsum = ',xsum);

	pip^.ip_chksum := osum;
	if (xsum = osum) THEN WriteLn('Checksum is CORRECT.')
			ELSE WriteLn('Checksum is NOT CORRECT.');

END; { End of in_dump }
{$ENDC}

VAR ipdemux:Ref_Task;   { demuxer task address }

{ internet statistics  - all initialized in in_init }
 ipdrop: integer;	        { ip packets dropped }
 ipxsum: integer;	        { ip packets with bad checksums }
 iplen : integer;	        { ip packets with bad lengths }
 ipdest: integer;	        { ip packets with bad destinations }
 ipttl : integer;	        { ip packets with time to live := 0 }
 ipprot: integer;	        { no server for protocol }
 ipver : integer;	        { bad ip version number }
 iprcv : integer;	        { number of ip packets received }
 ipfrag: integer;	        { number of fragments received }
 ipwwop: Integer;	        { Number of times awakened w/o packets }
 ipmulti: Integer;	        { Number of times found > 1 packet on queue }

{ Allocate and internet packet. Has to grunge around with local net header
	sizes to do the right thing. }

FUNCTION in_alloc(datalen:Integer; optlen:Integer):PACKET;
VAR
	p: PACKET;
	pip: Ref_IP;
	len: integer;
	status:OSErr;
BEGIN

	optlen := BitAND((optlen + 3),BitNOT(3));
{       len := (IPHSIZ + optlen + datalen + 1) & ~1;}
	len := (IPHSIZ + optlen + datalen + 1);
	IF Odd(len) THEN len := len - 1;

	if (datalen > INETLEN) THEN BEGIN
{$IFC DEBUG}
		WriteLn('IN_ALLOC: Packet size ',datalen,'is too large.');
{$ENDC}
		in_alloc := NIL;
		exit(in_alloc);
		END;

	p := POINTER(ORD4(freeq.qHead));
	if p <> NIL then begin
		status := dequeue(freeq.qHead,@freeq);
		if status <> noErr then p := NIL;
		end;
	if p = NIL THEN BEGIN
		CantAlloc(StrCvt('IN_ALLOC'),StrCvt('packet'));
		in_alloc := NIL;
		END
	else begin
		pip := in_head(p);
		pip^.ip_ihl := IP_IHL_Off + (optlen DIV 4);
		in_alloc := p;
		end;
END; {End of in_alloc}

{ Free up an internet packet }

PROCEDURE in_free(p: PACKET);
BEGIN
	enqueue(POINTER(ORD4(p)), @freeq);
END;

{ Intialize the internet layer. }

CONST
	LastIPConn = 9;
VAR
	ipsnd: integer;
	uid: integer;

	ipconns: array [0..LastIPConn] of ipconn;	       { demux table }
	nipconns: Integer; { current posn in demux table }

FUNCTION arp_init: Ref_Task; external;
PROCEDURE ip_listen; external;
PROCEDURE listeninit(it:Ref_Task; at:Ref_Task; q:QHdrPtr; fq:QHdrPtr); external;

{$S InitSeg }
PROCEDURE in_init;
VAR     i:INTEGER;
	temp_packet:PACKET;
	CR: CustRecord;
	TempSkt: Byte;
	status:OSErr;
	NBUF: LongInt;		   { # of packet buffers }
	divisor: LongInt;
	LBUF: Integer;		   { size of packet buffers }
BEGIN

{$IFC NOT DEBUG}
	 ReadCustom(@CR);
	 LocalIPAddress := CR.LocalIPAddr;
	 GWIPAddress := CR.GateWIPAddr;
	 NSIPAddress[0] := CR.NameServer;
	 TSIPAddress[0] := CR.TimeServer;
	 User_Name := CR.UserName;
	 Use_AB := CR.UseAB;
	 DefaultHost := CR.DefHost;
{$ENDC}

	nipconns := 0;		        { current posn in demux table }
	ipsnd := 0;
	uid := 1 ;

	{ internet statistics are initialized }
	ipdrop := 0;	        { ip packets dropped }
	ipxsum := 0;	        { ip packets with bad checksums }
	iplen := 0;	        { ip packets with bad lengths }
	ipdest := 0;	        { ip packets with bad destinations }
	ipttl := 0;	        { ip packets with time to live := 0 }
	ipprot := 0;	        { no server for protocol }
	ipver := 0;	        { bad ip version number }
	iprcv := 0;	        { number of ip packets received }
	ipfrag := 0;	        { number of fragments received }
	ipwwop := 0;
	ipmulti := 0;

	{ Create the queue of free packets. Format each packet and add it to
		the tail of the queue }

{$IFC DEBUG}
	WriteLn('About to allocate the packet pool');
{$ENDC}

	divisor := 32768;
	NBUF := ((ORD4(ApplicZone^.bkLim) - ORD4(ApplicZone)) div divisor)
		+ NBUFINIT;
	LBUF := LBUFINIT;	  { size of packet buffers }

	{ Initialize the receive queue }
	ip_queue.qFlags := 0;
	ip_queue.qHead := NIL;
	ip_queue.qTail := NIL;

	{ Initialize the free packet queue }
	freeq.qFlags := 0;
	freeq.qHead := NIL;
	freeq.qTail := NIL;

	FOR i := 0 TO NBUF - 1 DO BEGIN
		temp_packet := POINTER(ORD4(NewPtr(sizeof(Net_Buf))));
		if (temp_packet = NIL) THEN
			Fatal(StrCvt('in_init: can''t make free queue'),false);

		temp_packet^.nb_type := dummyType;
		temp_packet^.nb_tstamp := 0;
		temp_packet^.nb_len := 0;
		temp_packet^.nb_buff := POINTER(ORD4(NewPtr(LBUF)));

		if (temp_packet^.nb_buff = NIL) THEN
	     Fatal(StrCvt('Ran out of packet storage during in_init'),false);

		enqueue(POINTER(ORD4(temp_packet)), @freeq);
		END;

	{ DDP Send handle initialization }
	CurW_Hdl := POINTER(ORD4(NewHandle(ddpSize)));
	CurW_Hdl^^.abResult := noErr;	     { Another write can be done }

	ipdemux := tk_fork(tk_cur, @indemux, IPStack, 'IPDemux',NIL);
	listeninit(ipdemux,arp_init,@ip_queue,@freeq);

	{ Initialize the AB }
	TempSkt := AB_IP_Socket;
	IF DDPOpenSocket(TempSkt,@ip_listen) <> 0 THEN
	    CantConnect(StrCvt('DDPOpenSocket'),StrCvt('socket for Applebus IP'));
END; { end of in_init }

{$S	    }

{ Return true if there are any enqueued, unprocessed packets in system. }

FUNCTION in_more: Boolean;
BEGIN
	in_more := ip_queue.qHead <> NIL;
END;

{ Return the address of our machine relative to a certain foreign host. }

FUNCTION in_mymach(host: in_name): in_name;
BEGIN
	in_mymach := LocalIPAddr;
END; { End of my_mach }

{ Open a protocol connection on top of internet. Protocol information
	necessary for packet demultiplexing; handler is upcalled
	upon receipt of packet. handler is
		int handler(p, len, fhost)
			PACKET p
			int len
			in_name fhost
}

VAR IPConn_Table: ARRAY [0..LastIPConn] of ip_iob;

FUNCTION in_open (prot:byte; handler: ProcPtr):IPCONN;
VAR
	i: integer;
	conn: IPCONN;
BEGIN
	FOR i := 0 to nipconns-1 DO
		IF (ipconns[i]^.c_prot = prot) THEN BEGIN
			in_open := NIL;
			exit(in_open);
			END;

	IF nipconns = LastIPConn + 1 THEN conn := NIL
		ELSE conn := @IPConn_Table[nipconns];

	if (conn = NIL) THEN BEGIN
		in_open := NIL;
		exit(in_open);
		END;
	conn^.c_prot := prot;
	conn^.c_handle := handler;
	ipconns[nipconns] := conn;
	nipconns := nipconns + 1;
	in_open := conn;
END; { end of in_open }

{ Fill in the internet header in the packet p and send the packet through the
	appropriate net interface. This will involve using routing. Packets for
	a certain connection are all routed at connection open time, but some
	facility should be provided to allow for later rerouting. }

PROCEDURE IP2AB(IP: in_name; VAR AB:AddrBlock); external;

FUNCTION in_write(conn: IPCONN; p:PACKET; datalen:Integer; fhost: in_name):INTEGER;
CONST
    CantReachHost = -2;
VAR
	firsthop: in_name;
	pip: Ref_ip;
	len: integer;
	DestAddr: AddrBlock;
	err: OSerr;
BEGIN

	IF (datalen > LBUFINIT) THEN BEGIN
{$IFC DEBUG}
		WriteLn('IN_WRITE: Received a stupid packet length',datalen);
		{ if BCBitAnd(NDEBUG,BUGHALT) THEN HALT; }
{$ENDC}
		in_write := -1;
		exit(in_write);
		END;

{$IFC DEBUG}
	Write('IP sending packet of length ',datalen:1,
	      ' protocol ',conn^.c_prot,' to ');
	out_inaddr(fhost);
	WriteLn('.');
{$ENDC}

	{ perform routing. Have to route on each and every packet going
		out because have to find first hop. }
	inroute(fhost, @firsthop);
	if (firsthop = 0) THEN BEGIN
{$IFC DEBUG}
		Write('IN_WRITE: Couldn''t route packet to host ');
		out_inaddr(fhost);
		WriteLn('.');
{$ENDC}
		in_write := 0;
		exit(in_write);
		END;

{$IFC DEBUG}
	Write('IP packet routed to host ');
	out_inaddr(firsthop);
	WriteLn('.');
{$ENDC}

	pip := in_head(p);
	pip^.ip_ver := Cur_IP_VER;
	pip^.ip_time := IP_TIME;

	pip^.ip_flgs := NO_IP_FLGS;
	pip^.ip_foff := Cur_IP_FOFF;

	pip^.ip_id := { bswap } (uid);
	uid := uid + 1;

	pip^.ip_chksum := FirstIPXSUM;
	pip^.ip_src := LocalIPAddress;
	pip^.ip_dest := fhost;

	len := BitSL(pip^.ip_ihl,2) + datalen;

	pip^.ip_len := { bswap } (len);

	pip^.ip_tsrv := 0;
	pip^.ip_prot := conn^.c_prot;

	{ It's CHECKSUM time!! }
	pip^.ip_chksum := BitNOT(cksum(POINTER(ORD4(pip)), BitSL(pip^.ip_ihl,1)));
	ipsnd := ipsnd + 1;

{$IFC DEBUG}
	WriteLn('About to call the network to send');
{$ENDC}

	IP2AB(firsthop,DestAddr);

	IF DestAddr.ANode = 0 THEN BEGIN
		in_write := CantReachHost;
{$IFC DEBUG}
		WriteLn('in_write: Cannot reach host - IP2AB translation failed');
{$ENDC}
		exit(in_write);
		END;

{$IFC DEBUG}
	WriteLn('in_write to node ',DestAddr.ANode:1);
{$ENDC}
	{ Wait until previous write finished }
	WHILE CurW_Hdl^^.abResult = 1 DO tk_yield;
	{ Fill in the disk block }
	WITH CurW_Hdl^^ DO BEGIN
		ddpType := AB_IP;
		ddpSocket := AB_IP_Socket;
		ddpAddress := DestAddr;
		ddpReqCount := len;
		ddpDataPtr := p^.nb_buff;
		END;
	{ And do the write }
	err := DDPWrite(CurW_Hdl,false,true);
{$IFC DEBUG}
	WriteLn('in_write: exiting');
{$ENDC}
	if err = noErr then in_Write := 1 else in_write := -3;
END; { end of in_write }

FUNCTION inverify(p:Packet):Boolean;
VAR     pip:Ref_IP;
	csum: integer;	        { packet checksum }
BEGIN
	pip := in_head(p);

	IF (p^.nb_len < { bswap } (pip^.ip_len)) THEN BEGIN

{$IFC DEBUG}
		WriteLn('Packet length bad; dropped.' );
		{ in_dump(p); }
{$ENDC}
		iplen := iplen + 1;
		inverify := FALSE;
		exit(inverify);
		END;

	if (pip^.ip_ver <> Cur_IP_VER) THEN BEGIN
{$IFC DEBUG}
		WriteLn('Version number bad, packet dropped.');
		{ in_dump(p); }
{$ENDC}
		ipver := ipver + 1;
		inverify := FALSE;
		exit(inverify);
		END;

	csum := pip^.ip_chksum;
	pip^.ip_chksum := 0;
	if (csum <> BitNOT(cksum(POINTER(ORD4(pip)),BitSL(pip^.ip_ihl,1)))) THEN
		BEGIN
		pip^.ip_chksum := csum;
{$IFC DEBUG}
		WriteLn('Checksum bad, packet dropped.');
		{ in_dump(p); }
{$ENDC}
		ipxsum := ipxsum + 1;
		inverify := FALSE;
		exit(inverify);
		END;

	if(pip^.ip_dest <> LocalIPaddr) THEN BEGIN
{$IFC DEBUG}
		WriteLn('Received packet not for me.');
{$ENDC}
		inverify := FALSE;
		exit(inverify);
		END;

	if (pip^.ip_foff <> 0) OR Odd(pip^.ip_flgs) THEN BEGIN

{$IFC DEBUG}
		WriteLn('Fragment received; dropped.');
		{ in_dump(p); }
{$ENDC}
		ipfrag := ipfrag + 1;
		inverify := FALSE;
		exit(inverify);
		END;

	inverify := TRUE;
END;

{ This is the internet demultiplexing routine. It handles packets received by
	the per-net task, verifies their headers and does the upcall to
	the whoever should receive the packet. All the guts of demultiplexing
	is in this piece of code. If the packet doesn't belong to anyone,
	this gets logged and the packet dropped.        }

PROCEDURE indemux(Fake:PTR);
VAR
	pip: Ref_IP;	        { the internet header }
	conn: IPCONN;	        { an internet connection }
	i: Integer;
	Dummy: integer;	        { To hold value of ICMP_DESTUN }
	p: Packet;
	len:INTEGER;
	success:BOOLEAN;
BEGIN
    CheckTask;	    { Problem with stacks? }

    WHILE true DO BEGIN
	if ip_queue.qHead = NIL then tk_block; { Wait for something to come }

{$IFC DEBUG}
	WriteLn('Running: IP Demuxer');
{$ENDC}

	{ Get a packet }
	p := POINTER(ORD4(ip_queue.qHead));
	if p = NIL THEN BEGIN { Awakened w/o a packet! }
		ipwwop := ipwwop + 1;
{$IFC DEBUG}
		WriteLn('Awakened w/o any packets to process ');
{$ENDC}
		cycle;
		END;
	if dequeue(POINTER(ORD4(p)),@ip_queue) <> noErr then
		begin
{$IFC DEBUG}
		WriteLn('dequeue failure (p = ',ORD4(p),')');
{$ENDC}
		cycle;
		end;

{$IFC DEBUG}
	WriteLn('Processing a packet of length ',p^.nb_len);
{$ENDC}

	iprcv := iprcv + 1;

	if NOT inverify(p) THEN BEGIN
		ipdrop := ipdrop + 1;
		in_free(p);
		cycle;
		end;

	pip := in_head(p);
	len := { bswap } (pip^.ip_len);

	{ The packet is now verified; the header is correct. Now we have
		to demultiplex it among our internet connections. }

{$IFC DEBUG}
	WriteLn('IP: Received packet of length ',len-FirstIPLEN:1,
		' in protocol ',pip^.ip_prot:1);
{$ENDC}

	success := false;
	FOR i := 0 to nipconns - 1 DO BEGIN
		conn := ipconns[i];
		if (conn^.c_prot = pip^.ip_prot) THEN
			if (conn^.c_handle = NIL) THEN leave
			else BEGIN
{$IFC DEBUG}
			    WriteLn('handler found, delivering...');
{$ENDC}
			    CALL3(POINTER(ORD4(p)), len - FirstIPLEN, { ??? }
				  pip^.ip_src, conn^.c_handle);
			    CheckTask;
			    success := true;
{$IFC DEBUG}
			    WriteLn('finished executing IP handler');
{$ENDC}
			    tk_yield;
			    leave;
			    END;
		END;

	if not success then begin
		{ Didn't manage to demultiplex the packet.
		  We should drop it and go away. }
{$IFC DEBUG}
		WriteLn('Discarding pkt for unhandled protocol ',pip^.ip_prot:1);
{$ENDC}

		Dummy := icmp_destun(pip^.ip_src, pip, DSTPROT);
		ipprot := ipprot + 1;
		ipdrop := ipdrop + 1;
		in_free(p);
		end;
    END; { end of infinite while }
END; { End of indemux }

PROCEDURE in_close;
{ This procedure shuts down the IP connection }
VAR Status : Integer;
BEGIN
    Status := DDPCloseSocket(AB_IP_Socket);
END;

{ pretty print the statistics }

FUNCTION lfailures:INTEGER; external;

PROCEDURE in_stats;
VAR
	s:STR255;
	dp:DialogPtr;
	iType:INTEGER;
	itemHndl:Handle;
	box:Rect;
	i: Integer;
	tmpP:Packet;

    PROCEDURE SetIt(item:INTEGER; number:INTEGER);
    BEGIN
	NumToStr(number,s);
	GetDItem(dp,item,iType,itemHndl,box);
	SetIText(itemHndl,s);
    END;

BEGIN
	dp := GetNewDialog(77,NIL,POINTER(-1));
	SetIt(1,iprcv);
	SetIt(2,ipsnd);
	SetIt(3,ipdrop);
	SetIt(4,ipxsum);
	SetIt(5,ipprot);
	SetIt(6,ipver);
	SetIt(7,iplen);
	SetIt(8,ipttl);
	SetIt(9,ipfrag);
	tmpP := POINTER(ORD4(freeq.qHead));
	i := 0;
	while tmpP <> NIL do begin
		i := i+1;
		tmpP := tmpP^.nb_elt;
		end;
	SetIt(10,i);
	SetIt(11,lfailures);
{$IFC DEBUG}
	Write('packet addresses: ');
	tmpP := POINTER(ORD4(freeq.qHead));
	while tmpP <> NIL do begin
		Write(ORD4(tmpP),' ');
		tmpP := tmpP^.nb_elt;
		end;
	WriteLn('');
{$ENDC}
	MsgRegister(dp);
END; {End of in_stats}

{ CROCK routines. output an internet address in pretty octal form }

PROCEDURE cvt_inaddr(fhost: in_name; VAR s:STR255);
VAR     host:_ipname;
	s1,s2,s3,s4: STR255;
begin
	host.in_lname := fhost;
	NumToString(BitAND(host.in_lst.in_net,  255),s1);
	NumToString(BitAND(host.in_lst.in_nets, 255),s2);
	NumToString(BitAND(host.in_lst.in_netss,255),s3);
	NumToString(BitAND(host.in_lst.in_host, 255),s4);
	s := concat(s1,'.',s2,'.',s3,'.',s4);
end;

{$IFC DEBUG}
PROCEDURE out_inaddr(fhost: in_name);
VAR host:_ipname;
BEGIN

	host.in_lname := fhost;
	Write(BitAND(host.in_lst.in_net,255):1,'.',
	      BitAND(host.in_lst.in_nets,255):1,'.',
	      BitAND(host.in_lst.in_netss,255):1,'.',
	      BitAND(host.in_lst.in_host,255):1);

END; { End of out_inaddr }
{$ENDC}

END.

!E!O!F!
#
#
echo extracting net/ip_listen.text...
cat >net/ip_listen.text <<'!E!O!F!'
	.Title 'IP Socket Listener'
; code for Appletalk IP socket listener
; written by Tim Maroney, C-MU, July 1985
; modified 13 Sept 85 to eliminate use of A5 for global data (because of Switcher)
; please see the copyright notice in the file copyright/notice

	.nomacrolist
	.PAGE

.INCLUDE        -UPPER-TLASM-SYSEQU
.INCLUDE        -UPPER-TLASM-ATALKEQU
.INCLUDE        -UPPER-TLASM-TOOLEQU
.INCLUDE        -UPPER-TLASM-TOOLMACS

AB_IP	        .EQU    22      ; DDP protocol number for IP
AB_ARP	        .EQU    23      ; DDP protocol number for ARP
IPsize	        .EQU    600     ; length of an IP packet buffer
ARPSize	        .EQU    24      ; length of an ARP buffer
AB_IP_Socket    .EQU    72      ; static (sigh) IP socket number
nb_len	        .EQU    14      ; offset of the length field in a packet
nb_buff	        .EQU    6       ; offset of the buffer pointer in a packet
nb_tstamp       .EQU    10      ; offset of the time stamp field in a packet

; Here is the code for the socket listener.  See the Appletalk Manager
; documentation to understand this strange routine.

	.PROC   ip_listen
	.REF    ARPbuffer,IPEnable,arp_wake,ip_wake,ARPAllowed
	.REF    IPrdpkt,IPrdbuf,failcnt

; paranoia: make sure the packet is for our socket

	cmpi.b  #AB_IP_Socket,d0
	beq.s   @1
	bra     recvfail
@1

; First we have to find out the protocol, so we can figure out where
; to store the packet.  This requires figuring out whether this DDP
; header is long or short.

	lea     toRHA(a2),a3    ; a3 := addr of top of RHA (LAP header)
	cmpi.b  #shortDDP,lapType(a3)   ; short DDP header?
	; the addq may be used here beause an addq to an address register
	; leaves the condition codes untouched
	addq.l  #lapHdSz,a3     ; a3 := addr of DDP Header (RHA + 3)
	bne.s   @2	        ; if not, it's long
	move.b  sDDPType(a3),d0 ; d0 := ddp protocol byte from short hdr
	bra.s   @3
@2
	move.b  ddpType(a3),d0  ; d0 := ddp protocol byte from long hdr
@3

; d0 now contains the protocol ID from the DDP Header.

	cmpi.b  #AB_IP,d0       ; is this a packet for IP?
	bne.s   @4	        ; if not, maybe for ARP

; IP packet handling

	lea     IPrdbuf,a3
	tst.l   (a3)	        ; is there an ip buffer to read into?
	bne.s   @5	        ; if there is, continue
	clr.w   d3	        ; else signal ReadRest to throw away packet
	jsr     2(a4)	        ; ReadRest
	jsr     IPEnable        ; re-enable IP receive -- IPEnable will not work
				; if called in a re-entrant way, so do this at the
				; high interrupt priority
	lea     failcnt,a0
	addq.w  #1,(a0)
	rts
@5
	movea.l IPrdpkt,a5      ; get packet address to store packet length
	move.w  d1,nb_len(a5)   ; IPrdpkt^.nb_len := d1 (pkt length from caller)
	move.w  #IPsize,d3      ; size of buffer for ReadRest
	movea.l IPrdbuf,a3      ; get address of buffer arg to ReadRest
	jsr     2(a4)	        ; ReadRest

; disable reception of further packets for now
	lea     IPrdbuf,a0
	clr.l   (a0)

; put the packet on the IP queue and wake up the IP demultiplexer

	lea     IPrdpkt,a0
	move.l  (a0),-(sp)	        ; push arg for later ip_wake call
	jsr     IPEnable	        ; can't be re-entrant
	move.w  vSCCEnable(a2),sr       ; decrease priority
	move.l  (sp)+,a0	        ; pop arg for ip_wake
	lea     Ticks,a1	        ; a1 := address of Ticks
	move.l  (a1),nb_tstamp(a0)      ; packet's timestamp := Ticks
	jsr     ip_wake
	rts

; The packet wasn't for IP.  It had better be for ARP or I'll take my
; ball and go home.

@4
	cmpi.b  #AB_ARP,d0      ; is this a packet for ARP?
	beq.s   @9	        ; if so, continue to process it
	bra.s   recvfail
@9

; ARP packet handling: it's simple because there's just one fixed buffer

	lea     ARPAllowed,a3
	tst.b   (a3)	        ; is ARP allowed right now?
	bne.s   @10	        ; if not zero, continue
	bra.s   recvfail
@10
	move.w  #ARPsize,d3     ; size of ARP buffer for ReadRest
	lea     ARPbuffer,a3    ; address of ARP buffer for ReadRest
	jsr     2(a4)	        ; call ReadRest
	tst.l   d3	        ; check return status from ReadRest
	beq.s   @11	        ; if not exactly ARPsize received, return
	rts
@11
	lea     ARPAllowed,a0
	clr.b   (a0)	        ; disallow further ARP until processed
				; by ARP task (which calls ARPEnable)
	move.w  vSCCEnable(a2),sr       ; lower priority for the wakeup
	jsr     arp_wake	 ; wake up ARP handling task
	rts

; demultiplex failure -- read the rest of the packet into nowhere
recvfail
	clr.w   d3	        ; signals ReadRest to throw away packet
	jsr     2(a4)	        ; ReadRest
	lea     failcnt,a0
	addq.w  #1,(a0)
	rts

; ARPEnable: just set ARPAllowed to 1

	.PROC   ARPEnable
	.DEF    ARPAllowed
	lea     ARPAllowed,a0
	move.b  #1,(a0)
	rts
ARPAllowed      .BYTE	        ; 0 if ARP reception not allowed right now

; initialization routine for the socket listener, called from Pascal

	.PROC   listeninit
	.DEF    IPrdbuf,IPrdpkt,ipqaddr,dmxaddr,freeqaddr,failcnt,ATaskAddr
	.REF    ipenable
	lea     dmxaddr,a0
	move.l  16(sp),(a0)
	lea     ATaskAddr,a0
	move.l  12(sp),(a0)
	lea     ipqaddr,a0
	move.l  8(sp),(a0)
	lea     freeqaddr,a0
	move.l  4(sp),(a0)
	lea     failcnt,a0
	clr.w   (a0)
	jsr     ipenable
	rts
	.align  2
failcnt .WORD   ; count of number of failures
IPrdbuf .LONG   ; pointer to packet buffer for IP read
IPrdpkt .LONG   ; pointer to packet for IP read
ipqaddr .LONG   ; address of demuxer queue
dmxaddr .LONG   ; address of demuxer task
freeqaddr .LONG ; address of free packet queue
ATaskAddr .LONG ; address of ARP task

	.PROC   arp_wake
	.REF    ATaskAddr,tk_wake
	lea     ATaskAddr,a0
	move.l  (a0),-(sp)
	jsr     tk_wake
	rts

; ip_wake takes a single parameter, the address of the received packet, in a0

	.PROC   ip_wake
	.REF    ipqaddr,dmxaddr,tk_wake
	lea     ipqaddr,a1      ; queue arg to enqueue (ip_queue address)
	move.l  (a1),a1
	_Enqueue
	lea     dmxaddr,a0
	move.l  (a0),-(sp)      ; task arg to tk_wake (ipdemux address)
	jsr     tk_wake
	rts

; ipenable was formerly a Pascal routine.  It tries to enable the next read by
; pulling a packet off the free packet queue.

	.PROC   ipenable
	.REF    IPrdpkt,IPrdbuf,freeqaddr
	move.l  a4,-(sp)        ; save a4; used as local variable
	lea     freeqaddr,a0
	move.l  (a0),a1	        ; a1 := address of free queue
	tst.l   qHead(a1)       ; is free queue empty?
	beq.s   nofree	        ; if so, go to nofree
	move.l  qHead(a1),a0    ; element arg to dequeue
	move.l  a0,a4	        ; save free packet addr in a4
	_Dequeue
	tst.w   d0	        ; did dequeue operation succeed? (d0 is status)
	bne.s   nofree	        ; if not, go to nofree
	lea     IPrdpkt,a0
	move.l  a4,(a0)
	lea     IPrdbuf,a0
	move.l  nb_buff(a4),(a0)
	bra.s   return
nofree
	lea     IPrdpkt,a0      ; clear packet address
	clr.l   (a0)
	lea     IPrdbuf,a0      ; clear buffer address
	clr.l   (a0)
return
	move.l  (sp)+,a4        ; restore pushed a4
	rts

; getarpbuf: returns the address of the ARP buffer, for use by Pascal code
; FUNCTION getarpbuf:ARP_PACKET; EXTERNAL;

	.FUNC   getarpbuf
	.DEF    ARPbuffer
	lea     ARPbuffer,a0
	move.l  a0,4(sp)
	rts
	.align  2
ARPbuffer       .block  ARPsize ; buffer used for receiving ARP packets

; FUNCTION lfailures:INTEGER;

	.FUNC   lfailures
	.REF    failcnt
	lea     failcnt,a0
	move.w  (a0),4(sp)
	rts

.END
!E!O!F!
#
#
echo extracting net/name_host.text...
cat >net/name_host.text <<'!E!O!F!'
{$X-}
{$M+}
{$D-}
{$R-}
{$0V-}
{$DECL DEBUG}
{$SETC DEBUG := false}
UNIT NameHost;

{ Please note the copyright notice in the file "copyright/notice" }

INTERFACE

{$L-}
   USES {$U-}
      {$U Obj-Memtypes	  } Memtypes,
      {$U Obj-QuickDraw	  } QuickDraw,
      {$U Obj-OSIntf	  } OSIntf,
      {$U Obj-ToolIntf	  } ToolIntf,
      {$U Obj-ABPasIntf	  } ABPasIntf,
      {$U net-Task_Lib	  } Task_Lib,
      {$U net-Timer_Lib	  } Timer_Lib,
      {$U net-IP_Lib	  } IP_Lib;

{$L+}

FUNCTION NameRemoteHost(var name:STR255):Boolean;

IMPLEMENTATION

CONST FHostDialog = 31;
      OKbut = 1;
      CancelBut = 2;
      NameItem = 3;

FUNCTION NameRemoteHost(var name:STR255):Boolean;
VAR itemHit:INTEGER;
    MyDialog:DialogPtr;
    itemType:INTEGER;
    itemHndl:Handle;
    itemBox:Rect;
BEGIN
   MyDialog := GetNewDialog(FHostDialog,NIL,POINTER(-1));
   GetDItem(MyDialog,NameItem,itemType,itemHndl,itemBox);
   SetIText(itemHndl,DefaultHost);
   SelIText(MyDialog,NameItem,0,16000);
   ModalDialog(NIL,itemHit);
   if itemHit = 1 then GetIText(itemHndl,name);
   DisposDialog(MyDialog);
   NameRemoteHost := (itemHit = 1);
END;

END.
!E!O!F!
#
#
echo extracting net/name_user.text...
cat >net/name_user.text <<'!E!O!F!'
{$X-}
{$M+}
{$R-}
{$0V-}
{$D-}
{$DECL DEBUG}
{$SETC DEBUG := false}
UNIT Name_User;

{ Please note the copyright notice in the file "copyright/notice" }

INTERFACE

{$L-}

   USES {$U-}
      {$U Obj-Memtypes	  } Memtypes,
      {$U Obj-QuickDraw	  } QuickDraw,
      {$U Obj-OSIntf	  } OSIntf,
      {$U Obj-ToolIntf	  } ToolIntf,
      {$U Obj-ABPasIntf	  } ABPasIntf,
      {$U net-Task_Lib	  } Task_Lib,
      {$U net-Timer_Lib	  } Timer_Lib,
      {$U net-err_lib	  } Err_Lib,
      {$U net-ip_lib	  } IP_Lib,
      {$U net-udp_lib	  } UDP_Lib;

{$L+}

CONST

{ Name user return codes }
	NAMETMO =	        1      { Name user timed out on all requests };
	NAMEUNKNOWN     =       0      { Name not known };

FUNCTION udpname(var name: STR255): in_name;
FUNCTION convert_name(var name: STR255): in_name;
FUNCTION resolve_name (var name: STR255): in_name;

IMPLEMENTATION

CONST
	NAMESOCK       = 42;	        { A Well Known Socket }

	NI_NAME =       1;
	NI_ADDR =       2;
	NI_ERR  =       3;

{ This is the header for the nameserver stuff that sits on UDP. }
TYPE

    Ref_nmitem = ^ nmitem;

    nmitem = PACKED RECORD
	     { + 0 } nm_type: byte;
	     { + 1 } nm_len: byte
	     END;

{$S	   }

VAR
	nresp: Integer; { := 0 }        { # of responses to name request }
	name_conns: ARRAY [0..4] OF UDPCONN;
	address: in_name;
	name_task: Ref_Task;


{ Resolve a host name into an internet address.	 Three name formats are
 * accepted:
 *      1) A character string host name
 *      2) An octal host number, in the form:
 *	        <net>,<subnet>,<rsd>,<host>
 *	   or a decimal host number, in the form:
 *	        <net>.<subnet>.<rsd>.<host>
 *	   Any of the <net>, <subnet>, and <rsd> may be left blank or left out
 *	   entirely; they default to the local net/subnet.
 *      3) A thirty-two bit hex number, preceeded by a '#', which is used
 *	   without interpretation as the host number.
 * If a character string name is supplied, it is first looked up in a
 * local host table.  If it is not found there, the routine goes off to
 * internet name servers to try to resolve the name.
 *
 * The following routines are included in this file:
 *      resolve_name    Resolve a name as specified above
 *      gethmch	        Parse a hex machine address specification
 *      getomch	        Parse an octal machine address specification
 }

CONST	 INSZ	 =	 4;

	 MYNET	 = 128;	        { CMU B class network numbers }
	 MYSNET	 = 2;	        {  "	 "      "       "     }
	 MYRSD	 = 0;	        { Empty subnet and host values}
	 MYHOST	 = 0;

TYPE
	ByteName = PACKED ARRAY[1..INSZ] OF BYTE;

	Addr_Type = PACKED RECORD CASE Integer OF
		0: (bytes: ByteName);
		1: (name: in_name);
		END;

FUNCTION getomch(var name: STR255): in_name; forward;
FUNCTION gethmch(var name: STR255): in_name; forward;
FUNCTION getdmch(var name: STR255): in_name; forward;

{ Resolve foreign host internet address
 * Scan table of host names and nicknames.
 * For each name, see if our string is a prefix.  If so, keep checking -
 * could be ambiguous.
 * If ambiguous, return 0.
 * When find no matches, try internet name servers.
 }

{ resolve_name resides in the blank segment.  This is so it can unload the
  name service segment when it completes.  It is an infrequently used protocol,
  and one not time-critical. -- Tim }

{$S	  }

FUNCTION resolve_name(var name: STR255): in_name;
VAR result:in_name;
BEGIN
	result := convert_name(name);
	if result = 0 then result := udpname(name);
	UnloadSeg(@udpname);
	resolve_name := result;
END;

FUNCTION convert_name(var name: STR255): in_name;
VAR L,i,limit:Integer;
    flag:Boolean;
BEGIN
    L := Length(name);
    if L = 0 THEN
	    convert_name := 0
    else if name[1] in ['0'..'9'] THEN BEGIN
	    flag := false;
	    if L < 8 then limit := L else limit := 8;
	    for i := 2 to limit do begin
		if (name[i] = '.') then flag := true end;
	    if flag
		THEN convert_name := getdmch(name)
		ELSE convert_name := getomch(name);
	    END
    else if (name[1] = '#') OR (name[1] = '$') THEN
	    convert_name := gethmch(name)
    else convert_name := 0;
    UnloadSeg(@gethmch);
END; { convert_name }

{$S UDPNameS  }

{ Parse foreign host number input as hex string }

FUNCTION gethmch(var name: STR255): in_name;
VAR Result: LongInt;
    i: Integer;
BEGIN
	IF NOT (Length(name) in [2..9])	 THEN
		gethmch := 0
	else
		begin
		Result := 0;
		for i := 2 to length(name) do
			if name[i] in ['0'..'9'] then
				Result := Result * 16 + (ord(name[i])-ord('0'))
			else if name[i] in ['a'..'f'] then
				Result := Result * 16 + (ord(name[i])-ord('a')+10)
			else if name[i] in ['A'..'F'] then
				Result := Result * 16 + (ord(name[i])-ord('A')+10)
			else Result := Result * 16;
			gethmch := Result;
		end;
END; { gethmch }

{ Parse foreign host number input as octal string }

FUNCTION getomch(var name: STR255): in_name;
LABEL
	8890, 9999; { Loop exits }
VAR
	tmp: ByteName;
	i, j: Integer;
	n: Integer;
	addr: Addr_Type;
	StrCtr: Integer;
	LastFilled: Integer;
BEGIN
	addr.bytes[1] := MYNET;
	addr.bytes[2] := MYSNET;
	addr.bytes[3] := MYRSD;
	addr.bytes[4] := MYHOST;

	StrCtr := 1;
	FOR i := 1 to INSZ DO BEGIN
		n := 0;
		WHILE (StrCtr <= Length(name)) AND (name[StrCtr] in ['0'..'7']) DO
			BEGIN
			n := (n * 8) + ORD(name[StrCtr]) - ORD('0');
			if (n > 255) THEN BEGIN
				getomch := 0;
				EXIT(getomch);
				END;
			StrCtr := StrCtr + 1;
			END;
		tmp[i] := n;
		LastFilled := i;
		if StrCtr > length(name) THEN GOTO 8890;
		if name[StrCtr] = ',' THEN StrCtr := StrCtr + 1
		ELSE BEGIN
		    getomch := 0;
		    EXIT(getomch);
		    END;
		END;

	8890:
	if StrCtr <= length(name) THEN BEGIN
		getomch := 0;
		EXIT(getomch);
		END;

	FOR j := 4 DOWNTO 1 DO BEGIN
		addr.bytes[j] := tmp[LastFilled];
		LastFilled := LastFilled - 1;
		if LastFilled < 1 THEN GOTO 9999;
		END;
9999:
	getomch := addr.name;
END; { getomch }

{ Parse foreign host number input as decimal string }

FUNCTION getdmch(var name: STR255): in_name;
LABEL
	8890, 9999; { Loop exits }
VAR
	tmp: ByteName;
	i, j: Integer;
	n: Integer;
	addr: Addr_Type;
	StrCtr: Integer;
	LastFilled: Integer;
BEGIN
	addr.bytes[1] := MYNET;
	addr.bytes[2] := MYSNET;
	addr.bytes[3] := MYRSD;
	addr.bytes[4] := MYHOST;

	StrCtr := 1;
	FOR i := 1 to INSZ DO BEGIN
		n := 0;
		WHILE (StrCtr <= Length(name)) AND (name[StrCtr] in ['0'..'9']) DO
			BEGIN
			n := (n * 10) + ORD(name[StrCtr]) - ORD('0');
			if (n > 255) THEN BEGIN
				getdmch := 0;
				EXIT(getdmch);
				END;
			StrCtr := StrCtr + 1;
			END;
		tmp[i] := n;
		LastFilled := i;
		if StrCtr > length(name) THEN GOTO 8890;
		if name[StrCtr] = '.' THEN StrCtr := StrCtr + 1
		ELSE BEGIN
		    getdmch := 0;
		    EXIT(getdmch);
		    END;
		END;

	8890:
	if StrCtr <= length(name) THEN BEGIN
		getdmch := 0;
		EXIT(getdmch);
		END;

	FOR j := 4 DOWNTO 1 DO BEGIN
		addr.bytes[j] := tmp[LastFilled];
		LastFilled := LastFilled - 1;
		if LastFilled < 1 THEN GOTO 9999;
		END;
9999:
	getdmch := addr.name;
END;

{ This code implements a UDP name user compatible with the servers on
	Mit-Multics, Mit-XX and Mit-Spooler.  }

PROCEDURE name_rcv(p: PACKET; len: Integer; host: in_name; foo_data: PTR);
	forward;

PROCEDURE name_wake(Dummy:PTR);
BEGIN
	tk_wake(name_task);
END;

FUNCTION udpname(var name: STR255): in_name;
LABEL   8888;
CONST   NameTimeout = 9;
VAR     len,i,Dummy:Integer;
	p:PACKET;
	s:PTR;
	tm:ref_Timer;
BEGIN
	{ Check the local table for a match }
	{ Note: This code is missing: some day it should be added.   }

	{ grovel, grovel...check if the name is 'me'. If it is, special case
		it and use my net 0 ip address }
	if name = 'me' THEN BEGIN
		udpname :=  LocalIPaddr;
		EXIT(udpname);
		END;

	len := length(name);

	p := udp_alloc(len + 3, 0);
	if p = NIL THEN BEGIN
		CantAlloc(StrCvt('UDPNAME'),StrCvt('packet'));
		udpname := 0;
		EXIT(udpname);
		END;

	s := POINTER(ORD4(udp_data(udp_head(in_head(p)))));
	s^ := NI_NAME;
	s := POINTER(ORD4(s)+1);
	s^ := len;
	s := POINTER(ORD4(s)+1);
	for i := 1 to len do
		begin
		s^ := byte(name[i]);
		s := POINTER(ORD4(s)+1);
		end;
	s^ := 0;

	name_task := tk_cur;
	address := 0;
	nresp := 0;

	FOR i := 0 TO Num_Name_Servers DO BEGIN
		if i = Num_Name_Servers THEN
			BEGIN
{$IFC DEBUG}
			if BCBitAnd(NDEBUG,CBitOr(PROTERR,NETERR)) THEN
				WriteLn('UDP_NAME: Too many name servers!!');
			if BCBitAnd(NDEBUG,BUGHALT) THEN BEGIN
				WriteLn('BUGHALT!');
				HALT;
				END;
{$ENDC}
			GOTO 8888; {break;}
			END;

		name_conns[i] := udp_open(NSIPAddress[i], NAMESOCK, udp_socket,
				     @name_rcv, NIL);

{$IFC DEBUG}
		if BCBitAnd(NDEBUG,INFOMSG) THEN BEGIN
			Write('NAME: Sending request to server ');
			out_inaddr( NSIPAddress[i] );
			WriteLn('.');
			END;
{$ENDC}

		Dummy := udp_write(name_conns[i], p, len+3);
		END; { end of for loop }
		8888:

	udp_free(p);

	tm := tm_alloc;
	if tm=NIL THEN BEGIN
		CantAlloc(StrCvt('UDPNAME'),StrCvt('timer'));
		udpname := 0;
		exit(udpname);
		END;
	tm_set(NameTIMEOUT, @name_wake, NIL, tm);
	tk_block;

	{ Now one of two things should have happened: we should have received
		the resolved address or we should have timed out. If we've
		gotten the address, we should clear the timer. If we've timed
		out, we should just deallocate it. }

	Dummy := ORD(tm_clear(tm));
	Dummy := ORD(tm_free(tm));

	{ Clean up the udp connections. }

	for i:=0 to Num_Name_Servers do udp_close(name_conns[i]);

	if (nresp = 0) THEN udpname := NAMETMO
	else udpname := address;
END;

PROCEDURE name_rcv{(p: PACKET; len: Integer; host: in_name; foo_data: PTR)};
VAR
	pnm: Ref_nmitem;
	pname:Ref_in_name;
BEGIN
	nresp := nresp + 1;

{$IFC DEBUG}
	if BCBitAnd(NDEBUG,INFOMSG) THEN BEGIN
		Write('NAME_RCV: Got response from foreign host ');
		out_inaddr(host);
		WriteLn('.');
		END;
{$ENDC}

	pnm := {(struct nmitem *)} POINTER(ORD4(udp_data(udp_head(in_head(p)))));

	pnm := {(struct nmitem *)} POINTER(ORD4(pnm) + pnm^.nm_len + 2);

	if (pnm^.nm_type = NI_ADDR) AND (address = 0) THEN BEGIN
		name_wake(NIL);
		pname := POINTER(ORD4(pnm)+2);
		address := pname^;
		END
	else BEGIN
{$IFC DEBUG}
	  if BCBitAnd(NDEBUG,INFOMSG) THEN BEGIN
		Write('NAME_RCV: Name server ');
		out_inaddr(host);
		WriteLn(' couldn''t resolve the name.');
		END;
{$ENDC}
		if (nresp = Num_Name_Servers) THEN name_wake(NIL);
		END;

	udp_free(p);
END { name_rcv };

END.

!E!O!F!
#
#
echo extracting net/task_asm.text...
cat >net/task_asm.text <<'!E!O!F!'
	  .Title 'Task Switching routines'
;__________________________________________________________________
;
; Pascal interface to the Task Switching Routines
;
; Mark Sherman, July 1984
; Version 0.0
;
;__________________________________________________________________

     .nomacrolist
     .PAGE
;___________________________________________________________
;
; Definitions of Pascal data structure offsets
;___________________________________________________________
;
;
;	 task = RECORD			 { a task - top of its stack }
;	     tk_sp: PTR;		 { task's current stack ptr }
;	     tk_nxt: Ref_Task;		 { pointer to next task }
;	     tk_size: Integer;		 { Size of allocated task }
;	     tk_unique: Ref_Task;	 { Unique Identification for collision }
;	     ev_flg: Task_State;	 { flag set if task is scheduled }
;	     tk_stack: packed array[0..0] of stack;  { task's stack }
;	 END;
;
	  .PROC	    tk_swtch,2
;___________________________________________________________________________
;
;    tk_switch - Task Switch; swap the current task with the proposed task
;
;	  Call:	    Old_Task: Task to block
;		    New_Task: Task to start running
;
;
;    PROCEDURE tk_swtch(Old_Task:Ref_Task;New_Task:Ref_Task);
;
;    Stack setup upon entry:
;       +0  .LONG     Return address
;       +4  .LONG     Address of New_Task (+0 after popping RA)
;       +8  .LONG     Address of Old_Task (+4 after popping RA)
;
;    Other stack perversity:
;	  When entering, all of the registers execpt for A0, A1 and D0 belong
;	  to the old task. These will be stacked on the old stack and replaced
;	  by values from the new stack. Hence a complete context shift is
;	  done, providing the caller of task switch with the environment from
;	  the last block of the task. (Note: by using the old stack, we
;	  will use the return address of that left by the task when it blocked
;	  by calling tk_block. Similarly, the current task's stack will be
;	  saved for its later restarting. Also see tk_fram below
;
;_____________________________________________________________________________
;	   STOP #10;			 ; Drop into debugger

	  LEA	    SaveRA,A0
	  MOVE.L    (SP)+,(A0)	        ; Save the return address
	  MOVEA.L   SP,A1	        ; Hold on to old SP for Args
					; Save all of the registers -- who
					; knows what will be munged
	  MOVEM.L   D3/D4/D5/D6/D7/A2/A3/A3/A4/A5/A6,-(SP)
	  MOVE.L    4(A1),A0	        ; A0 -> TCB for old task
	  MOVE.L    SP,(A0)	        ; Save current SP in TCB (start of rec)
	  MOVE.L    (A1),A0	        ; A0 -> TCB for new task
	  MOVE.L    (A0),SP	        ; Restore the stack pointer
					; Put back the registers
	  MOVEM.L   (SP)+,D3/D4/D5/D6/D7/A2/A3/A3/A4/A5/A6
	  ADD.L	    #8,SP		 ; Pop the stack of arguments
					 ; More trickery: we need return address
	  MOVEA.L   SaveRA,A1		 ; from old stack!
	  JMP	    (A1)		 ; Back to tk_blk !
	  .align        2
SaveRA	  .LONG
;
;
;

	  .PROC	    tk_frame,4
	  .REF	    _cdump
;___________________________________________________________________________
;
;    tk_frame - Setup a frame as if a task had called tk_block
;
;	  Call:	    PTCB: Pointer to a task control block
;		    StackSize: Number of bytes pointed at by PTCB
;		    Proc_Start: Starting address of task
;		    Proc_Arg: Pointer argument for task
;
;	  Returns:  Filled in task control block for use in tk_block
;
;    PROCEDURE tk_frame (PTCB:Ref_Task; StackSize: LongInt;
;			  Proc_Start: ProcPtr; Proc_Arg: PTR);
;
;    Stack setup upon entry:
;	  +0 .LONG     Return address
;	  +4 .LONG     Pointer value for Proc_Arg
;	  +8 .LONG     Address of task code
;	 +12 .LONG     Number of bytes in TCB + Stack
;	 +16 .LONG     Pointer to the TCB -- TCB values at bottom, stack at top
;		       and grows downward. Disaster is stack grows into TCB.
;
;    To properly look like this task had called tk_block (and hence is
;    returning), there must be a stack frame for tk_block. Further, since
;    the return from tk_block will cause the procedure to start, its
;    parameter must also be available.
;
;    What we are trying to simulate is the situation where a call to
;    tk_block has been made, followed by a call to tk_swtch. The simulation
;    of these calls (up till the actual task switch) is
;	  Push args to tk_block = NOP (no arguments)
;	  JSR to tk_block = PUSH return address = start address of task
;	  LINK A6,Locals  => Push saved A6, Assign SP to A6, alloc locals
;	  (Note: this saved A6 will become SP upon return of tk_block)
;	  Push args to tk_swtch (PUSH Oldtask, Push NewTask)
;	  JSR to tkswicth = PUSH return address
;	  POP R.A. inside of tk_swtch
;	  PUSH Saved registers (note the value of A6 and A5!)
;	  Save the SP at this point
;
;
;Hence the stack we must build is:
;
;
;	  parameter for task (since task thinks it is being called!)
;	  return address for "caller" of task = error handling routine
;	  parameters to tk_block to be popped
;	  R.A for tk_block = starting address of task
;  A6->	  linked value of "old" A6 (nonexistant value)
;	  local variables of tk_block
;	  parameters to tk_swtch (only to be popped here)
;	  saved registers from inside of tk_swtch
;	  (save SP must go inside of TCB)
;
;_____________________________________________________________________________
;	   STOP #12
BlockLocs  .Equ	   20			 ; Max space taken by tk_block's locals

	  LEA	    OldA6,A0
	  MOVE.L    A6,(A0)	        ; Save it for later -- we will clobber 6
	  MOVE.L    16(SP),A0	        ; A0 -> TCB
	  ADD.L	    12(SP),A0	        ; A0 -> top of Stack (grows down)
					; So now we start pushing everything
					; on the stack denoted by A0
	  MOVE.L    4(SP),-(A0)	        ; Push the task's parameter
	  LEA	    _cdump,A1	        ; Ret. Addr. of "caller" of the task
	  MOVE.L    A1,-(A0)
;	  NOP			        ; Nothing - no parameters to tk_block yt
	  MOVE.L    8(SP),-(A0)	        ; Push the return address for tk_block =
					; starting address of task
	  MOVE.L    A1,-(A0)	        ; A fake A6 linkage register to UNLNK
					; This is what stack pointer will be
					; loaded with !!!! (See above)
	  MOVEA.L   A0,A6	        ; Here is fake linkage !!!
	  SUBA.L    #BlockLocs,A0       ; Allocate tk_block locals (some value)
	  MOVE.L    A1,-(A0)	        ; Fake Old_Task_Ptr
	  MOVE.L    A1,-(A0)	        ; Fake New_Task_Ptr
					; Put in plenty of registers to restore
	  MOVEM.L   D3/D4/D5/D6/D7/A2/A3/A3/A4/A5/A6,-(A0)
;
; All done setting up stack, so save the stack pointer into TCB
;

	  MOVE.L    16(SP),A1	        ; A1 -> TCB
	  MOVE.L    A0,(A1)	        ; Place SP, i.e., A0, into TCB
DoneIt
	  MOVE.L    (SP)+,A0	        ; Get return address of tk_frame
	  ADDA.L    #16,SP	        ; Pop off the parameters
	  MOVEA.L   OldA6,A6	        ; Restore the frame pointer
	  JMP	    (A0)	        ; return to called of tk_frame
	  .align    2
OldA6	  .LONG

;___________________________________________________________________________
;
;    stk_init - Stack initialization for tasking
;
;	  Call:	    Size: maximum amount of stack space required by main prog
;
;
;    PROCEDURE stk_init(size:Integer);
;
;    Stack setup upon entry:
;       +0  .LONG     Return address
;       +4  .WORD     Number of bytes to allocate beyond current stack
;
;
;____________________________________________________________________________
     .PROC     stk_init,1
     .DEF      GlobStk

     MOVE.L    SP,D0		   ; Save the stack pointer
     MOVE.L    (SP)+,A0		   ; Save the return address
     CLR.L     D1		   ; Clear out the whole word
     MOVE.W    (SP)+,D1		   ; Get the length
     SUB.L     D1,D0		   ; Allocate the hypothetical stack ptr (D0)
     LEA       GlobStk,A1	   ; Just for the store. Sigh.
     MOVE.L    D0,(A1)		   ; Save the magic stack ptr
     JMP       (A0)		   ; And return
     .align    2
GlobStk	  .LONG

;___________________________________________________________________________
;
;    stk_alloc -- allocate a stack for a task
;
;	  Call:	    Size: number of bytes to allocate
;
;	  Returns:  A Pointer to the lowest address (bottom ) of the stack
;
;
;    FUNCTION stk_alloc(size: Integer):PTR;
;
;    Stack setup upon entry:
;       +0  .LONG     Return address
;       +4  .WORD     Number of bytes to provide
;       +6  .LONG     Address of stack block of storage (return value)
;
;
;
;_____________________________________________________________________________
     .FUNC     stk_alloc,1
     .REF      GlobStk
     MOVE.L    (SP)+,A0		   ; Save the return address
     CLR.L     D0		   ; Clear out register for count
     MOVE.W    (SP)+,D0		   ; Get the count
;     STOP #8
     LEA       GlobStk,A1	   ; Get a ptr to the variable for next inst
     SUB.L     D0,(A1)		   ; Advanced the stack
     MOVE.L    GlobStk,(SP)	   ; And return the "bottom" of the stack
     JMP       (A0)		   ; And return

;    utility routine to read the stack pointer.

     .FUNC GetSP,0
     MOVE.L    (SP)+,A0		   ; save the r.a
     MOVEA.L   SP,A1		   ; save the sp
     MOVE.L    A1,(SP)		   ; give back the sp
     JMP       (A0)		   ; return

.END
!E!O!F!
exit
-=-
Tim Maroney, Professional Heretic, CMU Center for Art and Technology
tim@k.cs.cmu.edu       | uucp: {seismo,decwrl,ucbvax,etc.}!k.cs.cmu.edu!tim
CompuServe: 74176,1360 | God is not dead; he just smells funny.