(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) (FILECREATED "23-Sep-2026 22:58:37" {MEDLEY}PSEUDOHOSTS.;221 37206 :EDIT-BY rmk :CHANGES-TO (FNS PSEUDOHOST) :PREVIOUS-DATE "22-Sep-2026 01:13:00" {MEDLEY}PSEUDOHOSTS.;220) (PRETTYCOMPRINT PSEUDOHOSTSCOMS) (RPAQQ PSEUDOHOSTSCOMS ( (* ;; "Public entries") (FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEDEVICE TRUEFILENAME PSEUDOFILENAME PSEUDOFILENAMES) (FNS CDPSEUDO) (* ;; "Internals") (FNS PSEUDOHOST.PREFIXMAP EXPAND.PH CONTRACT.PH UNSLASHIT GETHOSTINFO.PH) (FNS OPENFILE.PH GETFILENAME.PH DIRECTORYNAMEP.PH CLOSEFILE.PH REOPENFILE.PH DELETEFILE.PH GENERATEFILES.PH GETFILEINFO.PH SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH BIN.PH GETNEXTBUFFER.PH) (P (MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG) (MOVD 'GETHOSTINFO.PH 'GETHOSTINFO)) (INITVARS PREFIXMAPS.PH) (GLOBALVARS PREFIXMAPS.PH) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PHDEVICE PHGENFILESTATE TARGETDEVICE) (MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL)))) (* ;; "Public entries") (DEFINEQ (PSEUDOHOST [LAMBDA (HOST PREFIX CDSUFFIX NOERROR) (* ;; "Edited 23-Sep-2026 22:58 by rmk") (* ;; "Edited 22-Sep-2026 01:12 by rmk") (* ;; "Edited 21-Jun-2026 01:11 by rmk") (* ;; "Edited 28-Apr-2026 08:31 by rmk") (* ;; "Edited 2-Feb-2025 10:05 by rmk") (* ;; "Edited 2-Nov-2023 10:53 by rmk") (* ;; "Edited 22-Sep-2023 15:29 by rmk") (* ;; "Edited 25-Jun-2022 17:00 by rmk") (* ;; "Edited 24-Feb-2022 23:56 by rmk: Expand prefix so that it is rooted in a real host and not a previously defined pseudohost.") (DECLARE (GLOBALVARS \FILEDEVICES)) (CL:WHEN (AND (LISTP HOST) (NULL PREFIX)) (SETQ PREFIX (CADR HOST)) (SETQ HOST (CAR HOST))) (CL:WHEN (EQ (CHCON1 HOST) (CHARCODE {)) (SETQ HOST (SUBSTRING HOST 2))) (CL:WHEN (EQ (NTHCHARCODE HOST -1) (CHARCODE })) (SETQ HOST (SUBSTRING HOST 1 -2))) (SETQ HOST (MKATOM HOST)) (PROG (TARGETHOST TARGETDEVICE PREFIXHOST PHDEV TRUEPREFIX) (if PREFIX then (CL:UNLESS (SETQ TRUEPREFIX (TRUEFILENAME PREFIX NOERROR)) (RETURN NIL)) (CL:UNLESS [SETQ PREFIXHOST (U-CASE (FILENAMEFIELD TRUEPREFIX 'HOST] (SETQ TRUEPREFIX (UNSLASHIT (PACKFILENAME 'HOST (SETQ PREFIXHOST 'DSK) 'BODY TRUEPREFIX)))) (* ;; "We want the maximal prefix. If {LI} is a pseudohost with prefix {DSK} and we are defining {FOO} with prefix {LI}, we want FOO's prefix to be {DSK}xyz>. , And if FUM is then defined as {FOO}, we want its prefix to be {DSK}xyz>mno>. This gives the true filenames.") (SETQ TRUEPREFIX (EXPAND.PH TRUEPREFIX PREFIXHOST)) (CL:UNLESS (MEMB (NTHCHARCODE TRUEPREFIX -1) (CHARCODE (> / <))) (SETQ TRUEPREFIX (CONCAT TRUEPREFIX (CL:IF (STRPOS "/" TRUEPREFIX) "/" ">")))) [SETQ TARGETHOST (U-CASE (FILENAMEFIELD TRUEPREFIX 'HOST] (* ;; "We know about the directory separators for these particular devices. Maybe there should be separate list of slash-hosts somewhere that we can use. (Here we also default to <>, e.g. NS servers)") (SELECTQ TARGETHOST ((DSK CORE) (SETQ TRUEPREFIX (UNSLASHIT TRUEPREFIX))) (UNIX (SETQ TRUEPREFIX (SLASHIT TRUEPREFIX))) (SETQ TRUEPREFIX (UNSLASHIT TRUEPREFIX))) (SETQ TARGETDEVICE (OR (\GETDEVICEFROMHOSTNAME TARGETHOST) (CL:IF NOERROR (RETURN NIL)) (ERROR "Unknown target host" TARGETHOST))) (if (NULL (SETQ PHDEV (\GETDEVICEFROMNAME HOST T))) then (SETQ PHDEV (create FDEV using TARGETDEVICE DEVICENAME _ HOST FDEV1 _ TARGETDEVICE FDEV2 _ TRUEPREFIX FDEV4 _ PREFIX OPENFILELST _ NIL OPENFILE _ (FUNCTION OPENFILE.PH) GETFILENAME _ (FUNCTION GETFILENAME.PH) DIRECTORYNAMEP _ (FUNCTION DIRECTORYNAMEP.PH) CLOSEFILE _ (FUNCTION CLOSEFILE.PH) REOPENFILE _ (FUNCTION REOPENFILE.PH) DELETEFILE _ (FUNCTION DELETEFILE.PH) OPENP _ (FUNCTION \GENERIC.OPENP) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) GENERATEFILES _ (FUNCTION GENERATEFILES.PH) GETFILEINFO _ (FUNCTION GETFILEINFO.PH) SETFILEINFO _ (FUNCTION SETFILEINFO.PH) BIN _ (FUNCTION BIN.PH) GETNEXTBUFFER _ (FUNCTION GETNEXTBUFFER.PH))) (UNINTERRUPTABLY (\DEFINEDEVICE HOST PHDEV) (PSEUDOHOST.PREFIXMAP HOST TRUEPREFIX)) elseif (type? PHDEVICE PHDEV) then (* ;; "New prefix for an existing pseudohost") (CL:UNLESS (EQUAL TRUEPREFIX (fetch (PHDEVICE TRUEPREFIX) of PHDEV)) (UNINTERRUPTABLY (replace (PHDEVICE TRUEPREFIX) of PHDEV with TRUEPREFIX) (replace (PHDEVICE PREFIX) of PHDEV with PREFIX) (replace (PHDEVICE TARGETDEV) of PHDEV with TARGETDEVICE) (PSEUDOHOST.PREFIXMAP HOST TRUEPREFIX)) (* ;; "If host e.g. MEDLEY is getting a new PREFIX, then the true prefix of every {MEDLEY}/foo/fie/ must be updated, recursively") (* ;;  "Seems like a lot to make this scan be uninterruptable. Should we?") (for FD in \FILEDEVICES when [AND (type? PHDEVICE FD) (EQ HOST (FILENAMEFIELD (fetch (PHDEVICE PREFIX) of FD) 'HOST] do (PSEUDOHOST (fetch (FDEV DEVICENAME) of FD) (fetch (PHDEVICE PREFIX) of FD) NIL T))) elseif NOERROR then (RETURN NIL) else (ERROR HOST "cannot name a pseudohost")) elseif (PSEUDOHOSTP HOST) then (* ;; "Remove/undefine a pseudohost. \DEFINEDEVICE removes the name-mapping but doesn't remove the device. Maybe that's on purpose for other devices, but not here.") (UNINTERRUPTABLY (PSEUDOHOST.PREFIXMAP HOST NIL) (SETQ \FILEDEVICES (DREMOVE (\GETDEVICEFROMNAME 'HOST T) \FILEDEVICES)) (\DEFINEDEVICE HOST NIL)) (for FD in \FILEDEVICES when [AND (type? PHDEVICE FD) (EQ HOST (FILENAMEFIELD (fetch (PHDEVICE PREFIX) of FD) 'HOST] do (PSEUDOHOST (fetch (FDEV DEVICENAME) of FD) NIL NIL T)) elseif NOERROR then (RETURN NIL) else (ERROR (CONCAT "Prefix for pseudohost " HOST " not found"))) (CL:WHEN (AND PREFIX CDSUFFIX) (CDPSEUDO HOST CDSUFFIX)) (CL:WHEN PREFIX (* ;  "If no prefix, we didn't get a pseudohost") (RETURN HOST))]) (PSEUDOHOSTP [LAMBDA (HOST) (* ; "Edited 10-Jun-2026 22:55 by rmk") (* ; "Edited 27-Apr-2026 17:27 by rmk") (* ; "Edited 16-Dec-2024 21:15 by rmk") (* ; "Edited 24-Feb-2022 23:51 by rmk") (* ; "Edited 18-Jan-2022 11:29 by rmk") (LET [(DEV (if (type? FDEV HOST) then HOST elseif (type? STREAM HOST) then (fetch (STREAM DEVICE) of HOST) else (\GETDEVICEFROMNAME HOST T T] (CL:WHEN (type? PHDEVICE DEV) (LIST (fetch (FDEV DEVICENAME) of DEV) (fetch (PHDEVICE TRUEPREFIX) of DEV)))]) (PSEUDOHOSTS [LAMBDA NIL (* ; "Edited 10-Jun-2026 23:03 by rmk") (* ; "Edited 17-Jan-2022 18:15 by rmk") (DECLARE (GLOBALVARS \FILEDEVICES)) (for DEV in \FILEDEVICES when (type? PHDEVICE DEV) collect (LIST (fetch (FDEV DEVICENAME) of DEV) (fetch (PHDEVICE TRUEPREFIX) of DEV]) (TARGETHOST [LAMBDA (HOST) (* ; "Edited 10-Jun-2026 22:50 by rmk") (* ; "Edited 14-Dec-2024 15:26 by rmk") (* ; "Edited 12-Dec-2024 16:16 by rmk") (* ; "Edited 22-Jan-2022 09:00 by rmk") (LET ((PH (PSEUDOHOSTP HOST))) (CL:WHEN PH (FILENAMEFIELD (CADR PH) 'HOST))]) (TRUEDEVICE [LAMBDA (X) (* ; "Edited 10-Jun-2026 22:59 by rmk") (* ; "Edited 31-Dec-2024 11:44 by rmk") (* ; "Edited 25-Dec-2024 07:37 by rmk") (* ; "Edited 23-Dec-2024 22:56 by rmk") (* ; "Edited 16-Dec-2024 17:36 by rmk") (* ; "Edited 12-Dec-2024 14:34 by rmk") (LET [(DEV (if (type? FDEV X) then X elseif (STREAMP X) then (fetch (STREAM DEVICE) of X) else (\GETDEVICEFROMNAME X] (if (type? PHDEVICE DEV) then (fetch (PHDEVICE TARGETDEV) of DEV) else DEV]) (TRUEFILENAME [LAMBDA (FILE NOERROR) (* ; "Edited 10-Jun-2026 23:06 by rmk") (* ; "Edited 2-Feb-2025 09:12 by rmk") (* ; "Edited 1-Oct-2023 20:16 by rmk") (* ; "Edited 26-Jul-2023 07:53 by rmk") (* ; "Edited 26-Jan-2022 23:33 by rmk") (* ; "Edited 25-Jan-2022 08:47 by rmk") (if (LISTP FILE) then (for F in FILE collect (TRUEFILENAME F)) else (LET (FILENAME DEVICE) (if (STREAMP FILE) then (SETQ FILENAME (OR (fetch (STREAM FULLFILENAME) of FILE) FILE)) (SETQ DEVICE (fetch (STREAM DEVICE) of FILE)) ELSE (SETQ FILENAME (\ADD.CONNECTED.DIR FILE)) (SETQ DEVICE (\GETDEVICEFROMNAME FILENAME NOERROR))) (CL:IF (type? PHDEVICE DEVICE) (EXPAND.PH FILENAME DEVICE) FILENAME)]) (PSEUDOFILENAME [LAMBDA (FILE PHOST) (* ; "Edited 21-Sep-2026 22:37 by rmk") (* ; "Edited 10-Jun-2026 23:07 by rmk") (* ; "Edited 27-Apr-2026 18:50 by rmk") (* ; "Edited 26-Apr-2026 09:00 by rmk: If PHOST is non-NIL and a pseudohost, that's the one that the caller wants.") (* ; "Edited 24-Apr-2026 22:52 by rmk") (* ; "Edited 26-Jul-2023 12:34 by rmk") (* ; "Edited 29-Jan-2022 23:08 by rmk") (* ; "Edited 28-Jan-2022 09:06 by rmk") (DECLARE (GLOBALVARS \FILEDEVICES)) (if (LISTP FILE) then (for F in FILE collect (PSEUDOFILENAME F PHOST)) else (for D PN (FILENAME _ (if (STREAMP FILE) then (fetch (STREAM FULLFILENAME) of FILE) else (\ADD.CONNECTED.DIR FILE))) in \FILEDEVICES when (type? PHDEVICE D) when (OR (NULL PHOST) (EQ PHOST (fetch (FDEV DEVICENAME) of D))) unless (EQ FILENAME (SETQ PN (CONTRACT.PH FILENAME D PHOST))) do (RETURN PN) finally (RETURN FILENAME]) (PSEUDOFILENAMES [LAMBDA (FILE) (* ; "Edited 10-Jun-2026 23:08 by rmk") (* ; "Edited 27-Apr-2026 19:23 by rmk") (* ;  "Edited 27-Apr-2026 10:00 by rmk; Edited 27-Apr-2026 09:33 by rmk") (* ;; "Shows all the pseudohost synonyms for FILE (including its truename)") (DECLARE (GLOBALVARS \FILEDEVICES)) (for D PN (TRUENAME _ (TRUEFILENAME FILE)) in \FILEDEVICES when (type? PHDEVICE D) unless [EQ TRUENAME (SETQ PN (PSEUDOFILENAME TRUENAME (fetch (FDEV DEVICENAME) of D] collect PN finally (RETURN (CONS TRUENAME $$VAL]) ) (DEFINEQ (CDPSEUDO [LAMBDA (PHOST CDSUFFIX FILEPKGFLG) (* ; "Edited 27-Apr-2026 22:54 by rmk") (* ; "Edited 25-Apr-2026 23:53 by rmk") (* ; "Edited 21-Dec-2024 13:48 by rmk") (* ; "Edited 6-Feb-2024 15:50 by rmk") (* ;; "Makes a cd command for PHOST. The command name is %"cd%" followed by the lower-case letters of CDSUFFIX (e.g. cdf for PHOST FOO and CDSUFFIX %"f%".") (* ;; "Does not notify FILEPKG unless FILEPKGFLG") (DECLARE (SPECVARS FILEPKGFLG)) (CL:WHEN (AND (SETQ PHOST (CAR (PSEUDOHOSTP PHOST))) CDSUFFIX) [LET [(CNAME (CONCAT "cd" (L-CASE CDSUFFIX] (SETQ PHOST (CONCAT "{" PHOST "}")) (EVAL `(DEFCOMMAND ,CNAME (SUBDIR) (/CNDIR (CL:IF SUBDIR (CONCAT ,PHOST "/" SUBDIR) ,PHOST)))])]) ) (* ;; "Internals") (DEFINEQ (PSEUDOHOST.PREFIXMAP [LAMBDA (HOST TRUEPREFIX) (* ; "Edited 21-Sep-2026 22:41 by rmk") (* ; "Edited 11-Jun-2026 16:42 by rmk") (* ;; "Associated with each target device (DSK, UNIX, FS1:...) is a mapping between the pseudohosts names and the true prefixes that they expand to. This adds (or removes) TRUEPREFIX from the PREFIXMAPS of the target device of HOST.") (LET* [(PHDEV (\GETDEVICEFROMNAME HOST \FILEDEVICES)) (TARGETDEV (AND (type? PHDEVICE PHDEV) (fetch (PHDEVICE TARGETDEV) of PHDEV))) (NEWENTRY (LIST HOST TRUEPREFIX (CL:IF (EQ (CHARCODE /) (NTHCHARCODE TRUEPREFIX -1)) '/ '<)] (CL:WHEN TARGETDEV [if (NULL TRUEPREFIX) then (change (fetch (TARGETDEVICE PREFIXMAPS) of TARGETDEV) (DREMOVE (ASSOC HOST DATUM) DATUM)) elseif (for ENTRY in (fetch (TARGETDEVICE PREFIXMAPS) of TARGETDEV) never (EQUAL NEWENTRY ENTRY)) then (* ;; "If a HOST preference isn't provided and two prefixes have common initial substrings, choose the one that provides the smallest file name.") (change (fetch (TARGETDEVICE PREFIXMAPS) of TARGETDEV) (SORT (CONS NEWENTRY DATUM) (FUNCTION (LAMBDA (P1 P2) (* ;; "To give smallest file names, longest prefix comes first. If same length (synonyms), the one with the smallest host comes first. So MEDLEY before WMEDLEY") (if (IGREATERP (NCHARS (CADR P1)) (NCHARS (CADR P2))) elseif (EQ (NCHARS (CADR P1)) (NCHARS (CADR P2))) then (ILESSP (NCHARS (CAR P1)) (NCHARS (CAR P2])]) (EXPAND.PH [LAMBDA (FILENAME PHDEV) (* ;; "Edited 10-Jun-2026 12:18 by rmk") (* ;; "Edited 27-Apr-2026 17:27 by rmk") (* ;; "Edited 25-Apr-2022 09:35 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand to its true name") (* ;; "Assumes that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name") [if (type? STREAM FILENAME) then (CL:UNLESS PHDEV (SETQ PHDEV (fetch (STREAM DEVICE) of FILENAME))) (SETQ FILENAME (fetch (STREAM FULLNAME) of FILENAME)) elseif (NOT (type? FDEV PHDEV)) then (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV FILENAME] (if (type? PHDEVICE PHDEV) then (LET (SUFFIX SUFFIXPOS) (CL:WHEN (SETQ SUFFIXPOS (STRPOS "}" FILENAME)) (SETQ SUFFIX (OR (SUBSTRING FILENAME (ADD1 SUFFIXPOS)) "")) (CL:WHEN (FMEMB (CHCON1 SUFFIX) (CHARCODE (< > /))) (SETQ SUFFIX (SUBSTRING SUFFIX 2))) (CONCAT (fetch (PHDEVICE TRUEPREFIX) of PHDEV) SUFFIX))) else FILENAME]) (CONTRACT.PH [LAMBDA (TRUENAME PHDEV PHOST) (* ;; "Edited 21-Sep-2026 22:27 by rmk") (* ;; "Edited 10-Jun-2026 23:41 by rmk") (* ;; "Edited 27-Apr-2026 18:43 by rmk") (* ;; "Edited 26-Apr-2026 10:31 by rmk") (* ;; "Edited 22-Sep-2023 14:30 by rmk") (* ;; "Finds the preferred pseudoname for TRUENAME, the name on PHOST if given, else the shortest one. The PHDEV is used only to find its targetdev, that's where we scan for matching trueprefixes. This replaces the chosen trueprefix of TRUENAME with the corresponding pseudohost.") (CL:WHEN TRUENAME (CL:UNLESS (type? FDEV PHDEV) (SETQ PHDEV (\GETDEVICEFROMNAME PHDEV))) (CL:WHEN (EQ PHOST T) (SETQ PHOST (fetch (FDEV DEVICENAME) of PHDEV))) (LET ((PREFIXMAPS (fetch (TARGETDEVICE PREFIXMAPS) of (fetch (PHDEVICE TARGETDEV) of PHDEV))) PREFIXMAP PREFIX SUFFIX CONNECTOR) (* ;;  "PREFIXMAPs of PHDEVare sorted so that the longest one comes first, if PHOST isn't specified") (SETQ PREFIXMAP (find PM in PREFIXMAPS when (OR (NULL PHOST) (EQ PHOST (CAR PM))) suchthat (STRPOS (CADR PM) TRUENAME 1 NIL T NIL FILEDIRCASEARRAY))) (* ;; "If we didn't find a prefix map, TRUENAME was not related to any pseudohost descending from the target, it is a pure target name, presumably because something like a relative .. reference took it off all paths. We return the original name.") (if PREFIXMAP then (SETQ PREFIX (CADR PREFIXMAP)) [SETQ SUFFIX (SUBSTRING TRUENAME (ADD1 (NCHARS PREFIX] (CL:WHEN (STRPOS ">" SUFFIX) (* ;;  "CONNECTOR tells us whether to use / or > depending on what the prefix has") (SETQ CONNECTOR (CADDR PREFIXMAP)) [SETQ SUFFIX (CONCAT CONNECTOR (CL:IF (EQ CONNECTOR '/) (SLASHIT SUFFIX) (UNSLASHIT SUFFIX))]) (PACK* '{ (CAR PREFIXMAP) "}" (OR SUFFIX "")) else TRUENAME)))]) (UNSLASHIT [LAMBDA (X LCASEDIRS) (* ; "Edited 26-Jan-2022 15:09 by rmk") (* ; "Edited 22-Dec-2021 20:18 by rmk") (* ; "Edited 21-Nov-2021 23:00 by rmk:") (* ;; "Tricky to get the first one right.") (LET [LASTDIRPOS UNSLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X) 0] [SETQ UNSLASHED (CONCATCODES (FOR I C LASTC FROM DIRPOS WHILE (SETQ C (NTHCHARCODE X I)) COLLECT (PROG1 (SELCHARQ C (/ (SETQ LASTDIRPOS I) (IF (AND LASTC (NEQ LASTC (CHARCODE }))) THEN (CHARCODE >) ELSE (CHARCODE <))) ((< >) (SETQ LASTDIRPOS I) C) C) (SETQ LASTC C] (CL:WHEN (AND LCASEDIRS LASTDIRPOS) (SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS))) (SETQ UNSLASHED (CONCAT (L-CASE (SUBSTRING UNSLASHED 1 LASTDIRPOS)) (OR (SUBSTRING UNSLASHED (ADD1 LASTDIRPOS)) "")))) (CL:IF (EQ DIRPOS 1) UNSLASHED (CONCAT (SUBSTRING X 1 (SUB1 DIRPOS)) UNSLASHED))]) (GETHOSTINFO.PH [LAMBDA (HOST ATTRIBUTE) (* ;; "Edited 26-Nov-2025 17:26 by rmk") (* ;; "Edited 24-Apr-2022 14:16 by rmk: the info from the true host") (* ;; "Want the info from the true host") (GETHOSTINFO.ORIG (OR (TARGETHOST HOST) HOST) ATTRIBUTE]) ) (DEFINEQ (OPENFILE.PH [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING) (* ;; "Edited 26-Apr-2026 10:25 by rmk") (* ;; "Edited 31-Oct-2022 23:32 by rmk") (* ;; "Edited 14-Jul-2022 17:53 by rmk") (* ;; "Edited 25-Jun-2022 17:06 by rmk: If the stream was opened through the pseudohost, then it should only be registered on the pseudohost. We assume that it is safe to remove it from the target hosts list. The goal is that OPENP should only see it once, as being open on the pseudohost.") (* ;; "Edited 25-Jan-2022 08:45 by rmk") (* ;; "Edited 18-Jan-2022 10:29 by rmk") (LET ((TARGETDEV (fetch (PHDEVICE TARGETDEV) of FDEV)) (STREAM (PSEUDOHOST.TARGETVAL OPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING) FDEV))) (CL:WHEN STREAM (FDEVOP 'UNREGISTERFILE TARGETDEV TARGETDEV STREAM) (change (fetch (STREAM FULLFILENAME) of STREAM) (CONTRACT.PH DATUM FDEV T)) (replace (STREAM DEVICE) of STREAM with FDEV)) STREAM]) (GETFILENAME.PH [LAMBDA (NAME RECOG FDEV) (* ; "Edited 25-Apr-2026 16:11 by rmk") (* ; "Edited 25-Jan-2022 22:56 by rmk") (* ; "Edited 16-Jan-2022 20:27 by rmk") (PSEUDOHOST.NAME GETFILENAME (NAME RECOG FDEV]) (DIRECTORYNAMEP.PH [LAMBDA (DIRSPEC DEV CREATE?) (* ; "Edited 25-Jan-2022 22:56 by rmk") (* ; "Edited 18-Jan-2022 11:32 by rmk") (* ;; "{FOO} by itself is always a legitimate directory--you should be able to connect to it when you are starting up")  (* ; "Edited 16-Jan-2022 20:35 by rmk") (OR (EQ (CHARCODE }) (NTHCHARCODE DIRSPEC -1)) (PSEUDOHOST.NAME DIRECTORYNAMEP (DIRSPEC DEV CREATE?) DEV]) (CLOSEFILE.PH [LAMBDA (STREAM ABORTFLG) (* ; "Edited 25-Jun-2022 14:38 by rmk") (* ; "Edited 16-Jan-2022 15:38 by rmk") (APPLY* (FETCH (FDEV CLOSEFILE) OF (FETCH (PHDEVICE TARGETDEV) OF (FETCH (STREAM DEVICE) OF STREAM))) STREAM ABORTFLG]) (REOPENFILE.PH [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 26-Apr-2026 10:26 by rmk") (* ; "Edited 25-Jan-2022 12:50 by rmk") (* ; "Edited 18-Jan-2022 11:41 by rmk") (LET ((STREAM (PSEUDOHOST.TARGETVAL REOPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) FDEV))) (CHANGE (fetch (STREAM FULLFILENAME) of STREAM) (CONTRACT.PH DATUM FDEV T)) (replace (STREAM DEVICE) of STREAM with FDEV) STREAM]) (DELETEFILE.PH [LAMBDA (FILENAME DEV) (* ; "Edited 25-Apr-2026 23:41 by rmk") (* ; "Edited 25-Jan-2022 22:56 by rmk") (PSEUDOHOST.NAME DELETEFILE (FILENAME DEV]) (GENERATEFILES.PH [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 25-Apr-2026 23:21 by rmk") (* ; "Edited 17-Jan-2022 20:46 by rmk") (* ;; "FDEV is the pseudohost. We will generate from the target directory using its GENFILESTATE, but fiddle the output so that it looks like it is coming from the pseudo host.") (LET ((TARGETGENOBJ (APPLY* (FETCH (FDEV GENERATEFILES) OF (FETCH (PHDEVICE TARGETDEV) OF FDEV)) (FETCH (PHDEVICE TARGETDEV) OF FDEV) (EXPAND.PH PATTERN FDEV) DESIREDPROPS OPTIONS))) (* ;; "The TARGETGENOBJ contains the targets functions as well as its GENFILESTATE. We need the ph FDEV to contract the generated names") (CREATE FILEGENOBJ NEXTFILEFN _ (FUNCTION NEXTFILEFN.PH) FILEINFOFN _ (FUNCTION FILEINFOFN.PH) GENFILESTATE _ (LIST FDEV TARGETGENOBJ (fetch (FDEV DEVICENAME) of FDEV]) (GETFILEINFO.PH [LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 22-Apr-2026 18:12 by rmk") (* ; "Edited 20-Apr-2026 08:30 by rmk") (* ; "Edited 25-Jan-2022 12:43 by rmk") (* ; "Edited 17-Jan-2022 18:21 by rmk") (GETFILEINFO (TRUEFILENAME STREAM) ATTRIBUTE]) (SETFILEINFO.PH [LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 25-Apr-2026 15:52 by rmk") (* ; "Edited 25-Jan-2022 12:37 by rmk") (SETFILEINFO (TRUEFILENAME STREAM) ATTRIBUTE VALUE]) (NEXTFILEFN.PH [LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 25-Apr-2026 23:21 by rmk") (* ; "Edited 17-Jan-2022 21:27 by rmk") (LET* ((TARGETGENOBJ (CADR GENFILESTATE)) (TARGETGENFILESTATE (FETCH GENFILESTATE OF TARGETGENOBJ)) (FILENAME (APPLY* (FETCH NEXTFILEFN OF TARGETGENOBJ) TARGETGENFILESTATE NAMEONLY))) (CL:WHEN FILENAME (CL:UNLESS NAMEONLY (SETQ FILENAME (CONTRACT.PH FILENAME (CAR GENFILESTATE) (CADDR GENFILESTATE))))) FILENAME]) (FILEINFOFN.PH [LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 17-Jan-2022 20:52 by rmk") (APPLY* (FETCH FILEINFOFN OF (CADR GENFILESTATE)) (FETCH GENFILESTATE OF (CADR GENFILESTATE)) ATTRIBUTE]) (BIN.PH [LAMBDA (STREAM) (* ; "Edited 21-Jun-2026 00:38 by rmk") (* ; "Edited 25-Jun-2022 14:38 by rmk") (* ; "Edited 16-Jan-2022 15:38 by rmk") (APPLY* (FETCH (FDEV BIN) OF (FETCH (PHDEVICE TARGETDEV) OF (FETCH (STREAM DEVICE) OF STREAM))) STREAM]) (GETNEXTBUFFER.PH [LAMBDA (STREAM WHATFOR NOERRORFLG) (* ; "Edited 21-Jun-2026 01:16 by rmk") (* ; "Edited 25-Jun-2022 14:38 by rmk") (* ; "Edited 16-Jan-2022 15:38 by rmk") (APPLY* (FETCH (FDEV GETNEXTBUFFER) OF (FETCH (PHDEVICE TARGETDEV) OF (FETCH (STREAM DEVICE) OF STREAM))) STREAM WHATFOR NOERRORFLG]) ) (MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG) (MOVD 'GETHOSTINFO.PH 'GETHOSTINFO) (RPAQ? PREFIXMAPS.PH NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PREFIXMAPS.PH) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS PHDEVICE ((TRUEPREFIX (fetch (FDEV FDEV2) of DATUM) (replace (FDEV FDEV2) of DATUM with NEWVALUE)) (PREFIX (fetch (FDEV FDEV4) of DATUM) (replace (FDEV FDEV4) of DATUM with NEWVALUE)) (TARGETDEV (fetch (FDEV FDEV1) of DATUM) (replace (FDEV FDEV1) of DATUM with NEWVALUE))) [TYPE? (AND DATUM (EQ 'OPENFILE.PH (fetch (FDEV OPENFILE) of DATUM]) (RECORD PHGENFILESTATE (PHDEVICE . TARGETGENFILESTATE)) (ACCESSFNS TARGETDEVICE ((PREFIXMAPS (CDR (ASSOC (U-CASE (fetch (FDEV DEVICENAME) of DATUM)) PREFIXMAPS.PH)) (RPLACD [OR (ASSOC (U-CASE (fetch (FDEV DEVICENAME) of DATUM)) PREFIXMAPS.PH) (CAR (PUSH PREFIXMAPS.PH (CONS (U-CASE (fetch (FDEV DEVICENAME) of DATUM] NEWVALUE)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS PSEUDOHOST.NAME MACRO [TAIL (LET [(OPNAME (CAR TAIL)) (ARGS (CADR TAIL)) (DEV (OR (CADDR TAIL) (CAR (LAST (CADR TAIL] (* ;;  "Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately") `(CONTRACT.PH [APPLY* (fetch (FDEV ,OPNAME) of (fetch (PHDEVICE TARGETDEV) OF ,DEV)) (EXPAND.PH ,(CAR ARGS) ,DEV) ,@(SUBST `(fetch (PHDEVICE TARGETDEV) of ,DEV) DEV (CDR ARGS] ,DEV T]) (PUTPROPS PSEUDOHOST.TARGETVAL MACRO [TAIL (LET [(OPNAME (CAR TAIL)) (ARGS (CADR TAIL)) (DEV (OR (CADDR TAIL) (CAR (LAST (CADR TAIL] (* ;; "Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately. Unlike PSEUDOHOST.OP, this returns the target value, doesn't assume it is a name to be contracted.") `(APPLY* (FETCH (FDEV ,OPNAME) OF (FETCH (PHDEVICE TARGETDEV) OF ,DEV)) (EXPAND.PH ,(CAR ARGS) ,DEV) ,@(SUBST `(FETCH (PHDEVICE TARGETDEV) OF ,DEV) DEV (CDR ARGS]) ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1254 16382 (PSEUDOHOST 1264 . 9260) (PSEUDOHOSTP 9262 . 10248) (PSEUDOHOSTS 10250 . 10917) (TARGETHOST 10919 . 11498) (TRUEDEVICE 11500 . 12529) (TRUEFILENAME 12531 . 13882) ( PSEUDOFILENAME 13884 . 15558) (PSEUDOFILENAMES 15560 . 16380)) (16383 17532 (CDPSEUDO 16393 . 17530)) (17560 26091 (PSEUDOHOST.PREFIXMAP 17570 . 20047) (EXPAND.PH 20049 . 21409) (CONTRACT.PH 21411 . 24007 ) (UNSLASHIT 24009 . 25755) (GETHOSTINFO.PH 25757 . 26089)) (26092 33797 (OPENFILE.PH 26102 . 27227) ( GETFILENAME.PH 27229 . 27627) (DIRECTORYNAMEP.PH 27629 . 28253) (CLOSEFILE.PH 28255 . 28722) ( REOPENFILE.PH 28724 . 29400) (DELETEFILE.PH 29402 . 29686) (GENERATEFILES.PH 29688 . 30882) ( GETFILEINFO.PH 30884 . 31405) (SETFILEINFO.PH 31407 . 31716) (NEXTFILEFN.PH 31718 . 32434) ( FILEINFOFN.PH 32436 . 32711) (BIN.PH 32713 . 33195) (GETNEXTBUFFER.PH 33197 . 33795))))) STOP