;;; -*- Mode:Common-Lisp; Package:Ip; Base:10 -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151


;;; Copyright (C) 1989 Texas Instruments Incorporated. All rights reserved.

;; Allows Explorers to boot using only TCP/IP. This patch must be loaded on 
;; the namespace server and must be loaded and disk-saved on the namespace client. Before disk saving 
;; run the function (ip:enable-udp-who-am-i).

;; Notes.
;; 1). We do not have an assigned port yet and so we have chosen an expermental one. If you
;;     need to change the port see the variable *udp-who-am-i-port* (remember to change it on 
;;     both the client and server). The nameserver also uses an expermental port on TCP that can
;;     be changed by setting  NAME:*RPC-TCP-PORT*.
;;

(defvar *UDP-WHO-AM-I-PORT* 235.
  "Port number to use. Right now it is an expermental port number but we should get a well known port.")

(defvar *UDP-WHO-AM-I-DESTINATION-ADDRESS*  #xffffffff "Use the ip broadcast address.")

(add-server *udp-who-am-i-port*
	    '(process-run-function '(:name "UDP who-am-i") 'udp-who-am-i-server)
	    '*udp-server-alist*)

(defvar *DEBUG-ON-NON-SERVER* nil "set to t to use client namespace function to look up host.")

(defvar *DEBUG-UDP-WHO-AM-I-SERVER* nil "Set to t to stop errors from being caught.")

;; Note that in the spirit of TGC we will just cons away with no thought of reusing the buffers. Cringe!!! 
(defun UDP-WHO-AM-I-SERVER (&aux port)
  "UDP who-am-i server"
  (condition-call-if  (not *debug-udp-who-am-i-server*) (cond)
      (unwind-protect
	  (let* (name data-p source-port source-address length
		 (buffer (make-array 256 :element-type 'string-char :fill-pointer 0)))
	    
	    (setf port (send *udp-handler* :get-port *udp-who-am-i-port*))
	    (setf (send port :who-state) "Who Am I")
	    
	    (setf (values length source-port source-address data-p) (send port :receive-data buffer))
	    (setf (fill-pointer buffer) length)
	    
	    (when (and data-p
		       (search "WHO-AM-I" buffer :test #'string-equal :end2 (max 9 length)))
	      
	      (setf name 
		    (let* ((start (position #\" buffer :test 'char-equal)))		      
		      (if start 
			  (subseq buffer (1+ start) (position #\" buffer :start (1+ start) :test 'char-equal)))))
	      
	      (let* ((domain-name
		       (when name 
			 (if *debug-on-non-server*
			     (format nil "~a" (second (multiple-value-list (name:lookup-object name :host))))
			     (funcall name:*who-am-i-answer-function* name))))
		     
		     (his-host-object (when domain-name (si:parse-host (name:qualified-name name domain-name) :no-error)))
		     
		     (his-addresses (when his-host-object (send his-host-object :send-if-handles :network-address-list :ip)))
		     
		     (his-best (when his-addresses (best-relative-address his-addresses my-addresses)))
		     
		     (my-best (when his-addresses (best-relative-address my-addresses his-addresses))))
		
		(when (and his-best my-best)
		  (let ((*print-base* 16.)
			(*print-radix* t)
			
			;; Bind this to get around ip's changing the address in to a subnet broadcast.
			(*really-broadcast* t))
		    (declare (special *really-broadcast*))
		        
		    (send port :transmit-data
			  :data (format nil "UR ~s ~s ~s ~a ~a"
					name
					domain-name
					si:local-host-name
					his-best
					my-best)
			  :destination-port source-port ;;*udp-who-am-i-port*
			  :destination-host *udp-who-am-i-destination-address*
			  ))))))
	
	(when port (send *udp-handler* :return-port port)))
    ((not (or (send cond :dangerous-condition-p)
	      (send cond :debugging-condition-p)))
     (tv:notify nil "Udp Who Am I server got an error: ~a" (send cond :report-string)))))

;; Note that more work needs to be done to find the closest address.
(defun BEST-RELATIVE-ADDRESS (my-addresses his-addresses)
  "Address of this host with the shortest routing path to the given host"
  (let ((returned-addr (first his-addresses)) first-hop-rte)
    (condition-case ()
	(progn
	  (setf first-hop-rte (get-routing-entry (first my-addresses)))
	  (when (not (eq (ip-routing-address first-hop-rte) :direct))
		(setf first-hop-rte (get-routing-entry (ip-routing-address first-hop-rte))))
	  (dolist (a his-addresses)
		  (when (equal (get-routing-entry a) first-hop-rte)
			(setf returned-addr a))))
      (incomplete-routing-table))
    returned-addr))

(defvar *UDP-WHO-AM-I-TIMEOUT* 5 "Max time in secs to wait for replys")

(defvar *UDP-WHO-AM-I-RETRY-COUNT* 5 "Number of times to retry send the who-am-i before giving up.")

(defun WHO-AM-I (&optional (name (si:get-pack-host-name)) (retry *udp-who-am-i-retry-count*) &aux port)
  "Return basic namespace info about a host."
  (declare (values domain-name server-name server-address my-address :ip))
  (unwind-protect
      (let ((buffer (make-array 256 :element-type 'string-char :fill-pointer 0))
	    length
	    source-port
	    source-address
	    data-p
	    cursor1
	    cursor2
	    domain-name
	    server-name
	    server-address
	    my-address)
	
	(setf port (send *udp-handler* :get-port))
	(setf (send port :who-state) "Who Am I")

	(dotimes (i retry)

	  (let ((*really-broadcast* t))
	    (declare (special *really-broadcast*))
	    (send port :transmit-data
		  :data (format nil "WHO-AM-I ~s" name)
		  :destination-port *udp-who-am-i-port*
		  :destination-host *udp-who-am-i-destination-address*
		  :source-host *udp-who-am-i-destination-address*
		  ))
	  

	  (loop
	    (setf (values length source-port source-address data-p) (send port :receive-data buffer *udp-who-am-i-timeout*))
	    (when (not data-p)
	      (return))

	    (setf (fill-pointer buffer) length)
	    
	    (when (and (search "UR" buffer :test #'string-equal :end2 3)
		       (progn (setf cursor1 (1+ (position #\" buffer :test #'char-equal)))
			      (setf cursor2 (position #\" buffer :test #'char-equal :start (1+ cursor1)))
			      (string-equal name (subseq buffer cursor1 cursor2))))

	      ;; Get the domain name.
	      (setf cursor1 (1+ (position #\" buffer :test #'char-equal :start (1+ cursor2))))
	      (setf cursor2 (position #\" buffer :test #'char-equal :start (1+ cursor1)))
	      (setf domain-name (subseq buffer cursor1 cursor2))

	      ;; get my name
	      (setf cursor1 (1+ (position #\" buffer :test #'char-equal :start (1+ cursor2))))
	      (setf cursor2 (position #\" buffer :test #'char-equal :start (1+ cursor1)))
	      (setf server-name (subseq buffer cursor1 cursor2))

	      ;; Get server-address
	      (setf cursor1 (position #\space buffer :test #'char-not-equal :start (1+ cursor2)))
	      (setf cursor2 (position #\space buffer :test #'char-equal     :start cursor1))
	      (setf server-address (net:parse-network-address (subseq buffer cursor1 cursor2) :ip nil))

	      ;; Get my address
	      (setf cursor1 (position #\space buffer  :test #'char-not-equal :start (1+ cursor2)))
	      (setf cursor2  (position #\space buffer :test #'char-equal     :start cursor1))
	      (setf my-address (net:parse-network-address (subseq buffer cursor1 cursor2) :ip nil))

	      (when (and domain-name server-name server-address my-address)
		(return-from who-am-i (values domain-name server-name server-address my-address :ip)))))))
    (when port (send *udp-handler* :return-port port))))

(defun TURN-ON-WHO-AM-I-SERVER () (who-am-i-switch t))
(defun TURN-OFF-WHO-AM-I-SERVER () (who-am-i-switch nil))

(defun WHO-AM-I-SWITCH (on?)
  (if on?
     (add-server *udp-who-am-i-port*
	    '(process-run-function '(:name "UDP who-am-i") 'udp-who-am-i-server)
	    '*udp-server-alist*)
     (delete-server *udp-who-am-i-port*
		    '*udp-server-alist*)))

;; Add who-am-i  to the appropriate lists.
(when (boundp 'name:*who-am-i-implementations*)
  (unless (member 'who-am-i name:*who-am-i-implementations*)
    (pushnew 'who-am-i name:*who-am-i-implementations*)))

(when (boundp 'name:*enable-who-am-i-service-functions*)
  (unless (member 'turn-on-who-am-i-server name:*enable-who-am-i-service-functions*)
    (pushnew 'turn-on-who-am-i-server name:*enable-who-am-i-service-functions*)))

(when (boundp 'name:*disable-who-am-i-service-functions*)
  (unless (member 'turn-off-who-am-i-server name:*disable-who-am-i-service-functions*)
    (pushnew 'turn-off-who-am-i-server name:*disable-who-am-i-service-functions*)))

;; Some functions that were helpful when debugging.
(defun DELETE-UDP-WHO-AM-I ()
  "Deletes the udp who-am-i handler and adds the chaos who-am-i handler"
    (setf name:*who-am-i-implementations*
	  (delete 'who-am-i name:*who-am-i-implementations*))
    (setf name:*enable-who-am-i-service-functions*
	  (delete 'turn-on-who-am-i-server name:*enable-who-am-i-service-functions*))
    (setf  name:*disable-who-am-i-service-functions*
	   (delete 'turn-off-who-am-i-server name:*disable-who-am-i-service-functions*)))

(defun DELETE-CHAOS-WHO-AM-I ()
  "Deletes the chaos who-am-i handler and adds the udp who-am-i handler"
    (setf name:*who-am-i-implementations*
	  (delete 'chaos:who-am-i name:*who-am-i-implementations*))
    (setf name:*enable-who-am-i-service-functions*
	  (delete 'chaos:turn-on-who-am-i-server name:*enable-who-am-i-service-functions*))
    (setf  name:*disable-who-am-i-service-functions*
	   (delete 'chaos:turn-off-who-am-i-server name:*disable-who-am-i-service-functions*)))

(defun ENABLE-UDP-WHO-AM-I ()
  "Delete the chaos who-am-i code and add the udp code."
  (pushnew 'who-am-i name:*who-am-i-implementations*)
  (pushnew 'turn-on-who-am-i-server name:*enable-who-am-i-service-functions*)
  (pushnew 'turn-off-who-am-i-server name:*disable-who-am-i-service-functions*)
  (delete-chaos-who-am-i))

(defun ENABLE-CHAOS-WHO-AM-I ()
  (pushnew 'chaos:who-am-i name:*who-am-i-implementations*)
  (pushnew 'chaos:turn-on-who-am-i-server name:*enable-who-am-i-service-functions*)
  (pushnew 'chaos:turn-off-who-am-i-server name:*disable-who-am-i-service-functions*)
  (delete-udp-who-am-i))


;;; 
;;; Some system patches.
;;;


#!C
; From file BOOT.LISP#> NAMESPACE; MR-X:
#10R NAME#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NAME"))
                          (SI:*LISP-MODE* :Common-lisp)
                          (*READTABLE* Sys:Common-lisp-readtable)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* Sys::*common-lisp-symbol-substitutions*))
  (COMPILER#:PATCH-SOURCE-FILE "Sys: NAMESPACE; BOOT.É#É"

(defparameter *make-ip-default* t)
(defparameter *default-medium-desirability*
	(when (or *make-ip-default* (not (eq *local-host-system-type* :lispm)))
	  '((:Local 1.0) (Chaos 0.9) (:Udp 0.85) (:Tcp 0.95) (:Tcp-stream 0.97) (:Chaos-stream 0.87) (:Micronet 1.0))))

(DEFUN INITIALIZE-DISTRIBUTION-NAMESPACE (&OPTIONAL ADDRESS
					  (FORCE-BOOT *NAMESPACE-FORCE-BOOT*)
					  (CLEAR-PREVIOUS-NAMESPACES T))
  
  ;; ADDRESS should be a list of sublists, e.g. ((:chaos #x0100))
  
  (LET ((DISTRIBUTION-MISSING (NOT (ON-SEARCH-LIST *DISTRIBUTION-NAME*)))
	(net:*setup-local-only* t))
    (declare (special net:*setup-local-only*))
    (WHEN (OR SI:COLD-BOOTING
	      FORCE-BOOT
	      DISTRIBUTION-MISSING)
      
      (WHEN (OR CLEAR-PREVIOUS-NAMESPACES DISTRIBUTION-MISSING)
	(NAME-MGR-INIT NIL T))
      
      (unless address (setf address *DUMMY-NETWORK-ADDRESSES*))
      
      ;; SHOULDN'T HAVE TO DO THIS
      (UNLESS (ASSOC :CHAOS ADDRESS :TEST 'EQ)
	(SETF ADDRESS (APPEND ADDRESS (LIST (ASSOC :CHAOS *DUMMY-NETWORK-ADDRESSES* :TEST 'EQ)))))
      
      (LET ((ME (RELATIVE-MACHINE-NAME)))    
	(SEND *DISTRIBUTION-NAMESPACE* :SET-USAGE :NETWORK)
	
	(SETF SITE-NAME *DISTRIBUTION-NAME*)
	(ADD-OBJECT ME :HOST :NAMESPACE *DISTRIBUTION-NAMESPACE*
		    :PRE-DELETE T
		    :ATTRIBUTES (LIST '(:SERVICES :GROUP) *local-host-services*
				      '(:ADDRESSES :GROUP) ADDRESS
				      :SITE *DISTRIBUTION-NAME*
				      :SYSTEM-TYPE *local-host-system-type*
				      :PATHNAME-FLAVOR *local-pathname-flavor*
				      :ALIASES '("lm")
				      :LOCAL-HOST-P T
				      :MEDIUM-DESIRABILITY *default-medium-desirability*))
    
    (ADD-ALIAS "lm" ME :HOST :NAMESPACE *DISTRIBUTION-NAME* :LOCAL T)
    
    (SETQ SI:LOCAL-HOST (SI:PARSE-HOST (FULL-NAME "LM" *DISTRIBUTION-NAME*) T))
    
    (when (and (eq *local-pathname-flavor* 'fs:mac-pathname)
	       (fboundp 'si:get-startup-default-device))
      (Send si:local-Host :Set-Default-Device (si:get-startup-default-device)))	       ;3.09.88
    
    (NET:SET-LOGICAL-PATHNAME-HOST (FULL-NAME "SYS" *DISTRIBUTION-NAME*)
				   :PHYSICAL-HOST SI:LOCAL-HOST
				   :TRANSLATIONS *DEFAULT-SYS-TRANSLATIONS*
				   :LOCAL-ONLY T
				   :IF-EXISTS NIL)     ; if already exists, don't replace
    
    (ADD-ATTRIBUTE "SYS" :HOST :NAME-AS-FILE-COMPUTER "SYS" :NAMESPACE *DISTRIBUTION-NAMESPACE*)
    (ADD-ATTRIBUTE "SYS" :HOST :STRING-FOR-PRINTING "SYS" :NAMESPACE *DISTRIBUTION-NAMESPACE*)
    
    (ADD-OBJECT *DISTRIBUTION-NAME* :SITE :NAMESPACE *DISTRIBUTION-NAMESPACE*
		:ATTRIBUTES (LIST :TIMEZONE 6 :SITE-NAME *DISTRIBUTION-NAME*))
    
    (net:setup-medium-desirability)
    
    (INITIALIZATIONS 'NET:*NETWORK-WARM-INITIALIZATION-LIST* T)
    (INITIALIZATIONS 'SI:SITE-OPTION-INITIALIZATION-LIST T)))))


(DEFPARAMETER *DUMMY-NETWORK-ADDRESSES* '((:CHAOS #X0100) (:IP #xb1000000)))

(DEFUN INITIALIZE-NAME-SERVICE (&OPTIONAL (NAMESPACE NIL NAMESPACE-SPECIFIED)
				           (DISPLAY T))
  "Do all name service (& network) initializations from scratch (destroying any local namespace updates).
   If NAMESPACE is specified it will broadcast for a server of that namespace
    (but will NOT override a qualified pack host name for this machine).
   If DISPLAY, then the resulting namespace configuration will be shown on *STANDARD-OUTPUT*."

  (WHEN NAMESPACE-SPECIFIED 
     (SETF NAME:*DEFAULT-WHO-AM-I-DOMAIN* (WHEN NAMESPACE (STRING NAMESPACE))))

  (INITIALIZE-DISTRIBUTION-NAMESPACE *DUMMY-NETWORK-ADDRESSES*  T)
  (INITIALIZE-LOCAL-NAME-SERVICE T)
  (INITIALIZE-REMOTE-NAME-SERVICE T)

  ;; Replace what we wiped out
  ;; DONT DO THIS ANYMORE NOW THAT MISSES ARE CACHED
;x  (WHEN USER-ID
;x     (UNLESS (LOOKUP-OBJECT USER-ID :USER :READ-ONLY T)
;x       (ADD-OBJECT USER-ID :USER :LOCAL T)))

  (IF DISPLAY 
    (SHOW-NAMESPACE-CONFIGURATION)
    ;; Else
    (VALUES
      *NAMESPACE-SEARCH-LIST*
      *ALL-KNOWN-NAMESPACES*)))

(ADD-INITIALIZATION "Initialize Distribution Namespace" '(INITIALIZE-DISTRIBUTION-NAMESPACE *DUMMY-NETWORK-ADDRESSES*)
		    '(:SYSTEM :NORMAL))

(DEFUN IDENTIFY-SELF  (&OPTIONAL (MY-NAME (COMPLETE-MACHINE-NAME))
		       (BROADCAST-INITIALLY *BROADCAST-INITIALLY*)
		       DEBUG
		       (CATCH-ERRORS *CATCH-ERRORS-WHILE-BOOTING*))
  
  ;; cold-loaded without W
  (UNLESS *WINDOW-SYSTEM-CHOOSE-FUNCTION*
    (SETF *WINDOW-SYSTEM-CHOOSE-FUNCTION* (SYMBOL-REF "W" "MENU-CHOOSE")))
  (UNLESS *CURRENT-WINDOW-VAR* 
    (SETF *CURRENT-WINDOW-VAR* (SYMBOL-REF "W" "MOUSE-WINDOW")))
  
  (SETF MY-NAME (STRING-UPCASE MY-NAME))

  (LET* (NEW-NETWORK-NS
	 network
	 (DOMAIN "")
	 (WHO-AM-I-NAME (STRING-UPCASE (ACTUAL-WHO-AM-I-NAME MY-NAME)))
	 (PERMANENT-DOMAIN-CHANGE T)
	 SERVER-NAME
	 SERVER
	 (SYSTEM-TYPE :LISPM)
         (CONTROLLER-NUMBER 1)
	 ME
         CHOICE
         ALLOW-SAVE-OPTION
	 (SECONDARY-TITLE-STRING
	   (FORMAT NIL "~%    Choose a network initialization alternative:               [T/O=~D mins]" *IDENTIFY-TIMEOUT*))
	 (MAIN-TITLE-STRING ">>> No Explorer Nameserver knows this machine as")
	 (MAIN-TITLE-FORMAT-STRING "~A ~A. ~A")
	 (MAIN-TITLE (FORMAT NIL MAIN-TITLE-FORMAT-STRING MAIN-TITLE-STRING WHO-AM-I-NAME SECONDARY-TITLE-STRING))
         (BEG-NOP-TITLE SECONDARY-TITLE-STRING)
	 (NEG-EXPL-SERVER ">>> Unsuccessful at becoming a client of an Explorer server because:~%      ~A. ~A")
	 (NEG-SYM-SERVER  ">>> Unsuccessful at contacting a Symbolics server because:~%      ~A. ~A")    
	 (NEG-LOCAL-SERVER  ">>> Unsuccessful at loading a local namespace because:~%      ~A. ~A")    
	 (NEG-CONVERT      ">>> Unsuccessful at converting an existing configuration because:  ~%      ~A. ~A")
	 (AFTER-NAME-CHANGE ">>> The name of this machine is now ~A. ~A")
	 (NETWORK-TYPE (CAR *AVAILABLE-NETWORK-TYPES*))
	 (TITLE (IF BROADCAST-INITIALLY MAIN-TITLE BEG-NOP-TITLE))
	 (SITEINFO-PATH "LM:SITE;SITEINFO.XFASL")
         (RETRY-STRING "Try (again) to locate an Explorer Nameserver that knows about ~A ")
	 (MAIN-MENU-LAYOUT
	   `(("" :NO-SELECT T)
	     (,(PAD "Change the name of this machine and return to this menu")  :VALUE :NEW-NAME)
	     ("" :NO-SELECT T)
	     (,(PAD (FORMAT NIL RETRY-STRING WHO-AM-I-NAME))  :VALUE :RETRY)
	     ("" :NO-SELECT T)
	     (,(PAD "Try to contact a specific Explorer Nameserver directly")  :VALUE :DIRECT)
	     ("" :NO-SELECT T)
	     (,(PAD "Convert an existing Network Configuration file into a namespace") :VALUE :CONVERT)
	     ("" :NO-SELECT T)
	     (,(PAD "Create a new network namespace after booting") :VALUE :CREATE)
	     ("" :NO-SELECT T)
	     (,(PAD "Try to contact a specific non-Explorer nameserver") :VALUE :FOREIGN)
	     ("" :NO-SELECT T)
             (,(PAD "Try loading local files to use this machine as a temporary nameserver  ") :VALUE :FORCE-LOCAL)
	     ("" :NO-SELECT T)
	     ("" :NO-SELECT T)
	     (,(PAD "Run stand-alone (no networking)  [* DEFAULT *]") :VALUE NIL)))
	 (WINDOWS (AND *WINDOW-SYSTEM-CHOOSE-FUNCTION* (FBOUNDP *WINDOW-SYSTEM-CHOOSE-FUNCTION*)))
         (NET-ADDR-DOC-STRING "Enter an address which matches the network type chosen;
  The address can be a number or a string respresenting an alternate format."))
    
    (WHEN *NON-STANDARD-BOOT-ALTERNATIVE*
      (SETF DOMAIN       (SECOND  *NON-STANDARD-BOOT-ALTERNATIVE*)
	    NETWORK-TYPE (THIRD   *NON-STANDARD-BOOT-ALTERNATIVE*)
	    SERVER       (FOURTH  *NON-STANDARD-BOOT-ALTERNATIVE*)
	    ME           (FIFTH  *NON-STANDARD-BOOT-ALTERNATIVE*)
	    CONTROLLER-NUMBER (SIXTH *NON-STANDARD-BOOT-ALTERNATIVE*)))
    
    (LOOP 
      DO
      (SETQ *NET-DOMAIN* NIL)
      (SELECT 
	(SETF CHOICE
	      (COND
		((NOT WINDOWS)
                 :COLD)

		((NULL *network-environment*)
		 :no-networking)
		
		(*NON-STANDARD-BOOT-ALTERNATIVE*
		 (CAR *NON-STANDARD-BOOT-ALTERNATIVE*))
		
		(BROADCAST-INITIALLY :RETRY)
		
		(:OTHERWISE
		 (WITH-TIMEOUT ((* *IDENTIFY-TIMEOUT* 60 60) (SEND (EVAL *CURRENT-WINDOW-VAR*) :DEEXPOSE) :TIMEOUT)
		   (FUNCALL *WINDOW-SYSTEM-CHOOSE-FUNCTION*
			    MAIN-MENU-LAYOUT
			    :LABEL TITLE
			    ;; SPECIFY NEAR-MODE TO OVERCOME A WINDOW-LOCK PROBLEM - LSS
			    :NEAR-MODE `(:POINT ,(SEND (SYMBOL-VALUE
							 (FIND-SYMBOL "DEFAULT-SCREEN" 'W))
						       :WIDTH) 0)
			    :ITEM-ALIGNMENT :LEFT      
			    :DEFAULT-ITEM (SECOND MAIN-MENU-LAYOUT))))))
	
        (:COLD
	 (FORMAT T "~%~% *** Running stand-alone in a cold climate. ***~%~%")
	 (RETURN))

	(:no-networking
	 (FORMAT T "~%~% *** Running stand-alone (no networking). ***~%~%")
	 (RETURN))
	
	(:TIMEOUT
	 (FORMAT T "~%~% *** MENU TIMEOUT: Running stand-alone (no networking). ***~%~%")
	 (RETURN))
	
	(:CREATE
	 (FORMAT T "~%~% *** To create a new network namespace after booting has completed, 
     select the Namespace Editor from the System Menu.~2%")
	 (RETURN))
	
	(:CONVERT
	 (WHEN (CVV-WITH-ABORT
		 :HANDLE
		 `(""
		   (,(LOCF DOMAIN)   "Namespace name" 
		    :DOCUMENTATION "L: input a new value from the keyboard, R: edit this value;
 Enter a name to call the new namespace to be created."
		    :STRING)
		   (,(LOCF SITEINFO-PATH) "Pathname of a NetConfig Siteinfo file" 
		    :DOCUMENTATION
		    "L: input a new value from the keyboard, R: edit this value;
 If the pathname contains the host of an unknown host, you will be asked for its address."
		    :STRING)
                   "")
		 :EXTRA-WIDTH 15
		 :LABEL "Convert siteinfo file into network namespace")
	   
	   
	   (CONDITION-CASE-IF CATCH-ERRORS (CONDITION)
	       (PROGN
		
		(LET* ((COLON-IX (POSITION #\: SITEINFO-PATH))
		       (HOST-NAME (IF COLON-IX (SUBSEQ SITEINFO-PATH 0 COLON-IX)
				      (SETF SITEINFO-PATH (STRING-APPEND "SITEINFO-HOST:" SITEINFO-PATH))
				      "SITEINFO-HOST"))
		       INNER-ABORT)
		  (UNLESS (SI:PARSE-HOST HOST-NAME T)
		    (IF (CVV-WITH-ABORT
			  :HANDLE
			  `(""
			    (,(LOCF NETWORK-TYPE) "Network type for remote file access" :CHOOSE ,*AVAILABLE-NETWORK-TYPES*)
			    (,(LOCF ME)     ,(FORMAT NIL "Network address of this host [~A]" (RELATIVE-MACHINE-NAME))
			     :DOCUMENTATION ,NET-ADDR-DOC-STRING :SEXP)
			    (,(LOCF SERVER) ,(FORMAT NIL "Network address of the remote host [~A]" HOST-NAME)
			     :DOCUMENTATION ,NET-ADDR-DOC-STRING :SEXP)
			    ""
			    (,(LOCF SYSTEM-TYPE) ,(FORMAT NIL "System software type of the remote host [~A]" HOST-NAME)
			     :MENU *CONVERT-SYSTEM-TYPES*)
			    "")
			  :EXTRA-WIDTH 15
			  :LABEL "Enter information required to get a remote siteinfo file")
			;; THEN create this host in the Distribution namespace
			(THEN
			  (INITIALIZE-DISTRIBUTION-NAMESPACE (LIST (LIST NETWORK-TYPE ME)) T NIL)
			  
			  (ADD-OBJECT HOST-NAME :HOST :NAMESPACE *DISTRIBUTION-NAME*
				      :ATTRIBUTES (LIST '(:ADDRESSES :GROUP) (LIST (LIST NETWORK-TYPE SERVER))
							'(:SERVICES :GROUP) (LIST (GET-FILE-SERVICE NETWORK-TYPE))
							:SYSTEM-TYPE SYSTEM-TYPE)
				      :PRE-DELETE T))
			;; ELSE
			(SETF INNER-ABORT T)))
		  
		  (UNLESS INNER-ABORT
		    (IF DEBUG
			(FERROR NIL "SOME DUMMY NAMED ~A PUT YOU IN DEBUG MODE" USER-ID)
			;; else
                        (LET ((USER-ID "BOOT"))
			  (COMPILER-LET ((INHIBIT-STYLE-WARNINGS-SWITCH T))
    			    (NET:CONVERT-SITEINFO DOMAIN SITEINFO-PATH))))
		    (SETF *NET-DOMAIN* DOMAIN) 
		    (RETURN (SETF NEW-NETWORK-NS T)))))
	     
	     (ERROR
	      (SETF TITLE (FORMAT NIL NEG-CONVERT
				  (SEND CONDITION :SEND-IF-HANDLES :REPORT-STRING) SECONDARY-TITLE-STRING))))))
	
	(:NEW-NAME
	 (WHEN (CVV-WITH-ABORT
		 :HANDLE
		 `(""
		   (,(LOCF MY-NAME) "New machine (pack) name" :STRING)
		   (*DEFAULT-WHO-AM-I-DOMAIN* "Desired namespace (optional)" :STRING)
		   (,(LOCF PERMANENT-DOMAIN-CHANGE) "Save desired namespace in pack-name?" :BOOLEAN)
		   "")
		 :EXTRA-WIDTH 15
		 :LABEL "Change machine name")

           (WHEN (OR (ZEROP (LENGTH *DEFAULT-WHO-AM-I-DOMAIN*))
		     (STRING-EQUIV *DEFAULT-WHO-AM-I-DOMAIN* "nil"))
	     (SETQ *DEFAULT-WHO-AM-I-DOMAIN* NIL))

           (SETF MY-NAME (STRING-UPCASE MY-NAME))
	   (WHEN (STRINGP *DEFAULT-WHO-AM-I-DOMAIN*)
	     (SETF *DEFAULT-WHO-AM-I-DOMAIN* (STRING-UPCASE *DEFAULT-WHO-AM-I-DOMAIN*)))
           (WHEN (AND *DEFAULT-WHO-AM-I-DOMAIN* PERMANENT-DOMAIN-CHANGE)
	     (SETF MY-NAME (RELATIVE-NAME MY-NAME)))
           (SETF WHO-AM-I-NAME (ACTUAL-WHO-AM-I-NAME MY-NAME))
	   (WHEN PERMANENT-DOMAIN-CHANGE
	     (SETF MY-NAME WHO-AM-I-NAME))
	   
           ;; Replace the string in the menu that mentions the machine name
           (LOOP FOR ENTRY IN MAIN-MENU-LAYOUT DO
		 (WHEN (MEMBER :RETRY ENTRY :TEST 'EQ)
		   (RPLACA ENTRY (PAD (FORMAT NIL RETRY-STRING WHO-AM-I-NAME)))))
	   
           (UNLESS (OR DEBUG (NOT (VALIDATE-PARM 'MY-NAME MY-NAME :NO-ERROR)))
             (SI:SET-PACK-HOST-NAME MY-NAME)
	     (INITIALIZE-DISTRIBUTION-NAMESPACE NIL T NIL))
	   (SETF TITLE
		 (FORMAT NIL AFTER-NAME-CHANGE (IF DEBUG MY-NAME (COMPLETE-MACHINE-NAME)) SECONDARY-TITLE-STRING))
	   ))      
	
        (:RETRY   
	 (CONDITION-CASE-IF CATCH-ERRORS (CONDITION)
	     (COND
	      (DEBUG (FERROR NIL "DEBUG :RETRY"))
	      
	      ((AND (MULTIPLE-VALUE-SETQ (DOMAIN SERVER-NAME SERVER ME NETWORK) (WHO-AM-I MY-NAME))
		    (NULL SERVER-NAME))		; => short-circuit who-am-i
	       (SETQ *NET-DOMAIN* DOMAIN)
	       (BUILD-NS-SEARCH-LIST)
	       (RETURN))
	      
             ((NULL DOMAIN)			;;; No response
	      (SETF TITLE (FORMAT NIL MAIN-TITLE-FORMAT-STRING MAIN-TITLE-STRING WHO-AM-I-NAME SECONDARY-TITLE-STRING)))
	     
  	     ((CREATE-PUBLIC-NAMESPACE DOMAIN SERVER-NAME SERVER ME NETWORK)
              (FORMAT T "~2% *** Successfully contacted a server (~A) for namespace ~A~2%"
		      (STRING-UPCASE SERVER-NAME) (STRING-UPCASE DOMAIN))
	      (RETURN (SETF NEW-NETWORK-NS T)))

	     (:OTHERWISE
	      (FERROR NIL "???")))

	   (ERROR
	      (SETF TITLE (FORMAT NIL NEG-EXPL-SERVER (SEND CONDITION :REPORT-STRING)  SECONDARY-TITLE-STRING)))))
	
	(:DIRECT
	 (WHEN (OR *NON-STANDARD-BOOT-ALTERNATIVE*
		   (PROGN
		     (CVV-WITH-ABORT
		       :HANDLE
		       `(""
			 (,(LOCF DOMAIN) "Namespace name" :STRING)
			 (,(LOCF NETWORK-TYPE) "Network type" :CHOOSE ,*AVAILABLE-NETWORK-TYPES*)
			 (,(LOCF ME)     "Network address of this machine" 
			            :DOCUMENTATION ,NET-ADDR-DOC-STRING :SEXP)
			 (,(LOCF SERVER) "Network address of the Explorer Nameserver" 
			            :DOCUMENTATION ,NET-ADDR-DOC-STRING :SEXP)
			 (,(LOCF CONTROLLER-NUMBER) "Ethernet Controller number for these addresses" :SEXP)
			 "")
                       :EXTRA-WIDTH 10
		       :LABEL "Contact Explorer Nameserver")))
	   
           (CONDITION-CASE-IF CATCH-ERRORS (CONDITION)
	     (PROGN
               (VALIDATE-PARM "Namespace name" DOMAIN)
	       (VALIDATE-PARM "Network address of this machine" ME)
	       (VALIDATE-PARM "Network address of the Explorer Nameserver" SERVER)
               (WHEN DEBUG (FERROR NIL "DEBUG :DIRECT"))
  	       (WHEN (CREATE-PUBLIC-NAMESPACE DOMAIN "BOOTSTRAP-NAMESPACE-SERVER"
						     (BUILD-ADDRESS-LIST NETWORK-TYPE SERVER CONTROLLER-NUMBER)
						     (BUILD-ADDRESS-LIST NETWORK-TYPE ME CONTROLLER-NUMBER))
	           (SETF ALLOW-SAVE-OPTION (NOT *NON-STANDARD-BOOT-ALTERNATIVE*))
                   (FORMAT T "~2% *** Successfully contacted a server for namespace ~A~2%" DOMAIN)
	           (RETURN (SETF NEW-NETWORK-NS T))))
	     (ERROR
  	         (SETF *NON-STANDARD-BOOT-ALTERNATIVE* NIL)	;allow some other choice
	         (SETF TITLE (FORMAT NIL NEG-EXPL-SERVER (SEND CONDITION :REPORT-STRING) SECONDARY-TITLE-STRING))))))
	
	(:FOREIGN
	 (WHEN (OR *NON-STANDARD-BOOT-ALTERNATIVE*
	           (CVV-WITH-ABORT
		       :HANDLE
		       `(""
			 (,(LOCF ME)     "Chaos address of this machine" :NUMBER)
			 (,(LOCF SERVER) "Chaos address of the Symbolics Nameserver" :NUMBER)
			 (,(LOCF CONTROLLER-NUMBER) "Ethernet Controller number for these addresses" :SEXP)
			 "")
                       :EXTRA-WIDTH 10
		       :LABEL "Contact Symbolics nameserver"))
           (CONDITION-CASE-IF CATCH-ERRORS (CONDITION)
             (PROGN
               (WHEN DEBUG (FERROR NIL "DEBUG :SYMBOLICS"))
	       (UNLESS (SETF DOMAIN (SETUP-SYMBOLICS-CLIENT SERVER ME CONTROLLER-NUMBER))
		 (FERROR NIL "No server responded to WHO-AM-I"))
  	       (SETF ALLOW-SAVE-OPTION (NOT *NON-STANDARD-BOOT-ALTERNATIVE*))
               (FORMAT T "~2% *** Successfully contacted a server for namespace ~A~2%" DOMAIN)
	       (RETURN (SETQ NEW-NETWORK-NS T)))
	   (ERROR
	       (SETF *NON-STANDARD-BOOT-ALTERNATIVE* NIL)	;allow some other choice
	       (SETF TITLE (FORMAT NIL NEG-SYM-SERVER (SEND CONDITION :REPORT-STRING) SECONDARY-TITLE-STRING))))))
	
        (:FORCE-LOCAL
	   (WHEN (OR *NON-STANDARD-BOOT-ALTERNATIVE*
		       (CVV-WITH-ABORT :HANDLE
	                  `(""
			    (,(LOCF DOMAIN) "Name of the local namespace to try loading" :STRING)
			    "")
			  :EXTRA-WIDTH 20
			  :LABEL "Force local namespace load"))
           (CONDITION-CASE-IF CATCH-ERRORS (CONDITION)
              (PROGN
		 (FORCE-LOCAL-SERVER-BOOT DOMAIN :STANDALONE T)
		 (IF (LIST-OBJECT (RELATIVE-NAME MY-NAME) :HOST
				  :NAMESPACE DOMAIN :BRIEF T :CHASE-ALIASES NIL :MERGE-ALIASES NIL)
		     (THEN
                        (SETQ *NET-DOMAIN* DOMAIN)
                        (FORMAT T "~2% *** Successfully started a local server for namespace ~A~2%" DOMAIN)
 	                (SETF ALLOW-SAVE-OPTION (NOT *NON-STANDARD-BOOT-ALTERNATIVE*))
			(RETURN (SETQ NEW-NETWORK-NS T)))
		     (ELSE
		        (FERROR NIL "There is still no network namespace which contains a host called ~A"
				(RELATIVE-NAME MY-NAME)))))

	     (ERROR 
	       (SETF *NON-STANDARD-BOOT-ALTERNATIVE* NIL)	;allow some other choice
	       (SETF TITLE (FORMAT NIL NEG-LOCAL-SERVER (SEND CONDITION :REPORT-STRING) SECONDARY-TITLE-STRING))))))
	
	(NIL
	 (FORMAT T "~%~% *** Running stand-alone (no networking). ***~%~%")
         (SETF ALLOW-SAVE-OPTION (NOT *NON-STANDARD-BOOT-ALTERNATIVE*))
	 (RETURN)))
      
      (SETF BROADCAST-INITIALLY NIL))		;NEXT TIME AROUND, BE SURE AND ASK
    
    ;; Note that we havn't set this if they set *NON-STANDARD-BOOT-ALTERNATIVE* on a previous pass
    (WHEN (AND ALLOW-SAVE-OPTION 
               (WITH-TIMEOUT ((* *IDENTIFY-TIMEOUT* 60 60) NIL)
  	         (YES-OR-NO-P "Should your choice be the default for booting a disk-saved version of this band?")))
      (SETF *NON-STANDARD-BOOT-ALTERNATIVE*
	    (LIST CHOICE DOMAIN NETWORK-TYPE SERVER ME CONTROLLER-NUMBER)))

    NEW-NETWORK-NS))

(DEFUN CREATE-PUBLIC-NAMESPACE (DOMAIN SERVER-NAME SERVER ME &optional (NETWORK :chaos))
  (LET* ((NET-NS (FIND-KNOWN-NAMESPACE DOMAIN))
	 BOOTED-NS
         (QUALIFIED-SERVER-NAME (FULL-NAME SERVER-NAME *DISTRIBUTION-NAME*))
	 DOMAIN-OBJ
         SERVER-LIST
	 (BOOTSTRAP-SERVER-LIST (LIST QUALIFIED-SERVER-NAME)))
    
    ;; I think it is ok (and desirable) to throw this away for the
    ;; case where we are trying again after a partially successful bootstrap operation
    (WHEN NET-NS
      (DELETE-NAMESPACE (SEND NET-NS :DOMAIN-NAME))
      (SETF NET-NS NIL))

    (UNLESS (LISTP SERVER)
      (SETF SERVER (LIST (or network :CHAOS) SERVER)))
    (UNLESS (LISTP ME)
      (SETF ME (LIST (or network :CHAOS) ME)))
    (INITIALIZE-DISTRIBUTION-NAMESPACE (LIST ME) T NIL)
    
    (UNWIND-PROTECT
     (UNLESS NET-NS
      (ADD-OBJECT SERVER-NAME :HOST :NAMESPACE *DISTRIBUTION-NAME*
		  :ATTRIBUTES (LIST '(:ADDRESSES :GROUP) (LIST SERVER)
         		            '(:SERVICES :GROUP) (LIST (GET-FILE-SERVICE (CAR SERVER)))))
      
      ;; Go ahead and get a cache built, so subsequent lookups won't have to be repeated
      (SETF NET-NS
	    (ADD-NAMESPACE DOMAIN :PUBLIC NIL :BOOTSTRAP-SERVERS BOOTSTRAP-SERVER-LIST))

      (SEND NET-NS :REMOTE-CALL)		;this will get the namespace object & servers cached

      ;; Set up the other servers as bootstrap servers too.  This is because recursive
      ;; namespace calls use only the bootstrap server list and if the orignal answering
      ;; server goes down, they are stuck.  Do this here so if we get an error they can
      ;; start over
      (WHEN (SETF DOMAIN-OBJ (SEND NET-NS :DOMAIN-QUERY))
	(SETF SERVER-LIST (GET-ATTRIBUTE-VALUE DOMAIN-OBJ :SERVERS)))
      (LOOP FOR SERVER IN SERVER-LIST 
         WITH UNQUALIFIED-SERVER-NAME
	 WITH FORMATTED-SERVER-OBJ DO
	 (SETF UNQUALIFIED-SERVER-NAME (SPLIT-NAME SERVER))
         (WHEN (SETF FORMATTED-SERVER-OBJ (NAME:LIST-OBJECT UNQUALIFIED-SERVER-NAME :HOST :NAMESPACE NET-NS))
	   (ADD-OBJECT UNQUALIFIED-SERVER-NAME :HOST :NAMESPACE *DISTRIBUTION-NAME*
		       :ATTRIBUTES (THIRD FORMATTED-SERVER-OBJ))
           (LET ((FULL-NAME (FULL-NAME UNQUALIFIED-SERVER-NAME *DISTRIBUTION-NAME*)))
              (UNLESS (MEMBER FULL-NAME BOOTSTRAP-SERVER-LIST :TEST 'STRING-EQUIV)
   	         (PUSH-END FULL-NAME BOOTSTRAP-SERVER-LIST)))))

      (SEND NET-NS :NEW-BOOTSTRAP-SERVERS BOOTSTRAP-SERVER-LIST)
      (SETF BOOTED-NS NET-NS))

      ;; clean-up clause
      (WHEN (AND NET-NS (NULL BOOTED-NS))
	(DELETE-NAMESPACE (SEND NET-NS :DOMAIN-NAME))))
    
    (UNLESS (ON-SEARCH-LIST DOMAIN)
      (PUSH NET-NS *NAMESPACE-SEARCH-LIST*))

    (SETQ *NET-DOMAIN* DOMAIN)
    NET-NS))    

))

#!C
; From file IP.LISP#> IP; MR-X:
#10R IP#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "IP"))
                          (SI:*LISP-MODE* :Common-lisp)
                          (*READTABLE* Sys:Common-lisp-readtable)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* Sys::*common-lisp-symbol-substitutions*))
  (COMPILER#:PATCH-SOURCE-FILE "MR-X: IP; IP.É#É"


(defvar net:*setup-local-only* nil "If bound to t do not send icmp packets for routing info.")

(DEFUN enable-ip-service (&optional (local-only t))
  "Sets up the protocol handler list for use by IP."
  (DECLARE (SPECIAL *udp-protocol-ip-id* *udp-handler* *tcp-protocol* *tcp-handler* icmp-protocol))
  (LET (network-broadcast-addr route-entry)
    (SETF *ip-handler* (MAKE-INSTANCE (IF (TYPEP *ip-handler* 'ip-handler)
					  *ip-handler*
					  'ip-handler)))
    (SETF *ip-pkt-sent-list* ())
    (SETF *ip-pkt-rvcd-list* ())
    (SETF *ip-id-counter* (MOD (time:microsecond-time) 65536))
    (WHEN (VARIABLE-BOUNDP *udp-handler*)
      (PUSH (CONS :udp '*udp-handler*) *ip-protocol-handler-alist*)
      (PUSH (CONS *udp-protocol-ip-id* '*udp-handler*) *ip-protocol-handler-alist*))
    (WHEN (VARIABLE-BOUNDP *tcp-handler*)
      (PUSH (CONS :tcp '*tcp-handler*) *ip-protocol-handler-alist*)
      (PUSH (CONS *tcp-protocol* '*tcp-handler*) *ip-protocol-handler-alist*))
    (WHEN (VARIABLE-BOUNDP *icmp-handler*)
      (PUSH (CONS icmp-protocol '*icmp-handler*) *ip-protocol-handler-alist*)
      (PUSH (CONS :icmp '*icmp-handler*) *ip-protocol-handler-alist*))
    (reset-other-machines)
    (SETF ethernet::ip-ether-address-translations ())
    (SETF ethernet::*ip-arp-requests-received* 0)
    (SETF ethernet::*ip-arp-replies-sent* 0)
    (SETF ethernet::*ip-arp-requests-sent* 0)
    (SETF ethernet::*ip-arp-replies-received* 0)
    (ethernet::add-protocol *ip-ethernet-type*
			    #'(lambda (controller ip-pkt nbytes type src-addr dest-addr)
				(SEND *ip-handler* :receive-data
				      controller ip-pkt nbytes type src-addr dest-addr)))
    (reset-ip-routing-table local-only)
    (SETF (SEND *ip-handler* :timer-process)
	  (PROCESS-RUN-FUNCTION
	    '(:name "IP Packet Fragment Timer" :priority -15)
	    'ip-fragment-time-keeper))
    (enable)
    (DOLIST (addr my-addresses)
      (SETF route-entry (get-routing-entry addr))
      (SETF network-broadcast-addr
	    (LOGIOR (LOGAND addr (ip-routing-mask route-entry))
		    (LOGXOR #xFFFFFFFF (ip-routing-mask route-entry))))
      (unless net:*setup-local-only*
	(DOTIMES (dummy 5)
	  (IF *gateway-host-p*
	      (icmp-address-mask-transmit address-mask-reply 0 1 network-broadcast-addr)
	      (icmp-address-mask-transmit address-mask-request 0 1 network-broadcast-addr))
	  (sleep .5 "Setup IP Routing"))))))

(defvar *really-broadcast* nil "Bind to t if ip broadcast really means send to all nets.")

(DEFMETHOD (ip-handler :transmit) (data protocol destination-address
				   &optional (length (length data))
				   (source-address (closest-local-address destination-address))
				   (precedence 0)
				   (delay 0)
				   (throughput 0)
				   (reliability 0)
				   (fragmentp t)
				   (options nil))
  "This does the initial setup of the IP packet and calls the IP-TRANSMIT function for sending.
The parameters are used as follows:
DATA - The data to be sent
PROTOCOL - the sending protocol. i.e. :UDP, :TCP, :ICMP
DESTINATION-ADDRESS - The Ip address of the destination.
Optional parameters are as follows:
LENGTH - The length of the data.
SOURCE-ADDRESS - IP address of the source.
PRECEDENCE - Numeric value from 0 to 7.
DELAY - 0 = Normal delay, 1 = Low delay.
THROUGHPUT - 0 = Normal Throughput, 1 = High Throughput.
RELIABILITY - 0 = Normal Reliability, 1 = High Reliability.
FRAGMENTP - t = May fragment this packet, nil = Don't fragment.
OPTIONS  - A list of options.  Each element in this list is a sublist beginning with a keyword and elements as follows:
:SECURITY security compartments handling transmission
  Security is the keyword :SECURITY followed by the integers representing
  the level of security, the compartments used, the handling restrictions
  and the transmission control.
:LOOSE-SRR <addr> [<addr> ...] 
  The Loose Source and Record Route is the keyword :LOOSE-SRR followed by one or more addresses to use as the route.
:STRICT-SRR <addr> [<addr> ...] 
  The Strict Source and Record Route is the keyword :STRICT-SRR followed by one or more addresses for the route to use.
:RECORD <number of addresses> 
  The Record route is the keyword :RECORD followed by the number of addresses to record.
:STREAM-ID id 
  The Stream Identifier is the keyword :STREAM-ID followed by the identifier for the stream.
:TIMESTAMP flag <number of stamps> [<addr> ...]  
  The Timestamp is the keyword :TIMESTAMP followed by a Flag field which
  can take the values of 0 - for Timestamps only, 1 - Get address as
  well as timestamps, and 3 - Specify the addresses to get timestamps
  from.  The number of stamps follows the flag field and is followed by
  the addresses if the flag field is a 3."
  ;; Fragment down to *max-ethernet-packet-bytes*.  
  ;; Further fragmentation will be done if the routing logic determines it is necessary.
  (DECLARE (inline copy-pkt))
  (LET ((default-cons-area *ip-area*)
	(start-time (time:fixnum-microsecond-time))
	ip-pkt header-length)
    (UNWIND-PROTECT
	(PROGN
	  (SETF ip-pkt (ALLOCATE-RESOURCE 'ip-packet))
	  (SETF header-length (parse-ip-options ip-pkt options))
	  (SETF (ip-version ip-pkt) ip-version)
	  (SETF (ip-precedence ip-pkt) precedence)
	  (SETF (ip-delay ip-pkt) delay)
	  (SETF (ip-thruput ip-pkt) throughput)
	  (SETF (ip-reliability ip-pkt) reliability)
	  (SETF (ip-tos-reserved ip-pkt) 0)	  
	  (SETF (ip-identification ip-pkt) (INCF *ip-id-counter*))
	  (SETF (ip-flags-reserved ip-pkt) 0)
	  (SETF (ip-dont-fragment-p ip-pkt) (NOT fragmentp))
	  (SETF (ip-time-to-live ip-pkt) ip-maximum-routing-time)
	  (UNLESS (NUMBERP protocol) (SETF protocol (CDR (ASSOC protocol *ip-protocol-mapping*))))
	  (SETF (ip-protocol ip-pkt) protocol)
	  (SETF (ip-src-addr ip-pkt) source-address)
	  (SETF (ip-dst-addr ip-pkt) destination-address)
	  (WHEN (> (+ length header-length) 65535)
	    (FERROR 'ip-error "IP maximum length exceeded"))
	  ;; outbound fragmentation (optimized for ethernet)
	  (DO* ((remaining-length length (- remaining-length copy-length))
		(from-offset 0 (+ from-offset copy-length))
		(frag-offset 0 (+ frag-offset max-frag-blocks))		
		(max-bytes (- *max-ethernet-packet-bytes* header-length))
		(max-frag-blocks (TRUNCATE max-bytes 8))
		(frag-copy-length (* max-frag-blocks 8))
		(frag-count 0 (1+ frag-count))
		copy-length)
	       ((ZEROP remaining-length))
	    ;; complete the header
	    (COND ((> remaining-length max-bytes)
		   (SETF copy-length frag-copy-length)
		   (SETF (ip-more-fragments-p ip-pkt) t))
		  (t (WHEN (PLUSP frag-count)
		       (INCF packet-fragments-sent (1+ frag-count))
		       (INCF packets-fragmented))
		     (SETF copy-length remaining-length)
		     (SETF (ip-more-fragments-p ip-pkt) nil)))
	    (WHEN (AND options (EQL frag-count 1))
	      (modify-header-options ip-pkt))
	    (SETF (ip-total-length ip-pkt) (+ header-length copy-length))
	    (SETF (ip-fragment-offset ip-pkt) frag-offset)
	    ;; Set up Data portion of the packet.
	    (copy-pkt data ip-pkt copy-length from-offset (TRUNCATE header-length 2))
	    (WHEN *ip-debug-mode*
              (FORMAT t "~%IP packet transmitted~%")
              (print-header ip-pkt))
	    ;; route the packet
	    (COND ((OR (EQL destination-address #xFFFFFFFF) (EQL destination-address #x00000000))
		   (DOLIST (route-entry ip-routing-table)
		     (WHEN (EQ (ip-routing-address route-entry) :direct)
		       (unless *really-broadcast*
			 (SETF (ip-dst-addr ip-pkt)
			       (LOGIOR (ip-routing-network route-entry)
				       (LOGXOR #xFFFFFFFF (ip-routing-mask route-entry)))))
		       (CONDITION-CASE ()
			   (ip-transmit ip-pkt route-entry)
			 (incomplete-routing-table)))))
		  (t (CONDITION-CASE ()
			 (ip-transmit ip-pkt)
		       (incomplete-routing-table))))))
      ;; unwind-protect cleanup
      (WHEN ip-pkt (DEALLOCATE-RESOURCE 'ip-packet ip-pkt))
      (INCF time-sending
	    (ROUND (TIME-DIFFERENCE (time:fixnum-microsecond-time) start-time) 1000)))))

(compile-flavor-methods ip-handler)

))
