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

;;; The format for entries is:
;;;
;;; NET : NET-ADDR : NETNAME :
;;; GATEWAY : ADDR, ADDR : NAME : CPUTYPE : OPSYS : PROTOCOLS :
;;; HOST : ADDR, ALTERNATE-ADDR (if any): HOSTNAME,NICKNAME : CPUTYPE :
;;;   OPSYS : PROTOCOLS :
;;;
;;; Where:
;;;  ADDR = internet address in decimal, e.g., 26.0.0.73
;;;  CPUTYPE = machine type (PDP-11/70, VAX-11/780, FOONLY-F3, C/30, etc.)
;;;  OPSYS = operating system (UNIX, TOPS20, TENEX, ITS, etc.)
;;;  PROTOCOLS = transport/service (TCP/TELNET,TCP/FTP, etc.)
;;;  : (colon) = field delimiter
;;;  :: (2 colons) = null field
;;;
;;; See RFC810 for more details.

(DEFUN NMAPCAR (&FUNCTIONAL FUNCTION LIST)
  "Destructive map over the LIST with FUNCTION"
  (DO ((TAIL LIST (CDR TAIL)))
      ((NULL TAIL))
    (SETF (CAR TAIL) (FUNCALL FUNCTION (CAR TAIL)))))

(DEFUN KEY-INTERN (STRING)
  ;; These are checks for parser BD.  Better safe than sorry
  (IF (ZEROP (STRING-LENGTH STRING))
      (FERROR () "Attempt to intern null string while parsing host table"))
  (IF (STRING-SEARCH-SET '(#\Space #\Newline #\: #\\) STRING)
      (FERROR () "Attempt to intern funny string ~S while parsing host table"))
  (INTERN (STRING-UPCASE STRING) PKG-KEYWORD-PACKAGE))
    
(DEFVAR *IDX-VAR*)
(DEFVAR *BEGIN-VAR*)
(DEFVAR *LINE-VAR*)
(DEFVAR *TEMPORARY*)
(DEFVAR *FIELD-VAR*)

(DEFVAR *DEBUG-PARSER-MACROS* NIL "T causes expansion to include diagnostics")

(DEFMACRO PARSING-ALONG ((LINE-VAR FIELD-VAR) &BODY BODY)
  (LET ((IDX-VAR (GENTEMP "I"))
	(BEGIN-VAR (GENTEMP "B"))
	(TEMPORARY-VAR (GENTEMP "T")))
    `(COMPILER-LET ((*IDX-VAR* ',IDX-VAR)
		    (*BEGIN-VAR* ',BEGIN-VAR)
		    (*LINE-VAR* ',LINE-VAR)
		    (*FIELD-VAR* ',FIELD-VAR)
		    (*TEMPORARY* ',TEMPORARY-VAR))
       (LET ((,IDX-VAR -1) (,BEGIN-VAR) (,TEMPORARY-VAR))
	 ,@BODY))))

(DEFMACRO PARSE-ACT (&BODY AFTER-COLON &AUX (TAG (GENSYM)))
  `(TAGBODY
       (SETQ ,*FIELD-VAR* NIL)
       ,TAG
       (SETQ ,*BEGIN-VAR* (+ ,*IDX-VAR* 1))
       (SETQ ,*IDX-VAR* (STRING-SEARCH-SET ",:" ,*LINE-VAR* ,*BEGIN-VAR*))
       (UNLESS (= ,*IDX-VAR* ,*BEGIN-VAR*)
	 (SETQ ,*TEMPORARY* (STRING-TRIM " " (SUBSTRING ,*LINE-VAR* ,*BEGIN-VAR* ,*IDX-VAR*)))
	 (COND ((NULL ,*FIELD-VAR*)
		(SETQ ,*FIELD-VAR* ,*TEMPORARY*))
	       ((STRINGP ,*FIELD-VAR*)
		(SETQ ,*FIELD-VAR* (LIST ,*FIELD-VAR* ,*TEMPORARY*)))
	       (T
		(SETQ ,*FIELD-VAR* (NCONC ,*FIELD-VAR* (NCONS ,*TEMPORARY*)))))
	 ,(WHEN *DEBUG-PARSER-MACROS*
	    `(FORMAT *TRACE-OUTPUT* "~&Field (~S) is now ~S" ',*FIELD-VAR* ,*FIELD-VAR*))
	 (IF (CHAR= (AREF ,*LINE-VAR* ,*IDX-VAR*) #/,) (GO ,TAG)
	   ,@AFTER-COLON))))

(DEFUN PARSE-NIC-PROTOCOL-SPEC (STRING &AUX (IDX (STRING-SEARCH-CHAR #// STRING)))
  (IF (NULL IDX) (KEY-INTERN STRING)
    (CONS (KEY-INTERN (STRING-RIGHT-TRIM " " (SUBSTRING STRING 0 IDX)))
	  (KEY-INTERN (STRING-LEFT-TRIM " " (SUBSTRING STRING (1+ IDX)))))))

(DEFUN PARSE-NIC-MACHINE-LINE (LINE TYPE &AUX RESULT NAME FIELD)
  (PARSING-ALONG (LINE FIELD)
    (PARSE-ACT ; addresse(s)
      (PUSH (IF (CLI:LISTP FIELD) FIELD (LIST FIELD)) RESULT)
      (PUSH :ADDRESSES RESULT))
    (PARSE-ACT ; names(s)
      (COND ((STRINGP FIELD)
	     (SETQ NAME FIELD)
	     (SETQ FIELD (LIST FIELD)))
	    ((CONSP FIELD)
	     (SETQ NAME (FIRST FIELD))))
      (PUSH FIELD RESULT)
      (PUSH :HOST-NAMES RESULT))
    (PARSE-ACT ; cputype
      (PUSH (KEY-INTERN FIELD) RESULT)
      (PUSH :MACHINE-TYPE RESULT))
    (PARSE-ACT ; opsys
      (PUSH (KEY-INTERN FIELD) RESULT)
      (PUSH :SYSTEM-TYPE RESULT))
    (PARSE-ACT ; transport/services
      (IF (STRINGP FIELD)
	  (PUSH (LIST (KEY-INTERN FIELD)) RESULT)
	(NMAPCAR #'PARSE-NIC-PROTOCOL-SPEC FIELD)
	(PUSH FIELD RESULT))
      (PUSH :PROTOCOLS RESULT)))
  (CONS TYPE (CONS NAME RESULT)))

(DEFUN (:PROPERTY :HOST NIC-PARSE-LINE) (LINE)
  (PARSE-NIC-MACHINE-LINE LINE :HOST))

(DEFUN (:PROPERTY :GATEWAY NIC-PARSE-LINE) (LINE)
  (PARSE-NIC-MACHINE-LINE LINE :GATEWAY))

(DEFUN (:PROPERTY :NET NIC-PARSE-LINE) (LINE &AUX RESULT FIELD)
  (PARSING-ALONG (LINE FIELD)
    (PARSE-ACT ; address
      (PUSH FIELD RESULT)
      (PUSH :ADDRESS RESULT))
    (PARSE-ACT ; name
      ))
  (CONS :NET (CONS FIELD RESULT)))

(DEFUN PARSE-NIC-LINE (LINE INCLUDE-OBJECTS &AUX COLON TYPE PARSER)
  (IF (OR (ZEROP (STRING-LENGTH LINE)) (CHAR= (AREF LINE 0) #/;))
      (VALUES NIL NIL)
    (SETQ TYPE (KEY-INTERN (STRING-TRIM
			     " " (SUBSTRING LINE 0
					    (SETQ COLON (STRING-SEARCH-CHAR #/: LINE))))))
    (WHEN (MEMQ TYPE INCLUDE-OBJECTS)
      (SETQ PARSER (GET TYPE 'NIC-PARSE-LINE))
      (IF (NULL PARSER)
	  (FERROR () "Unknown type ~S" TYPE)
	(VALUES T (FUNCALL PARSER (STRING-RIGHT-TRIM " " (SUBSTRING LINE (+ COLON 1)))))))))

(DEFVAR *INCLUDE-OBJECTS* :UNBOUND)
(DEFVAR *CURRENT-INPUT-STREAM* :UNBOUND)
(DEFVAR *CURRENT-INPUT-FILE-LIST* :UNBOUND)
(DEFVAR *NIC-STREAM* :UNBOUND)

(DEFUN NIC-ENTRY-STREAM-D-H (OP &OPTIONAL ARG1 &REST REST)
  (STREAM-DEFAULT-HANDLER *NIC-STREAM* OP ARG1 REST))

(DEFSELECT (NIC-ENTRY-STREAM NIC-ENTRY-STREAM-D-H)
  (:CLOSE (IGNORE)
    (AND *CURRENT-INPUT-STREAM* (SEND *CURRENT-INPUT-STREAM* :CLOSE)))
  (:ENTRY ()
    (IF (NOT (OR *CURRENT-INPUT-STREAM* *CURRENT-INPUT-FILE-LIST*))
	()
      (UNLESS *CURRENT-INPUT-STREAM*
	(WHEN *CURRENT-INPUT-FILE-LIST*
	  (SETQ *CURRENT-INPUT-STREAM* (OPEN (CAR *CURRENT-INPUT-FILE-LIST*)))
	  (SETQ *CURRENT-INPUT-FILE-LIST* (CDR *CURRENT-INPUT-FILE-LIST*))))
      (DO (SOMETHING-HAPPENED RESULT LINE EOF)
	  (())
	(MULTIPLE-VALUE (LINE EOF) (SEND *CURRENT-INPUT-STREAM* :LINE-IN))
	(WHEN EOF
	  (SEND *CURRENT-INPUT-STREAM* :CLOSE)
	  (SETQ *CURRENT-INPUT-STREAM* NIL))
	(UNLESS *CURRENT-INPUT-STREAM*
	  (IF (NULL *CURRENT-INPUT-FILE-LIST*) (RETURN NIL)
	    (SETQ *CURRENT-INPUT-STREAM* (OPEN (CAR *CURRENT-INPUT-FILE-LIST*)))
	    (SETQ *CURRENT-INPUT-FILE-LIST* (CDR *CURRENT-INPUT-FILE-LIST*))))
	(MULTIPLE-VALUE (SOMETHING-HAPPENED RESULT) (PARSE-NIC-LINE LINE *INCLUDE-OBJECTS*))
	(IF SOMETHING-HAPPENED (RETURN RESULT)))))
  (:TRUENAMES ()
    (CLI:MAP 'LIST #'(LAMBDA (FILE) (SEND FILE :TRUENAME)) *CURRENT-INPUT-FILE-LIST*)))

(DEFUN MAKE-NIC-ENTRY-STREAM-CLOSURE ()
  (CLOSURE '(*CURRENT-INPUT-FILE-LIST* *CURRENT-INPUT-STREAM* *NIC-STREAM* *INCLUDE-OBJECTS*)
	   'NIC-ENTRY-STREAM))

(DEFUN MAKE-NIC-ENTRY-STREAM-FROM-FILES (INPUT-FILES INCLUDE-OBJECTS)
  (LET ((*CURRENT-INPUT-FILE-LIST* (CLI:MAP 'LIST #'FS:PARSE-PATHNAME INPUT-FILES))
	(*INCLUDE-OBJECTS* INCLUDE-OBJECTS)
	(*CURRENT-INPUT-STREAM* NIL)
	(*NIC-STREAM* NIL))
    (SETQ *NIC-STREAM* (MAKE-NIC-ENTRY-STREAM-CLOSURE))))

(DEFUN MAKE-NIC-ENTRY-STREAM-FROM-STREAM (INPUT-STREAM INCLUDE-OBJECTS)
  (LET ((*CURRENT-INPUT-FILE-LIST* NIL)
	(*INCLUDE-OBJECTS* INCLUDE-OBJECTS)
	(*CURRENT-INPUT-STREAM* INPUT-STREAM)
	(*NIC-STREAM* NIL))
    (SETQ *NIC-STREAM* (MAKE-NIC-ENTRY-STREAM-CLOSURE))))
	  (CLOSURE '(*CURRENT-INPUT-FILE-LIST* *CURRENT-INPUT-STREAM* *NIC-STREAM*)
		   'NIC-ENTRY-STREAM))))

(DEFUN GENERATE-LISP-INTERNET-TABLE
       (&KEY (INPUT-FILES (LIST (GET-SITE-OPTION :LOCAL-INTERNET-HOST-TABLE)))
	     (OUTPUT-FILE "SYS: SITE; INTERNET LISP >")
	     (INCLUDE-OBJECTS '(:HOST)))
  (WITH-OPEN-STREAM (NIC (MAKE-NIC-ENTRY-STREAM-FROM-FILES INPUT-FILES INCLUDE-OBJECTS))
    (WITH-OPEN-FILE (OUT OUTPUT-FILE :DIRECTION :OUTPUT)
      (PKG-BIND 'INTERNET
	(LET ((*PRINT-CASE* :UPCASE)
	      (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL)
	      (DEFINE-CONS (CONS 'NETI:DEFINE-THING NIL)))
	(FORMAT OUT "~
;;; -*- Mode:Lisp; Package:~A; Base: ~D -*-
;;; This was generated by a program; do NOT edit it.
;;; This is ~A.
;;; It was made by ~A on ~\DATIME\ from the following files:
;;; ~A~%"
		*PACKAGE* *PRINT-BASE* (SEND OUT :TRUENAME) USER-ID (SEND NIC :TRUENAMES))
      (DO ((ENTRY (SEND NIC :ENTRY) (SEND NIC :ENTRY)))
	  ((NULL ENTRY))
	(SEND OUT :TYO #\Newline)
	(SETF (CDR DEFINE-CONS) ENTRY)
	(WRITE DEFINE-CONS :STREAM OUT)))))))