(FILECREATED "11-NOV-83 17:47:28" {PHYLUM}<LISPCORE>LIBRARY>MAKEDIR.;3 16668
changes to: (FNS ParseNetDirEntry ReadAddress AdvanceToNextChar ReadAddrConst
ReadAttributeList MakeNetDir ReadNameList ReadName ReadAddrList)
(VARS MAKEDIRCOMS)
previous date: "11-NOV-83 11:07:53" {PHYLUM}<LISPCORE>LIBRARY>MAKEDIR.;1)
(* Copyright (c) 1983 by Schlumberger Technology Corporation)
(PRETTYCOMPRINT MAKEDIRCOMS)
(RPAQQ MAKEDIRCOMS ((FNS AddressCompare AdvanceToNextChar CollapseExpressions DigestEntry LookUpName
MakeNetDir NameCharP NameCompareFn NextByteInFile ParseNetDirEntry
ParsePortConstant PutBCPLString ReadAddrConst ReadAddrList ReadAddress
ReadAttributeList ReadName ReadNameList ReadtoEOL SeekToNextBlock
WriteAddressBlock WriteAddressTable WriteEntryBlock WriteNameBlock
WriteNameTable)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS WORDIN WORDOUT))))
(DEFINEQ
(AddressCompare
(LAMBDA (A1 A2) (* ejs: " 7-AUG-83 17:47")
(* * Ax is an entry in the address list. Return T is A1 belongs before A2. This function is used with SORT)
(COND
((ILESSP (CAR A1)
(CAR A2))
T)
((IGREATERP (CAR A1)
(CAR A2))
NIL)
((ILESSP (CADR A1)
(CADR A2))
T)
((IGREATERP (CADR A1)
(CADR A2))
NIL)
(T (ILEQ (CADDR A1)
(CADDR A2))))))
(AdvanceToNextChar
[LAMBDA (FILE) (* bvm: "11-NOV-83 17:36")
(* * Advance the stream to the next non-white character, but not past the EOL)
(while (SELCHARQ (\PEEKBIN FILE T)
((SPACE TAB)
T)
NIL)
do (BIN FILE])
(CollapseExpressions
(LAMBDA (LIST) (* ejs: " 7-AUG-83 16:20")
(* * LIST is a list of net host socket triples. Union them if legal)
(PROG ((NET 0)
(HOST 0)
(SOCKET 0))
(for ENTRY in LIST
do (COND
((ZEROP NET)
(SETQ NET (CAR ENTRY))))
(COND
((ZEROP HOST)
(SETQ HOST (CADR ENTRY))))
(COND
((ZEROP SOCKET)
(SETQ SOCKET (CADDR ENTRY)))))
(RETURN (COND
((ZEROP (LOGOR NET HOST SOCKET))
NIL)
(T (LIST NET HOST SOCKET)))))))
(DigestEntry
(LAMBDA (NAMELST ADDRLST) (* ejs: " 7-AUG-83 18:10")
(* * Store the appropriate information for a network directory entry)
(DECLARE (GLOBALVARS NAMES ADDRESSES ENTRIES NAMETABLE))
(for NAME in NAMELST
do (PUTHASH (MKATOM (U-CASE (CAR NAME)))
ADDRLST NAMETABLE)
(TCONC NAMES NAME))
(for ADDR in ADDRLST do (TCONC ADDRESSES ADDR))
(TCONC ENTRIES (LIST NAMELST ADDRLST))))
(LookUpName
(LAMBDA (ENTRY) (* ejs: "14-SEP-83 10:33")
(* * Lookup the value of a name defined by the pup network directory)
(DECLARE (GLOBALVARS NAMETABLE))
(COND
((GETHASH (MKATOM (U-CASE ENTRY))
NAMETABLE))
(T (ERROR "Name not found" ENTRY)))))
(MakeNetDir
[LAMBDA (FILE BINFILE DEBUG PASS2) (* bvm: "11-NOV-83 14:10")
(DECLARE (GLOBALVARS NAMETABLE NAMES ADDRESSES ENTRIES))
(PROG (NAME ENLENGTH)
(COND
((NOT PASS2)
[SETQ FILE (OR (\GETSTREAM FILE (QUOTE INPUT)
T)
(OPENSTREAM FILE (QUOTE INPUT)
(QUOTE OLD]
(printout T "Reading from file " (FULLNAME FILE)
T)
(SETFILEPTR FILE 0)
(SETQ NAMETABLE (CONS (HARRAY 100)))
(SETQ NAMES (CONS))
(SETQ ADDRESSES (CONS))
(SETQ ENTRIES (CONS))
(do (ParseNetDirEntry FILE DEBUG) until (EOFP FILE))
(SORT (SETQ NAMES (CAR NAMES))
(FUNCTION NameCompareFn))
(SORT (SETQ ADDRESSES (CAR ADDRESSES))
(FUNCTION AddressCompare))
(SETQ ENTRIES (CAR ENTRIES))
(CLOSEF FILE)))
(printout T "Writing binary file... ")
(SETQ FILE (OPENSTREAM (OR BINFILE (PACKFILENAME (QUOTE EXTENSION)
(QUOTE DIRECTORY)
(QUOTE BODY)
(FULLNAME FILE)))
(QUOTE OUTPUT)
(QUOTE NEW)))
(printout T "output to file " (SETQ NAME (FULLNAME FILE))
"... ")
(SETFILEPTR FILE 16)
(for ENTRY in ENTRIES do (WriteEntryBlock FILE ENTRY))
(SETQ ENLENGTH (IDIFFERENCE (GETFILEPTR FILE)
16))
(SeekToNextBlock FILE)
(WriteAddressTable FILE)
(SeekToNextBlock FILE)
(WriteNameTable FILE)
(SETFILEPTR FILE 8)
(WORDOUT FILE ENLENGTH)
(WORDOUT FILE 16)
(WORDOUT FILE (FILENAMEFIELD NAME (QUOTE VERSION)))
(printout T "done" T)
(CLOSEF FILE)
(SETQ NAMES (SETQ ADDRESSES (SETQ ENTRIES NIL)))
(RETURN NAME])
(NameCharP
(LAMBDA (CHAR) (* ejs: " 7-AUG-83 13:06")
(* * CHAR is a charcode. Return T is char is a legal constituent of a network directory name)
(COND
((AND (IGEQ CHAR (CHARCODE 0))
(ILEQ CHAR (CHARCODE 9)))
T)
((AND (IGEQ CHAR (CHARCODE A))
(ILEQ CHAR (CHARCODE Z)))
T)
((AND (IGEQ CHAR (CHARCODE a))
(ILEQ CHAR (CHARCODE z)))
T)
((EQ CHAR (CHARCODE /))
T)
((EQ CHAR (CHARCODE -))
T))))
(NameCompareFn
(LAMBDA (NAME1 NAME2) (* ejs: " 7-AUG-83 17:49")
(* * NAMEx is an entry in the names list)
(SELECTQ (StringCompare (CAR NAME1)
(CAR NAME2))
((EQ LESS)
T)
NIL)))
(NextByteInFile
(LAMBDA (CURRENTBYTE) (* ejs: " 7-AUG-83 16:46")
(* * Compute the next byte in the file we can write to. As a concession to Maxc and a couple of other PDP-10 hosts
in the world, all blocks start on pdp-10 word boundaries -- byte addresses divisible by four in Interlisp-D)
(COND
((ZEROP (IMOD CURRENTBYTE 4))
CURRENTBYTE)
(T (IPLUS (ITIMES (IQUOTIENT CURRENTBYTE 4)
4)
4)))))
(ParseNetDirEntry
[LAMBDA (FILE DEBUG) (* bvm: "11-NOV-83 17:17")
(* * Assuming positioned at the beginning of a network directory entry, parse the entry and update the internal
data structures)
(PROG (NAMELST ADDRLST)
(SELECTQ (SKIPSEPRS FILE)
((; EOL)
(ReadtoEOL FILE)
(RETURN))
NIL)
(SETQ NAMELST (ReadNameList FILE))
(SETQ ADDRLST (ReadAddrList FILE))
(ReadAttributeList FILE)
(DigestEntry NAMELST ADDRLST)
(COND
(DEBUG (printout T .PPVTL NAMELST T])
(ParsePortConstant
(LAMBDA (STR)
(DECLARE (GLOBALVARS CHCONLST1)) (* ejs: " 7-AUG-83 15:04")
(* * If STR is a constant ether address of form net#host#socket, returns a port, else NIL)
(PROG ((CHARS (DCHCON STR CHCONLST1))
NET HOST VAL)
LP (COND
((NULL CHARS) (* Ran out of chars. Save last value parsed, make sure
we have at least a net and host)
(COND
((AND (NOT NET)
(NOT HOST)
(NOT VAL))
(RETURN)))
(OR NET (SETQ NET 0))
(OR HOST (SETQ HOST 0))
(RETURN (CONS (LOGOR HOST (LLSH NET 10Q))
(OR VAL 0)))))
(COND
((AND (IGEQ (CAR CHARS)
(CHARCODE 0))
(ILEQ (CAR CHARS)
(CHARCODE 7))) (* Add octal digit into value)
(SETQ VAL (IPLUS (COND
(VAL (LLSH VAL 3))
(T 0))
(IDIFFERENCE (CAR CHARS)
(CHARCODE 0)))))
((EQ (CAR CHARS)
(CHARCODE #)) (* # terminates net or host number)
(SETQ NET HOST)
(SETQ HOST VAL)
(SETQ VAL 0))
(T (RETURN)))
(SETQ CHARS (CDR CHARS))
(GO LP))))
(PutBCPLString
(LAMBDA (FILE STRING) (* ejs: " 8-AUG-83 07:44")
(BOUT FILE (fetch (STRINGP LENGTH) of STRING))
(\BOUTS FILE (fetch (STRINGP BASE) of STRING)
(fetch (STRINGP OFFST) of STRING)
(fetch (STRINGP LENGTH) of STRING))
(COND
((EVENP (fetch (STRINGP LENGTH) of STRING))
(BOUT FILE 0)))))
(ReadAddrConst
[LAMBDA (FILE) (* bvm: "11-NOV-83 17:38")
(* * Read a general address constant.)
(PROG (PORT STRING (BEGIN (GETFILEPTR FILE))
(LENGTH 0))
(until (SELCHARQ (BIN FILE)
((SPACE TAB EOL , ;)
T)
NIL)
do (add LENGTH 1))
(COND
((NOT (ZEROP LENGTH))
(SETFILEPTR FILE BEGIN)
(SETQ STRING (ALLOCSTRING LENGTH))
(\BINS FILE (fetch (STRINGP BASE) of STRING)
(fetch (STRINGP OFFST) of STRING)
LENGTH)
(AdvanceToNextChar FILE)
(SETQ PORT (ParsePortConstant STRING))
(RETURN (COND
(PORT (LIST (LOGAND (LRSH (CAR PORT)
8)
255)
(LOGAND (CAR PORT)
255)
(CDR PORT])
(ReadAddrList
[LAMBDA (FILE) (* bvm: "11-NOV-83 15:32")
(* * Read a list of addresses in a pup network directory file)
(bind ADDRESS until (SELCHARQ (\PEEKBIN FILE T)
((; EOL LF CR NIL)
T)
(, (BIN FILE)
NIL)
NIL)
when (SETQ ADDRESS (ReadAddress FILE)) collect ADDRESS])
(ReadAddress
[LAMBDA (FILE) (* bvm: "11-NOV-83 17:14")
(* * Read an address expression, returning a triple of net host socket)
(PROG (NAME ADDRCONST CHAR)
(SKIPSEPRS FILE)
[until (SELCHARQ (SETQ CHAR (\PEEKBIN FILE T))
((NIL ; , EOL LF)
T)
NIL)
do (COND
[[AND (NEQ CHAR (CHARCODE #))
(OR (ILESSP CHAR (CHARCODE 0))
(IGREATERP CHAR (CHARCODE 7]
(push NAME (CAR (ReadName FILE]
(T (push ADDRCONST (ReadAddrConst FILE]
[for ENTRY in NAME do (push ADDRCONST (CAR (LookUpName ENTRY]
(AdvanceToNextChar FILE)
(RETURN (CollapseExpressions ADDRCONST])
(ReadAttributeList
[LAMBDA (FILE) (* bvm: "11-NOV-83 17:44")
(* * Read past the attribute list. We ignore it for now)
(until (\EOFP FILE) do (SELCHARQ (BIN FILE)
(EOL (RETURN))
(; [bind TERMCHAR do (SETQ TERMCHAR (ReadtoEOL FILE))
repeatuntil (AND TERMCHAR (NEQ TERMCHAR (CHARCODE ,]
(RETURN))
NIL])
(ReadName
[LAMBDA (FILE) (* bvm: "11-NOV-83 15:27")
(* * Read a name, composed of alphanumerics plus -
and /, returning a stringp)
(PROG ((LENGTH 0)
START STRING END)
(SKIPSEPRS FILE)
(SETQ START (GETFILEPTR FILE))
(while (NameCharP (BIN FILE)) do (add LENGTH 1)) (* Compute length of string)
(COND
((NOT (ZEROP LENGTH))
(SETFILEPTR FILE START)
(SETQ STRING (ALLOCSTRING LENGTH))
(\BINS FILE (fetch (STRINGP BASE) of STRING)
(fetch (STRINGP OFFST) of STRING)
LENGTH) (* Read the terminator)
)
(T (SETQ STRING "")))
(RETURN (CONS STRING (AND (SKIPSEPRS FILE)
(BIN FILE])
(ReadNameList
[LAMBDA (FILE) (* bvm: "11-NOV-83 14:12")
(* * Read the name list section of a network directory entry. Return a list of strings)
(bind TEMP collect [LIST (CAR (SETQ TEMP (ReadName FILE] repeatuntil (EQ (CDR TEMP)
(CHARCODE =])
(ReadtoEOL
(LAMBDA (FILE) (* ejs: " 7-AUG-83 14:00")
(* * Read to the end of a line, eating the terminating character)
(PROG (CHAR)
(until (OR (EOFP FILE)
(EQ (\PEEKBIN FILE)
(CHARCODE EOL)))
do (SETQ CHAR (BIN FILE)))
(until (OR (EOFP FILE)
(NOT (EQ (\PEEKBIN FILE T)
(CHARCODE EOL))))
do (BIN FILE))
(RETURN CHAR))))
(SeekToNextBlock
(LAMBDA (FILE) (* ejs: " 7-AUG-83 18:47")
(* * Point to the next block in the file)
(PROG ((A (NextByteInFile (GETFILEPTR FILE))))
(SETFILEPTR FILE A)
(RETURN A))))
(WriteAddressBlock
(LAMBDA (FILE ADDRESS ENTRY MORE) (* ejs: " 7-AUG-83 17:59")
(* *Write out an address block.
If More is true, point to the next block, else 0 the
next pointer)
(PROG (NEXT (START (GETFILEPTR FILE)))
(WORDOUT FILE 0)
(WORDOUT FILE (LRSH ENTRY 1))
(BOUT FILE (CAR ADDRESS))
(BOUT FILE (CADR ADDRESS))
(WORDOUT FILE (\HINUM (CADDR ADDRESS)))
(WORDOUT FILE (\LONUM (CADDR ADDRESS)))
(WORDOUT FILE 0)
(SETQ NEXT (SeekToNextBlock FILE))
(COND
(MORE (SETFILEPTR FILE START)
(WORDOUT FILE (LRSH NEXT 1))))
(SETFILEPTR FILE NEXT))))
(WriteAddressTable
(LAMBDA (FILE) (* ejs: " 7-AUG-83 18:58")
(* * Write the ordered address table)
(DECLARE (GLOBALVARS ADDRESSES))
(PROG ((START (SeekToNextBlock FILE))
END)
(for I in ADDRESSES do (WORDOUT FILE (LRSH (CADDDR I)
1)))
(SETQ END (GETFILEPTR FILE))
(SETFILEPTR FILE 4)
(WORDOUT FILE (LENGTH ADDRESSES))
(WORDOUT FILE (LRSH START 1))
(SETFILEPTR FILE END)
(SeekToNextBlock FILE))))
(WriteEntryBlock
(LAMBDA (FILE ENTRY) (* ejs: " 7-AUG-83 19:08")
(* * ENTRY is a list whose CAR is a list of names and whose CADR is a list of addresses)
(PROG (ADDRSTART NEXT (NM (CAR ENTRY))
(AD (CADR ENTRY))
(START (GETFILEPTR FILE)))
(SETFILEPTR FILE (IPLUS START 6))
(for NAME in old NM
do (NCONC1 NAME (GETFILEPTR FILE))
(WriteNameBlock FILE (CAR NAME)
START
(CDR NM)))
(SeekToNextBlock FILE)
(SETQ ADDRSTART (GETFILEPTR FILE))
(for ADDRESS in old AD
do (NCONC1 ADDRESS (GETFILEPTR FILE))
(WriteAddressBlock FILE ADDRESS START (CDR AD)))
(SETQ NEXT (GETFILEPTR FILE))
(SETFILEPTR FILE START)
(WORDOUT FILE (IPLUS (LRSH START 1)
3))
(WORDOUT FILE (LRSH ADDRSTART 1))
(WORDOUT FILE 0)
(SETFILEPTR FILE NEXT)
(SeekToNextBlock FILE))))
(WriteNameBlock
(LAMBDA (FILE NAME ENTRY MORE) (* ejs: " 7-AUG-83 17:57")
(* *Write out a name block. If More is true, point to
the next block, else 0 the next pointer)
(PROG (NEXT (START (GETFILEPTR FILE)))
(WORDOUT FILE 0)
(WORDOUT FILE (LRSH ENTRY 1))
(PutBCPLString FILE NAME)
(SETQ NEXT (SeekToNextBlock FILE))
(COND
(MORE (SETFILEPTR FILE START)
(WORDOUT FILE (LRSH NEXT 1))))
(SETFILEPTR FILE NEXT))))
(WriteNameTable
(LAMBDA (FILE) (* ejs: " 7-AUG-83 18:34")
(* * Write the ordered address table)
(DECLARE (GLOBALVARS NAMES))
(PROG ((START (SeekToNextBlock FILE)))
(for I in NAMES do (WORDOUT FILE (LRSH (CADR I)
1)))
(SETFILEPTR FILE 0)
(WORDOUT FILE (LENGTH NAMES))
(WORDOUT FILE (LRSH START 1)))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS WORDIN DMACRO (= . \WIN))
(PUTPROPS WORDOUT DMACRO (= . \WOUT))
)
)
(PUTPROPS MAKEDIR COPYRIGHT ("Schlumberger Technology Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (915 16427 (AddressCompare 925 . 1411) (AdvanceToNextChar 1413 . 1736) (
CollapseExpressions 1738 . 2330) (DigestEntry 2332 . 2833) (LookUpName 2835 . 3178) (MakeNetDir 3180
. 4999) (NameCharP 5001 . 5515) (NameCompareFn 5517 . 5787) (NextByteInFile 5789 . 6273) (
ParseNetDirEntry 6275 . 6919) (ParsePortConstant 6921 . 8154) (PutBCPLString 8156 . 8566) (
ReadAddrConst 8568 . 9394) (ReadAddrList 9396 . 9802) (ReadAddress 9804 . 10574) (ReadAttributeList
10576 . 11014) (ReadName 11016 . 11855) (ReadNameList 11857 . 12203) (ReadtoEOL 12205 . 12683) (
SeekToNextBlock 12685 . 12965) (WriteAddressBlock 12967 . 13759) (WriteAddressTable 13761 . 14343) (
WriteEntryBlock 14345 . 15367) (WriteNameBlock 15369 . 15978) (WriteNameTable 15980 . 16425)))))
STOP