;;; -*- Mode:Lisp;Package:INTERNET;Base:10 -*-
;;; This is SYS: IP; ADDRESS

(DEFCONSTANT IPA-WILD #O100) ; signals wild component of address

(DEFMACRO IPA-REF (IPA IDX) `(AREF ,IPA ,IDX))
(DEFMACRO IPA-3 (IPA) `(IPA-REF ,IPA 3))  ; MSB
(DEFMACRO IPA-2 (IPA) `(IPA-REF ,IPA 2))
(DEFMACRO IPA-1 (IPA) `(IPA-REF ,IPA 1))
(DEFMACRO IPA-0 (IPA) `(IPA-REF ,IPA 0))  ; LSB

(DEFSTRUCT (ADDRESS (:TYPE :NAMED-ARRAY-LEADER)
		    (:MAKE-ARRAY (:TYPE 'ART-16B :LENGTH 4))
		    (:CONSTRUCTOR MAKE-ADDRESS-INTERNAL))
  IPA-HOST)

(DEFUN IPA-PRINT-COMPONENT (VAL STREAM)
  (IF (= VAL IPA-WILD) (SEND STREAM :TYO #/*)
    (FORMAT STREAM "~D" VAL)))

(DEFUN IPA-PRINT-ADDRESS (A STREAM)
  (IPA-PRINT-COMPONENT (IPA-3 A) STREAM)
  (SEND STREAM :TYO #/.)
  (IPA-PRINT-COMPONENT (IPA-2 A) STREAM)
  (SEND STREAM :TYO #/.)
  (IPA-PRINT-COMPONENT (IPA-1 A) STREAM)
  (SEND STREAM :TYO #/.)
  (IPA-PRINT-COMPONENT (IPA-0 A) STREAM))

(DEFSELECT ((:PROPERTY ADDRESS SI:NAMED-STRUCTURE-INVOKE) () T)
  (:PRINT-SELF (ME STREAM IGNORE SLASHIFY-P)
    (IF SLASHIFY-P (FORMAT STREAM "#~S /"~A/"" 'ADDRESS ME)
      (IPA-PRINT-ADDRESS ME STREAM)))
  (:WHICH-OPERATIONS (&REST FOO) FOO
    '(:PRINT-SELF)))

(DEFUN (:PROPERTY ADDRESS SI:READ-INSTANCE) (IGNORE IGNORE STREAM)
  (PARSE-ADDRESS (READ STREAM)))

;;; They are compared LSB first, since that's where addresses from the same network
;;; usually differ; they ALWAYS differ there for the same class C network.
(DEFUN ADDRESS-HASH-EQUAL (TEST-ADDRESS IPA)
  (AND (= (IPA-0 TEST-ADDRESS) (IPA-0 IPA))
       (= (IPA-1 TEST-ADDRESS) (IPA-1 IPA))
       (= (IPA-2 TEST-ADDRESS) (IPA-2 IPA))
       (= (IPA-3 TEST-ADDRESS) (IPA-3 IPA))))

(DEFUN ADDRESS-HASH (A) ; no masterpiece, but it'll do fer now
  (+ (%LOGDPB (LOGAND #O177 (IPA-3 A)) #O2010
	      (%LOGDPB (IPA-2 A) #O1010
		       (IPA-1 A)))
     (LSH (IPA-0 A) -1)))

;;; Wild address usually differ in the MSB (IPA-3)
(DEFUN ADDRESS-MATCH-P (A WILD &AUX TEM)
  (AND (OR (= IPA-WILD (SETQ TEM (IPA-3 WILD))) (= TEM (IPA-3 A)))
       (OR (= IPA-WILD (SETQ TEM (IPA-2 WILD))) (= TEM (IPA-2 A)))
       (OR (= IPA-WILD (SETQ TEM (IPA-1 WILD))) (= TEM (IPA-1 A)))
       (OR (= IPA-WILD (SETQ TEM (IPA-0 WILD))) (= TEM (IPA-0 A)))))

(DEFRESOURCE TEST-ADDRESS () :CONSTRUCTOR (MAKE-ARRAY 4 :TYPE ART-16B))

(DEFVAR *ADDRESS-TABLE*
	(MAKE-HASH-TABLE :SIZE 100 :COMPARE-FUNCTION 'ADDRESS-HASH-EQUAL
			 :HASH-FUNCTION 'ADDRESS-HASH))

(DEFUN PARSE-ADDRESS-COMPONENT (STRING FROM TO)
  (IF (AND (= (- TO FROM) 1) (= (AREF STRING FROM) #/*))
      IPA-WILD
    (LET ((NUMBER (PARSE-NUMBER STRING FROM TO 10 T)))
      (IF (OR (> NUMBER 255) (MINUSP NUMBER))
	  (FERROR () "Number (~D) out of range in Internet address" NUMBER)
	NUMBER))))

(DEFUN MAKE-ADDRESS (ARRAY &OPTIONAL HOST)
  (LET ((IPA (MAKE-ADDRESS-INTERNAL)))
    (AND HOST (SETF (IPA-HOST IPA) HOST))
    (COPY-ARRAY-CONTENTS ARRAY IPA)
    IPA))
  
(DEFUN IPA-INTERN (ADDRESS)
  (OR (GETHASH ADDRESS *ADDRESS-TABLE*)
      (LET ((IPA (MAKE-ADDRESS ADDRESS)))
	(PUTHASH IPA IPA *ADDRESS-TABLE*))))
  
(DEFUN PARSE-ADDRESS (STRING &OPTIONAL (FROM 0) (TO (STRING-LENGTH STRING)))
  (USING-RESOURCE (TEM TEST-ADDRESS)
    (DO ((LOCAL-TO 0) (IPA-IDX 3))
	((= IPA-IDX -1) (IPA-INTERN TEM))
      (SETQ LOCAL-TO (STRING-SEARCH-CHAR #/. STRING FROM TO))
      (IF (NULL LOCAL-TO)
	  (IF (ZEROP IPA-IDX) (SETQ LOCAL-TO TO)
	    (FERROR () "Not enough fields for an Internet address")))
      (SETF (IPA-REF TEM IPA-IDX) (PARSE-ADDRESS-COMPONENT STRING FROM LOCAL-TO))
      (DECF IPA-IDX)
      (SETQ FROM (+ LOCAL-TO 1)))))