;;; Pathnames -*-Mode:LISP;Package:FS-*- ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;; Advertised function interfaces: ;;; PARSE-PATHNAME THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) ;;; Parses a string (or whatever) into a pathname. ;;; DEFAULT-PATHNAME &OPTIONAL DEFAULTS HOST DEFAULT-TYPE DEFAULT-VERSION ;;; Returns the default for the given HOST from DEFAULTS. ;;; SET-DEFAULT-PATHNAME PATHNAME &OPTIONAL DEFAULTS ;;; Sets the default for either the host of the pathname or the NIL default. ;;; MAKE-PATHNAME-DEFAULTS ;;; Returns an alist that you can pass to the functions below that take a set of defaults. ;;; Most things that take a set of defaults will also take a single pathname. ;;; MERGE-PATHNAME-DEFAULTS PATHNAME &OPTIONAL DEFAULTS DEFAULT-TYPE DEFAULT-VERSION ;;; Fill in slots in PATHNAME from program defaults. This is what most ;;; programs interface to. ;;; MERGE-AND-SET-PATHNAME-DEFAULTS PATHNAME &OPTIONAL DEFAULTS DEFAULT-TYPE DEFAULT-VERSION ;;; Does parse, merge, and updating of defaults. ;;; DESCRIBE-PATHNAME PATHNAME ;;; Describes all files that look like pathname. Also useful when you cannot remember what ;;; directory a file is in. ;;; PATHNAME-PLIST PATHNAME ;;; Advertised messages on pathnames: ;;; :GET INDICATOR ;;; :PUTPROP PROP INDICATOR ;;; :REMPROP INDICATOR ;;; :DEVICE, :DIRECTORY, :NAME, :TYPE, :VERSION ;;; :NEW-DEVICE, :NEW-DIRECTORY, :NEW-NAME, :NEW-TYPE, :NEW-VERSION ;;; :NEW-STRUCTURED-DEVICE, :NEW-STRUCTURED-DIRECTORY, :NEW-STRUCTURED-NAME ;;; :NEW-PATHNAME &REST OPTIONS ;;; :DEFAULT-NAMESTRING STRING ;;; :GENERIC-PATHNAME ;;; :STRING-FOR-HOST, :STRING-FOR-PRINTING, :STRING-FOR-WHOLINE, :STRING-FOR-EDITOR ;;; :STRING-FOR-DIRED ;;; :INIT-FILE PROGRAM-NAME ;;; Advertised special variables: ;;; *KNOWN-TYPES* - list of types unimportant for the sake of generic pathnames. ;;; *DEFAULTS-ARE-PER-HOST* - user option. If NIL, pathnames defaults are maintained all ;;; together for all hosts. ;;; *ITS-UNINTERESTING-TYPES* - types that do not deserve the FN2 slot. ;;; Other system types (pathname syntaxes) must implement at least the following messages: ;;; They can then be mixed with CHAOS-PATHNAME for use with the standard chaosnet file ;;; job protocol. ;;; :STRING-FOR-HOST - returns a string that can be sent to the file computer that ;;; specifying the file in question. ;;; :PARSE-NAMESTRING - takes a string and returns multiple values for various components ;;; present in the string. ;;; See ITS-PATHNAME-MIXIN and/or TOPS20-PATHNAME-MIXIN for additional details. ;;; To add another protocol, implement the messages of CHAOS-PATHNAME for generic file ;;; manipulation. That flavor is defined in QFILE. ;;; Interaction with host objects: ;;; The HOST instance variable of a pathname is a host object, as ;;; outlined in AI: LISPM2; HOST >. ;;; *PATHNAME-HOST-LIST* is the set of all pathname hosts. Some of ;;; these are actual hosts on the local network, such as MIT-AI, and ;;; others are logical hosts, such as SYS. When parsing a string into a ;;; pathname, the specified host (the part of the string before the ;;; colon) is sent in the :PATHNAME-HOST-NAMEP message to each host in ;;; this list. When that returns T, that host is used. ;;; The host is sent a :PATHNAME-FLAVOR message to determine the flavor of the ;;; pathname to instantiate. (If the reply to :PATHNAME-FLAVOR returns multiple ;;; values, the second is an addition for the INIT-PLIST to use when instantiating.) ;;; Normally, when printing the host portion of a pathname, the host is ;;; sent a :NAME-AS-FILE-COMPUTER message. ;; The pathname hash table, pathnames, and cached strings are stored here to improve locality. (DEFVAR PATHNAME-AREA (MAKE-AREA ':NAME 'PATHNAME-AREA ':GC ':STATIC)) ;;; This is a separate flavor so there can be dummy pathnames which just print and store ;;; properties. (DEFFLAVOR EMPTY-PATHNAME () (SI:PROPERTY-LIST-MIXIN)) ;;; PRINC of a pathname is just like PRINC of the :STRING-FOR-PRINTING (DEFMETHOD (EMPTY-PATHNAME :PRINT-SELF) (STREAM IGNORE SLASHIFY-P) (IF SLASHIFY-P (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :NO-POINTER) (PRINC (TYPEP SELF) STREAM) (FUNCALL STREAM ':TYO #\SP) (PRIN1 (FUNCALL-SELF ':STRING-FOR-PRINTING) STREAM)) (FUNCALL STREAM ':STRING-OUT (FUNCALL-SELF ':STRING-FOR-PRINTING)))) (DEFMETHOD (EMPTY-PATHNAME :PLIST) () SI:PROPERTY-LIST) ;;; This is for use by things like the editor which have structures that store file-like ;;; properties on non-pathname objects. (DEFFLAVOR DUMMY-PATHNAME (NAME) (EMPTY-PATHNAME) :INITABLE-INSTANCE-VARIABLES) (DEFMETHOD (DUMMY-PATHNAME :STRING-FOR-PRINTING) () NAME) (DEFMETHOD (DUMMY-PATHNAME :STRING-FOR-EDITOR) () NAME) (DEFMETHOD (DUMMY-PATHNAME :STRING-FOR-DIRED) () NAME) (DEFUN MAKE-DUMMY-PATHNAME (NAME &OPTIONAL PLIST) (MAKE-INSTANCE 'DUMMY-PATHNAME ':NAME NAME ':PROPERTY-LIST PLIST)) ;;; This is the actual base flavor (DEFFLAVOR PATHNAME (HOST (DEVICE NIL) (DIRECTORY NIL) (NAME NIL) (TYPE NIL) (VERSION NIL) (SI:PROPERTY-LIST NIL) ;Where files properties are stored (STRING-FOR-PRINTING NIL) ) (EMPTY-PATHNAME) :ORDERED-INSTANCE-VARIABLES (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES HOST DEVICE DIRECTORY NAME TYPE VERSION SI:PROPERTY-LIST) (:GETTABLE-INSTANCE-VARIABLES HOST DEVICE DIRECTORY NAME TYPE VERSION SI:PROPERTY-LIST) (:INITABLE-INSTANCE-VARIABLES HOST DEVICE DIRECTORY NAME TYPE VERSION SI:PROPERTY-LIST) (:REQUIRED-METHODS :PARSE-NAMESTRING)) (DEFMETHOD (PATHNAME :INIT) (IGNORE) (OR (BOUNDP 'HOST) (FERROR NIL "Host must be specified when initializing a pathname"))) ;;; Caching of strings (DEFWRAPPER (PATHNAME :STRING-FOR-PRINTING) (IGNORE . BODY) `(OR STRING-FOR-PRINTING (LET ((DEFAULT-CONS-AREA PATHNAME-AREA)) (SETQ STRING-FOR-PRINTING (PROGN . ,BODY))))) (DEFMETHOD (PATHNAME :STRING-FOR-WHOLINE) () (FUNCALL-SELF ':STRING-FOR-PRINTING)) (DEFMETHOD (PATHNAME :STRING-FOR-DIRED) () (FUNCALL-SELF ':STRING-FOR-PRINTING)) (DEFMETHOD (PATHNAME :STRING-FOR-MINI) () (FUNCALL-SELF ':STRING-FOR-PRINTING)) (DEFMETHOD (PATHNAME :STRING-FOR-DIRECTORY) () (FUNCALL-SELF ':STRING-FOR-PRINTING)) (DEFFLAVOR MEANINGFUL-ROOT-MIXIN () () (:INCLUDED-FLAVORS PATHNAME) (:REQUIRED-METHODS :DIRECTORY-PATHNAME-AS-FILE) (:DOCUMENTATION :MIXIX "For use with file systems where the root directory is treated as an ordinary directory.")) ;;; This is a pathname that corresponds to a real (as opposed to logical) host (DEFFLAVOR HOST-PATHNAME ((STRING-FOR-WHOLINE NIL) (STRING-FOR-EDITOR NIL) (STRING-FOR-DIRED NIL) (STRING-FOR-DIRECTORY NIL) ) (PATHNAME)) (DEFWRAPPER (HOST-PATHNAME :STRING-FOR-WHOLINE) (IGNORE . BODY) `(OR STRING-FOR-WHOLINE (LET ((DEFAULT-CONS-AREA PATHNAME-AREA)) (SETQ STRING-FOR-WHOLINE (PROGN . ,BODY))))) (DEFWRAPPER (HOST-PATHNAME :STRING-FOR-EDITOR) (IGNORE . BODY) `(OR STRING-FOR-EDITOR (LET ((DEFAULT-CONS-AREA PATHNAME-AREA)) (SETQ STRING-FOR-EDITOR (PROGN . ,BODY))))) (DEFWRAPPER (HOST-PATHNAME :STRING-FOR-DIRED) (IGNORE . BODY) `(OR STRING-FOR-DIRED (LET ((DEFAULT-CONS-AREA PATHNAME-AREA)) (SETQ STRING-FOR-DIRED (PROGN . ,BODY))))) (DEFWRAPPER (HOST-PATHNAME :STRING-FOR-DIRECTORY) (IGNORE . BODY) `(OR STRING-FOR-DIRECTORY (LET ((DEFAULT-CONS-AREA PATHNAME-AREA)) (SETQ STRING-FOR-DIRECTORY (PROGN . ,BODY))))) ;;; This is a pathname connected by some remote medium. It might even be a local file ;;; system if that interfaces through a :STRING-FOR-HOST. (DEFFLAVOR REMOTE-PATHNAME ((STRING-FOR-HOST NIL) ;Caches ) (HOST-PATHNAME) (:REQUIRED-METHODS :STRING-FOR-HOST)) (DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-PRINTING) () (STRING-APPEND (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) ": " (FUNCALL-SELF ':STRING-FOR-HOST))) (DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-EDITOR) () (STRING-APPEND (FUNCALL-SELF ':STRING-FOR-HOST) #\SP (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) #/:)) (DEFWRAPPER (REMOTE-PATHNAME :STRING-FOR-HOST) (IGNORE . BODY) `(OR STRING-FOR-HOST (LET ((DEFAULT-CONS-AREA PATHNAME-AREA)) (SETQ STRING-FOR-HOST (PROGN . ,BODY))))) (DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-MINI) () (FUNCALL-SELF ':STRING-FOR-HOST)) (DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-DIRECTORY) () (FUNCALL-SELF ':STRING-FOR-HOST)) (DEFMETHOD (PATHNAME :NEW-DEVICE) (NEW-DEVICE) (FUNCALL-SELF ':NEW-PATHNAME ':DEVICE NEW-DEVICE)) (DEFMETHOD (PATHNAME :NEW-STRUCTURED-DEVICE) (NEW-DEVICE) (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-DEVICE NEW-DEVICE)) (DEFMETHOD (PATHNAME :NEW-DIRECTORY) (NEW-DIRECTORY) (FUNCALL-SELF ':NEW-PATHNAME ':DIRECTORY NEW-DIRECTORY)) (DEFMETHOD (PATHNAME :NEW-STRUCTURED-DIRECTORY) (NEW-DIRECTORY) (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-DIRECTORY NEW-DIRECTORY)) (DEFMETHOD (PATHNAME :NEW-NAME) (NEW-NAME) (FUNCALL-SELF ':NEW-PATHNAME ':NAME NEW-NAME)) (DEFMETHOD (PATHNAME :NEW-STRUCTURED-NAME) (NEW-NAME) (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-NAME NEW-NAME)) (DEFMETHOD (PATHNAME :NEW-TYPE) (NEW-TYPE) (FUNCALL-SELF ':NEW-PATHNAME ':TYPE NEW-TYPE)) (DEFMETHOD (PATHNAME :NEW-VERSION) (NEW-VERSION) (FUNCALL-SELF ':NEW-PATHNAME ':VERSION NEW-VERSION)) ;;; These exist for the sake of ITS (DEFMETHOD (PATHNAME :NEW-TYPE-AND-VERSION) (NEW-TYPE NEW-VERSION) (FUNCALL-SELF ':NEW-PATHNAME ':TYPE NEW-TYPE ':VERSION NEW-VERSION)) (DEFMETHOD (PATHNAME :TYPE-AND-VERSION) () (VALUES TYPE VERSION)) (DEFMETHOD (PATHNAME :PATCH-FILE-PATHNAME) (NAM SAME-DIRECTORY-P PATOM TYP &REST ARGS) (SELECTQ TYP (:SYSTEM-DIRECTORY (FUNCALL-SELF ':NEW-PATHNAME ':NAME (IF SAME-DIRECTORY-P PATOM NAM) ':TYPE (IF SAME-DIRECTORY-P "DIRECTORY" "PATCH-DIRECTORY") ':VERSION ':NEWEST)) (:VERSION-DIRECTORY (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~A~*~;~*~A~]-~D" SAME-DIRECTORY-P NAM PATOM (CAR ARGS)) ':TYPE (IF SAME-DIRECTORY-P "DIRECTORY" "PATCH-DIRECTORY") ':VERSION ':NEWEST)) (:PATCH-FILE (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~A~*~;~*~A~]-~D-~D" SAME-DIRECTORY-P NAM PATOM (CAR ARGS) (CADR ARGS)) ':TYPE (CADDR ARGS) ':VERSION ':NEWEST)))) (DEFMETHOD (HOST-PATHNAME :INIT-FILE) (PROGRAM-NAME) (FUNCALL-SELF ':NEW-PATHNAME ':NAME PROGRAM-NAME ':TYPE "INIT" ':VERSION ':NEWEST)) ;;; Default is for users to have their own directories. (DEFMETHOD (PATHNAME :HOMEDIR) () (MAKE-PATHNAME ':HOST HOST ':DIRECTORY USER-ID)) ;;; By default, a directory is stored as a file in the superior directory whose name gives ;;; the name of the component at this level. (DEFMETHOD (PATHNAME :PATHNAME-AS-DIRECTORY) () (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-DIRECTORY (APPEND (IF (LISTP DIRECTORY) DIRECTORY (NCONS DIRECTORY)) (NCONS NAME)) ':NAME ':UNSPECIFIC ':TYPE ':UNSPECIFIC ':VERSION ':UNSPECIFIC)) (DEFVAR *KNOWN-TYPES* '("QFASL" "LISP" "TEXT" NIL :UNSPECIFIC)) (DEFMETHOD (PATHNAME :GENERIC-PATHNAME) () (FUNCALL-SELF ':NEW-PATHNAME ':TYPE (IF (MEMBER TYPE *KNOWN-TYPES*) ':UNSPECIFIC TYPE) ':VERSION ':UNSPECIFIC)) ;;; Create a pathname, specifying components in external syntax form. ;;; Similar to sending a :NEW-PATHNAME message to an existing pathname, ;;; except that there is no pre-existing pathname, and defaulting comes ;;; only from the (specified or default) defaults. (DEFUN MAKE-PATHNAME (&REST OPTIONS &OPTIONAL &KEY (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (HOST (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T))) &ALLOW-OTHER-KEYS) (LEXPR-FUNCALL (DEFAULT-PATHNAME DEFAULTS HOST NIL NIL T) ':NEW-PATHNAME OPTIONS)) ;;; Make sure that a :NEW-PATHNAME which specifies a new host ;;; is processed by the flavor of pathname for that host. (DEFWRAPPER (PATHNAME :NEW-PATHNAME) (OPTIONS . BODY) `(LET ((NEW-HOST (GET (LOCF OPTIONS) ':HOST))) (IF (AND NEW-HOST (NEQ HOST (SETQ NEW-HOST (GET-PATHNAME-HOST NEW-HOST)))) (LEXPR-FUNCALL (DEFAULT-PATHNAME NIL NEW-HOST NIL NIL T) ':NEW-PATHNAME ':DEVICE DEVICE (IF (LISTP DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY) DIRECTORY (IF (LISTP NAME) ':STRUCTURED-NAME ':NAME) NAME ':TYPE TYPE ':VERSION VERSION OPTIONS) . ,BODY))) ;;; This is the fundamental way of altering some of the components of a pathname. ;;; Specify an alternating list of components and values. ;;; Components allowed are :HOST, :DEVICE, :DIRECTORY, :NAME, :TYPE and :VERSION; ;;; also, you can specify :STRUCTURED-DEVICE, :STRUCTURED-DIRECTORY or :STRUCTURED-NAME. ;;; Those three are equivalent to specifying :DEVICE, :DIRECTORY or :NAME ;;; but the argument is in internal format. ;;; All the :NEW-x operations call this one (by default), ;;; and all the :PARSE-x operations (except :PARSE-NAMESTRING) ;;; are called only by MAKE-PATHNAME-1, which is called only from here. (DEFMETHOD (PATHNAME :NEW-PATHNAME) (&REST OPTIONS &AUX (PLIST (LOCF OPTIONS))) (LEXPR-FUNCALL #'MAKE-PATHNAME-1 ':HOST (OR (GET PLIST ':HOST) HOST) ':DEVICE DEVICE (IF (LISTP DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY) DIRECTORY (IF (LISTP NAME) ':STRUCTURED-NAME ':NAME) NAME ':TYPE TYPE ':VERSION VERSION OPTIONS)) (DEFUN MAKE-PATHNAME-1 (&REST OPTIONS &AUX NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION DEFAULTS NEW-HOST ACTOR) (SETQ DEFAULTS (OR (GET (LOCF OPTIONS) ':DEFAULTS) *DEFAULT-PATHNAME-DEFAULTS*) NEW-HOST (OR (GET (LOCF OPTIONS) ':HOST) (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T)))) (SETQ ACTOR (DEFAULT-PATHNAME DEFAULTS NEW-HOST NIL NIL T)) (TV:DOPLIST (OPTIONS VAL KEY) (SELECTQ KEY (:DEFAULTS) (:HOST) (:DEVICE (SETQ NEW-DEVICE (FUNCALL ACTOR ':PARSE-DEVICE-SPEC VAL))) (:STRUCTURED-DEVICE (SETQ NEW-DEVICE (FUNCALL ACTOR ':PARSE-STRUCTURED-DEVICE-SPEC VAL))) (:DIRECTORY (SETQ NEW-DIRECTORY (FUNCALL ACTOR ':PARSE-DIRECTORY-SPEC VAL))) (:STRUCTURED-DIRECTORY (SETQ NEW-DIRECTORY (FUNCALL ACTOR ':PARSE-STRUCTURED-DIRECTORY-SPEC VAL))) (:NAME (SETQ NEW-NAME (FUNCALL ACTOR ':PARSE-NAME-SPEC VAL))) (:STRUCTURED-NAME (SETQ NEW-NAME (FUNCALL ACTOR ':PARSE-STRUCTURED-NAME-SPEC VAL))) (:TYPE (SETQ NEW-TYPE (FUNCALL ACTOR ':PARSE-COMPONENT-SPEC VAL))) (:VERSION (SETQ NEW-VERSION VAL)) (OTHERWISE (FERROR NIL "~S is not a recognized option" KEY)))) (MAKE-PATHNAME-INTERNAL (GET-PATHNAME-HOST NEW-HOST) NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION)) (DEFUN PATHNAME-PASS-THROUGH-SPEC (IGNORE SPEC) (FUNCALL-SELF ':PARSE-COMPONENT-SPEC SPEC)) ;;; Default is to leave the string alone (DEFMETHOD (PATHNAME :PARSE-COMPONENT-SPEC) (SPEC) SPEC) (DEFMETHOD (PATHNAME :PARSE-DEVICE-SPEC) PATHNAME-PASS-THROUGH-SPEC) (DEFMETHOD (PATHNAME :PARSE-STRUCTURED-DEVICE-SPEC) (SPEC) (AND (LISTP SPEC) (SETQ SPEC (CAR SPEC))) (FUNCALL-SELF ':PARSE-DEVICE-SPEC SPEC)) (DEFMETHOD (PATHNAME :PARSE-DIRECTORY-SPEC) PATHNAME-PASS-THROUGH-SPEC) (DEFMETHOD (PATHNAME :PARSE-STRUCTURED-DIRECTORY-SPEC) (SPEC) (AND (LISTP SPEC) (SETQ SPEC (CAR SPEC))) (FUNCALL-SELF ':PARSE-DIRECTORY-SPEC SPEC)) (DEFMETHOD (PATHNAME :PARSE-NAME-SPEC) PATHNAME-PASS-THROUGH-SPEC) (DEFMETHOD (PATHNAME :PARSE-STRUCTURED-NAME-SPEC) (SPEC) (AND (LISTP SPEC) (SETQ SPEC (CAR SPEC))) (FUNCALL-SELF ':PARSE-NAME-SPEC SPEC)) (DEFMETHOD (PATHNAME :TRANSLATED-PATHNAME) () SELF) (DEFMETHOD (PATHNAME :BACK-TRANSLATED-PATHNAME) (PATHNAME) PATHNAME) ;;; This is used to parse a string which may not have the host in it (DEFMETHOD (PATHNAME :PARSE-TRUENAME) (STRING) (PARSE-PATHNAME STRING HOST)) (DEFUN PATHNAME-LESSP (PATHNAME-1 PATHNAME-2) (FUNCALL PATHNAME-1 ':SORT-LESSP PATHNAME-2)) (DEFMETHOD (PATHNAME :SORT-LESSP) (OTHER-PATHNAME) (DO ((FIELDS '(HOST DEVICE DIRECTORY NAME TYPE VERSION) (CDR FIELDS)) (FIELD-1) (FIELD-2)) ((NULL FIELDS) (STRING-LESSP SELF OTHER-PATHNAME)) (SETQ FIELD-1 (SYMEVAL (CAR FIELDS)) FIELD-2 (SYMEVAL-IN-INSTANCE OTHER-PATHNAME (CAR FIELDS))) (COND ((EQUAL FIELD-1 FIELD-2)) ((SYMBOLP FIELD-1) (RETURN (OR (NOT (SYMBOLP FIELD-2)) (STRING-LESSP FIELD-1 FIELD-2)))) ((SYMBOLP FIELD-2) (RETURN NIL)) ((STRINGP FIELD-1) (RETURN (OR (NOT (STRINGP FIELD-2)) (STRING-LESSP FIELD-1 FIELD-2)))) ((STRINGP FIELD-2) (RETURN NIL)) ((NUMBERP FIELD-1) (RETURN (OR (NOT (NUMBERP FIELD-2)) (< FIELD-1 FIELD-2)))) ((NUMBERP FIELD-2) (RETURN NIL)) (T (RETURN (ALPHALESSP FIELD-1 FIELD-2)))))) (DEFMETHOD (PATHNAME :FASD-FORM) () `(MAKE-FASLOAD-PATHNAME ',(FUNCALL HOST ':NAME-AS-FILE-COMPUTER) ',DEVICE ',DIRECTORY ',NAME ',TYPE ',VERSION)) (DEFUN MAKE-FASLOAD-PATHNAME (HOST DEVICE DIRECTORY NAME TYPE VERSION &AUX PATH-HOST PATH) ;; Don't bomb out if the file computer that compiled this file doesn't exist any more. ;; Just take the one the file is being loaded from. (SETQ PATH-HOST (COND ((GET-PATHNAME-HOST HOST)) (SI:FDEFINE-FILE-PATHNAME (PATHNAME-HOST SI:FDEFINE-FILE-PATHNAME)) (T USER-LOGIN-MACHINE)) PATH (MAKE-PATHNAME-INTERNAL PATH-HOST DEVICE DIRECTORY NAME TYPE VERSION)) ;; Record the actual host for possible debugging. (AND (NEQ HOST PATH-HOST) (FUNCALL PATH ':PUTPROP HOST ':FASLOAD-HOST)) PATH) (DEFVAR *PATHNAME-HASH-TABLE*) (DEFUN MAKE-PATHNAME-INTERNAL (&REST REST &AUX TEM PATHNAME) (DECLARE (ARGLIST HOST DEVICE DIRECTORY NAME TYPE VERSION)) (MULTIPLE-VALUE (PATHNAME TEM) (GETHASH-EQUAL REST *PATHNAME-HASH-TABLE*)) (IF TEM (VALUES PATHNAME T) (LET ((DEFAULT-CONS-AREA PATHNAME-AREA)) (SETQ PATHNAME (APPLY #'MAKE-PATHNAME-INTERNAL-1 REST)) (PUTHASH-EQUAL (COPYLIST REST) PATHNAME *PATHNAME-HASH-TABLE*) (VALUES PATHNAME NIL)))) (DEFUN MAKE-PATHNAME-INTERNAL-1 (HOST DEVICE DIRECTORY NAME TYPE VERSION) (MULTIPLE-VALUE-BIND (FLAVOR-NAME OPTIONS) (FUNCALL HOST ':PATHNAME-FLAVOR) (LEXPR-FUNCALL #'MAKE-INSTANCE FLAVOR-NAME ':HOST HOST ':DEVICE DEVICE ':DIRECTORY DIRECTORY ':NAME NAME ':TYPE TYPE ':VERSION VERSION OPTIONS))) ;;; Turn anything into a pathname ;;; WITH-RESPECT-TO is the host to parse this on. DEFAULTS is a set of defaults. (DEFUN PARSE-PATHNAME (THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)) (AND WITH-RESPECT-TO (SETQ WITH-RESPECT-TO (GET-PATHNAME-HOST WITH-RESPECT-TO))) (COND ((TYPEP THING 'PATHNAME) THING) ((LISTP THING) (SETQ THING (CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST THING)) (LET (DEVICE DIRECTORY NAME TYPE VERSION HOST) (COND ((LISTP (CAR THING)) (SETF `((,DEVICE ,DIRECTORY) ,NAME ,TYPE ,VERSION) THING)) ((NUMBERP (THIRD THING)) (SETF `(,NAME ,TYPE ,VERSION ,DEVICE ,DIRECTORY) THING)) (T (SETF `(,NAME ,TYPE ,DEVICE ,DIRECTORY ,VERSION) THING))) (SETQ HOST (COND ((GET-PATHNAME-HOST DEVICE)) (WITH-RESPECT-TO) (T (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T))))) (AND WITH-RESPECT-TO (NEQ WITH-RESPECT-TO HOST) (FERROR NIL "Host ~A in ~A does not match ~A" HOST THING WITH-RESPECT-TO)) (MAKE-PATHNAME ':DEFAULTS DEFAULTS ':HOST HOST ':DEVICE DEVICE ':DIRECTORY DIRECTORY ':NAME NAME ':TYPE TYPE ':VERSION VERSION))) (T (SETQ THING (STRING THING)) (MULTIPLE-VALUE-BIND (HOST-SPECIFIED START END) (PARSE-PATHNAME-FIND-COLON THING) ;; If the thing before the colon is really a host, ;; and WITH-RESPECT-TO was specified, then they had better match (AND WITH-RESPECT-TO HOST-SPECIFIED (NEQ WITH-RESPECT-TO HOST-SPECIFIED) ;; Otherwise treat it as a device name (SETQ HOST-SPECIFIED NIL START 0 END NIL)) (LET ((HOST (OR HOST-SPECIFIED WITH-RESPECT-TO (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T))))) (MULTIPLE-VALUE-BIND (DEVICE DIRECTORY NAME TYPE VERSION) (FUNCALL (DEFAULT-PATHNAME DEFAULTS HOST NIL NIL T) ':PARSE-NAMESTRING (NOT (NULL HOST-SPECIFIED)) THING START END) (MAKE-PATHNAME-INTERNAL HOST DEVICE DIRECTORY NAME TYPE VERSION))))))) (DEFUN CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST (X) (COND ((OR (NULL X) (NUMBERP X)) X) ((LISTP X) (MAPCAR #'CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST X)) (T (STRING X)))) (DEFUN PARSE-PATHNAME-FIND-COLON (STRING &AUX HOST-SPECIFIED (START 0) (END (STRING-LENGTH STRING))) (DECLARE (RETURN-LIST HOST-SPECIFIED START END)) (DO ((IDX START (1+ IDX)) (HOST-START START) (ONLY-WHITESPACE-P T) (CHAR)) (( IDX END)) (COND ((= (SETQ CHAR (AREF STRING IDX)) #/:) ;; The first atom ends with a colon, take the host from that, and ;; parse from the end of that. (SETQ HOST-SPECIFIED (SUBSTRING STRING HOST-START IDX) START (1+ IDX)) (RETURN)) ((AND (= CHAR #\SP) ONLY-WHITESPACE-P) ;Skip leading spaces (SETQ HOST-START (1+ IDX))) (T (SETQ ONLY-WHITESPACE-P NIL) (OR (AND ( CHAR #/0) ( CHAR #/9)) (AND ( CHAR #/A) ( CHAR #/Z)) (AND ( CHAR #/a) ( CHAR #/z)) (= CHAR #/-) ;; If we get to non-alphabetic or -numeric, ;; then no interesting colon (RETURN))))) (AND (NULL HOST-SPECIFIED) (PLUSP END) (= (AREF STRING (1- END)) #/:) (SETQ HOST-SPECIFIED (STRING-REVERSE-SEARCH-CHAR #\SP STRING (1- END))) ;; The last character is a colon, take the host from the last atom, and ;; parse from the beginning to the space before that. (PSETQ HOST-SPECIFIED (SUBSTRING STRING (1+ HOST-SPECIFIED) (1- END)) END HOST-SPECIFIED)) ;; If what looked like the host really wasn't, forget it and reset the indices (AND HOST-SPECIFIED (NULL (SETQ HOST-SPECIFIED (GET-PATHNAME-HOST HOST-SPECIFIED))) (SETQ START 0 END NIL)) ;This will be interpreted correctly (VALUES HOST-SPECIFIED START END)) ;;; Fill in slots in PATHNAME from program defaults. This is what most ;;; programs interface to. (DEFUN MERGE-PATHNAME-DEFAULTS (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (DEFAULT-TYPE ':UNSPECIFIC) (DEFAULT-VERSION ':NEWEST) &AUX HOST DEFAULT NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION) (SETQ PATHNAME (PARSE-PATHNAME PATHNAME NIL DEFAULTS)) ;; Host always comes from pathname (SETQ HOST (PATHNAME-HOST PATHNAME)) ;; Get default for this host (SETQ DEFAULT (DEFAULT-PATHNAME DEFAULTS HOST)) ;; Merge the device, directory, and name (LET ((PDIR (PATHNAME-DIRECTORY PATHNAME)) (DDIR (PATHNAME-DIRECTORY DEFAULT))) (SETQ NEW-DIRECTORY (COND ((NULL PDIR) DDIR) ((AND (LISTP PDIR) (EQ (CAR PDIR) ':RELATIVE)) (MERGE-RELATIVE-DIRECTORY PDIR DDIR))))) (OR (PATHNAME-DEVICE PATHNAME) (SETQ NEW-DEVICE (PATHNAME-DEVICE DEFAULT))) (OR (PATHNAME-NAME PATHNAME) (SETQ NEW-NAME (PATHNAME-NAME DEFAULT))) ;; Merge the type and version if the name was NIL before the above merge (COND ((NULL (PATHNAME-NAME PATHNAME)) (OR (PATHNAME-TYPE PATHNAME) (SETQ NEW-TYPE (PATHNAME-TYPE DEFAULT))) (OR (PATHNAME-VERSION PATHNAME) (SETQ NEW-VERSION (PATHNAME-VERSION DEFAULT))))) (OR (PATHNAME-TYPE PATHNAME) NEW-TYPE (SETQ NEW-TYPE DEFAULT-TYPE)) (OR (PATHNAME-VERSION PATHNAME) NEW-VERSION (SETQ NEW-VERSION DEFAULT-VERSION)) ;; Whatever the new fields are, give them to the pathname. (LET (NEW-FIELDS) (AND NEW-NAME (SETQ NEW-FIELDS (LIST* (IF (LISTP NEW-NAME) ':STRUCTURED-NAME ':NAME) NEW-NAME NEW-FIELDS))) (AND NEW-DIRECTORY (SETQ NEW-FIELDS (LIST* (IF (LISTP NEW-DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY) NEW-DIRECTORY NEW-FIELDS))) (AND NEW-DEVICE (SETQ NEW-FIELDS (LIST* (IF (LISTP NEW-DEVICE) ':STRUCTURED-DEVICE ':DEVICE) NEW-DEVICE NEW-FIELDS))) (AND NEW-TYPE (SETQ NEW-FIELDS (LIST* ':TYPE NEW-TYPE NEW-FIELDS))) (AND NEW-VERSION (SETQ NEW-FIELDS (LIST* ':VERSION NEW-VERSION NEW-FIELDS))) (LEXPR-FUNCALL PATHNAME ':NEW-PATHNAME NEW-FIELDS))) ;;; A relative directory is one whose CAR is :RELATIVE and whose CDR is a a list of ;;; strings and special symbols. The symbol :UP means step up in the hierarchy. ;;; Strings are just added onto the end of the default. ;;; E.g. (:relative "foo") ("usr" "lispm") => ("usr" "lispm" "foo") ;;; (:relative :up "bar") ("usr" "lispm" "foo") => ("usr" "lispm" "bar") (DEFUN MERGE-RELATIVE-DIRECTORY (RELATIVE DEFAULT &AUX DIRECTORY) (SETQ DIRECTORY (COND ((OR (NULL DEFAULT) (EQ DEFAULT ':ROOT)) NIL) ((ATOM DEFAULT) (NCONS DEFAULT)) (T (COPYLIST DEFAULT)))) (DOLIST (REL (CDR RELATIVE)) (IF (EQ REL ':UP) (IF (NULL DIRECTORY) (FERROR NIL "There is no superior to the root") (DO ((L DIRECTORY (CDR L)) (OL (LOCF DIRECTORY) L)) ((NULL (CDR L)) (RPLACD OL NIL)))) (SETQ DIRECTORY (NCONC DIRECTORY (NCONS REL))))) (AND (NULL (CDR DIRECTORY)) (SETQ DIRECTORY (CAR DIRECTORY))) DIRECTORY) ;;; Another handy user interface, fills in from defaults and updates them. Useful when ;;; not prompting. (DEFUN MERGE-AND-SET-PATHNAME-DEFAULTS (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (DEFAULT-TYPE ':UNSPECIFIC) (DEFAULT-VERSION ':NEWEST)) (SETQ PATHNAME (MERGE-PATHNAME-DEFAULTS PATHNAME DEFAULTS DEFAULT-TYPE DEFAULT-VERSION)) (AND (LISTP DEFAULTS) (SET-DEFAULT-PATHNAME PATHNAME DEFAULTS)) PATHNAME) (DEFMETHOD (PATHNAME :DEFAULT-NAMESTRING) (NAMESTRING &OPTIONAL (DEFAULT-TYPE ':UNSPECIFIC) (DEFAULT-VERSION ':NEWEST)) (MERGE-PATHNAME-DEFAULTS NAMESTRING SELF DEFAULT-TYPE DEFAULT-VERSION)) ;;; The default is not to have completion at all (DEFMETHOD (PATHNAME :COMPLETE-STRING) (STRING IGNORE) (VALUES (STRING-APPEND (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) ": " STRING) NIL)) (DEFMETHOD (PATHNAME :MULTIPLE-FILE-PLISTS) (FILES OPTIONS &AUX (CHARACTERS T)) (LOOP FOR (IND OPT) ON OPTIONS BY 'CDDR DO (SELECTQ IND (:CHARACTERS (SETQ CHARACTERS OPT)) (OTHERWISE (FERROR NIL "~S is not a known MULTIPLE-FILE-PLISTS option" IND)))) (LOOP FOR FILE IN FILES AS STREAM = (OPEN FILE ':DIRECTION NIL ':ERROR NIL ':CHARACTERS CHARACTERS) COLLECT (CONS FILE (AND (NOT (STRINGP STREAM)) (LET* ((LIST (FUNCALL STREAM ':PLIST)) (PLIST (LOCF LIST))) (OR (GET PLIST ':TRUENAME) (PUTPROP PLIST (FUNCALL STREAM ':TRUENAME) ':TRUENAME)) LIST))))) (DEFMETHOD (PATHNAME :UNDELETE) (ERROR-P) (CHANGE-FILE-PROPERTIES SELF ERROR-P ':DELETED NIL)) (DEFUN DESCRIBE-PATHNAME (PATHNAME) (IF (TYPEP PATHNAME 'PATHNAME) (DESCRIBE-PATHNAME-1 PATHNAME) (SETQ PATHNAME (PARSE-PATHNAME PATHNAME)) (LOCAL-DECLARE ((SPECIAL *HOST* *DEVICE* *DIRECTORY* *NAME* *TYPE* *VERSION*)) (LET ((*HOST* (PATHNAME-HOST PATHNAME)) (*DEVICE* (PATHNAME-DEVICE PATHNAME)) (*DIRECTORY* (PATHNAME-DIRECTORY PATHNAME)) (*NAME* (PATHNAME-NAME PATHNAME)) (*TYPE* (PATHNAME-TYPE PATHNAME)) (*VERSION* (PATHNAME-VERSION PATHNAME))) (MAPHASH-EQUAL #'(LAMBDA (KEY VAL) (AND (OR (NULL *HOST*) (EQ *HOST* (FIRST KEY))) (OR (NULL *DEVICE*) (EQUAL *DEVICE* (SECOND KEY))) (OR (NULL *DIRECTORY*) (EQUAL *DIRECTORY* (THIRD KEY))) (OR (NULL *NAME*) (EQUAL *NAME* (FOURTH KEY))) (OR (NULL *TYPE*) (EQUAL *TYPE* (FIFTH KEY))) (OR (NULL *VERSION*) (EQUAL *VERSION* (SIXTH KEY))) (DESCRIBE-PATHNAME-1 VAL))) *PATHNAME-HASH-TABLE*))))) (DEFUN DESCRIBE-PATHNAME-1 (PATHNAME &AUX PLIST) (AND (SETQ PLIST (PATHNAME-PROPERTY-LIST PATHNAME)) (LET ((LOADED-IDS (GET (LOCF PLIST) ':FILE-ID-PACKAGE-ALIST))) (AND LOADED-IDS (DO ((LOADED-IDS LOADED-IDS (CDR LOADED-IDS)) (FIRST-P T NIL) (INFO) (TRUENAME) (CREATION-DATE)) ((NULL LOADED-IDS)) (SETQ INFO (CADAR LOADED-IDS) TRUENAME (CAR INFO) CREATION-DATE (CDR INFO)) (FORMAT T "~&The version ~:[~*~;of ~A ~]in package ~A ~:[is ~A, and ~;~*~]~ was created ~\TIME\~%" FIRST-P PATHNAME (CAAR LOADED-IDS) (EQ PATHNAME TRUENAME) TRUENAME CREATION-DATE))) (DO ((PLIST PLIST (CDDR PLIST)) (FLAG NIL) (IND) (PROP)) ((NULL PLIST)) (SETQ IND (CAR PLIST) PROP (CADR PLIST)) (COND ((NEQ IND ':FILE-ID-PACKAGE-ALIST) (COND ((NULL FLAG) (FORMAT T "~&~A has the following ~:[other ~]properties:~%" PATHNAME (NULL LOADED-IDS)) (SETQ FLAG T))) (FORMAT T "~&~7X~S:~27T~S~%" IND PROP))))))) (DEFUN PATHNAME-PLIST (PATHNAME) (PATHNAME-PROPERTY-LIST (MERGE-PATHNAME-DEFAULTS PATHNAME))) (DEFUN INIT-FILE-PATHNAME (PROGRAM-NAME &OPTIONAL (HOST USER-LOGIN-MACHINE) FORCE-P) (FUNCALL (USER-HOMEDIR HOST FORCE-P) ':INIT-FILE (STRING PROGRAM-NAME))) (DEFMETHOD (PATHNAME :TRUENAME) (&OPTIONAL (ERROR-P T)) (WITH-OPEN-FILE (STREAM SELF '(:PROBE)) (IF (STRINGP STREAM) (AND ERROR-P (FILE-PROCESS-ERROR STREAM SELF NIL)) (FUNCALL STREAM ':TRUENAME)))) ;;; This isn't implemented as a separate file subprotocol, just use the directory ;;; This has bugs on the ITS file server, where non-existent file returns an ;;; empty list for the directory, and non-existent directory comes back as an ;;; asynchronous mark rather than a command error and hence is not subject to ERROR-P. ;;; Maybe someone will fix these someday. (DEFMETHOD (PATHNAME :PROPERTIES) (ERROR-P) (LET ((DIR (FUNCALL-SELF ':DIRECTORY-LIST '(:NOERROR :DELETED)))) (COND ((LISTP DIR) (VALUES (CADR DIR) (GET (CAR DIR) ':SETTABLE-PROPERTIES))) ((NOT ERROR-P) DIR) (T (FILE-PROCESS-ERROR DIR SELF NIL))))) (DEFVAR *PATHNAME-HOST-LIST* NIL) (DEFUN GET-PATHNAME-HOST (HOST-NAME) (COND ((AND (TYPEP HOST-NAME 'SI:BASIC-HOST) (MEMQ HOST-NAME *PATHNAME-HOST-LIST*)) HOST-NAME) (T (LOOP FOR HOST IN *PATHNAME-HOST-LIST* WHEN (FUNCALL HOST ':PATHNAME-HOST-NAMEP HOST-NAME) RETURN HOST)))) ;;; These are the defaults you get if you don't get anything else. (DEFVAR *DEFAULT-PATHNAME-DEFAULTS*) ;;; This is a user variable, it says whether defaults are maintained on a per-host basis, or ;;; one default for all hosts. (DEFVAR *DEFAULTS-ARE-PER-HOST* NIL) ;;; Returns an alist that you can pass to the functions below that take a set of defaults. (DEFUN MAKE-PATHNAME-DEFAULTS (&AUX LIST) (SETQ LIST (MAKE-LIST NIL (1+ (LENGTH *PATHNAME-HOST-LIST*)))) (DO ((L2 LIST (CDR L2)) (L1 *PATHNAME-HOST-LIST* (CDR L1))) ((NULL L2)) (SETF (CAR L2) (NCONS (CAR L1)))) LIST) (DEFUN COPY-PATHNAME-DEFAULTS (DEFAULTS) (COPYALIST DEFAULTS)) ;;; Returns the default for the given host from defaults. ;;; INTERNAL-P means this function is being called from inside the parsing function and ;;; cannot do any parsing itself, but must just return something to accept messages. ;;; DEFAULTS can also be an atom, which is used as a default. (DEFUN DEFAULT-PATHNAME (&OPTIONAL DEFAULTS HOST DEFAULT-TYPE DEFAULT-VERSION INTERNAL-P &AUX ELEM PATHNAME HOST-TO-USE) (OR DEFAULTS (SETQ DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)) (AND HOST (SETQ HOST (GET-PATHNAME-HOST HOST))) (COND ((NLISTP DEFAULTS) (SETQ PATHNAME (PARSE-PATHNAME DEFAULTS))) (T (SETQ ELEM (COND ((NOT *DEFAULTS-ARE-PER-HOST*) (ASSQ NIL DEFAULTS)) (HOST (ASSQ HOST DEFAULTS)) (T (DOLIST (DEFAULT DEFAULTS) ;Last host mentioned (AND (CDR DEFAULT) (RETURN DEFAULT)))))) ;; If none better found, take the one for the login machine (OR (CDR ELEM) (SETQ ELEM (OR (ASSQ USER-LOGIN-MACHINE DEFAULTS) (NCONS USER-LOGIN-MACHINE)))) ;; If there isn't one already, build a pathname from the host of this one (SETQ HOST-TO-USE (OR HOST (CAR ELEM) (PATHNAME-HOST (CDR ELEM)))) (COND ((SETQ PATHNAME (CDR ELEM))) (INTERNAL-P (SETQ PATHNAME (MAKE-PATHNAME-INTERNAL HOST-TO-USE NIL NIL NIL NIL NIL))) (T (SETQ PATHNAME (FUNCALL (USER-HOMEDIR HOST-TO-USE) ':NEW-PATHNAME ':NAME "FOO" ':TYPE "LISP" ':VERSION ':NEWEST)) (SETF (CDR ELEM) PATHNAME))))) ;; If default-type or default-version was given, or the host has changed, ;; merge those in. (AND (OR (AND HOST (NEQ HOST (PATHNAME-HOST PATHNAME))) DEFAULT-TYPE DEFAULT-VERSION) (IF INTERNAL-P (AND HOST (SETQ PATHNAME (MAKE-PATHNAME-INTERNAL HOST NIL NIL NIL NIL NIL))) (SETQ PATHNAME (FUNCALL PATHNAME ':NEW-PATHNAME ':HOST (OR HOST (PATHNAME-HOST PATHNAME)) ':TYPE (OR DEFAULT-TYPE (PATHNAME-TYPE PATHNAME)) ':VERSION (OR DEFAULT-VERSION (PATHNAME-VERSION PATHNAME)) )))) PATHNAME) ;;; Sets the default for either the host of the pathname or the NIL default. (DEFUN SET-DEFAULT-PATHNAME (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) &AUX ELEM) (SETQ PATHNAME (PARSE-PATHNAME PATHNAME NIL DEFAULTS)) (OR (SETQ ELEM (ASSQ (PATHNAME-HOST PATHNAME) DEFAULTS)) (SETQ ELEM (NCONS (PATHNAME-HOST PATHNAME)))) (SETF (CDR ELEM) PATHNAME) (PULL ELEM DEFAULTS) ;This is the default host (AND (NOT *DEFAULTS-ARE-PER-HOST*) (SETQ ELEM (ASSQ NIL DEFAULTS)) (SETF (CDR ELEM) PATHNAME)) PATHNAME) ;;; Move ITEM to the front of LIST destructively (DEFUN PULL (ITEM LIST) (DO ((LS LIST (CDR LS)) (IT ITEM)) ((NULL LS) (SETQ LIST (NCONC LIST (NCONS IT)))) (SETF (CAR LS) (PROG1 IT (SETQ IT (CAR LS)))) (AND (EQ ITEM IT) (RETURN))) LIST) ;;;; ITS support ;;; An FN2 can be either a version, if it is all numbers, or a type otherwise. (DEFFLAVOR ITS-PATHNAME-MIXIN () () (:INCLUDED-FLAVORS PATHNAME)) (DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-HOST) () (FORMAT NIL "~A: ~A; ~A ~A" DEVICE (STRING-OR-WILD DIRECTORY) (ITS-FN1-STRING) (ITS-FN2-STRING))) (DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-PRINTING) () (FORMAT NIL "~A: ~:[~A;~:[ ~]~;~2*~]~@[~A~]~@[ ~A~]" (ITS-DEVICE-STRING) (MEMQ DIRECTORY '(NIL :UNSPECIFIC)) (STRING-OR-WILD DIRECTORY) (AND (MEMQ NAME '(NIL :UNSPECIFIC)) (MEMQ TYPE '(NIL :UNSPECIFIC)) (MEMQ VERSION '(NIL :UNSPECIFIC))) (ITS-FN1-STRING) (ITS-FN2-STRING))) (DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-EDITOR) () (FORMAT NIL "~A ~A ~:[~A: ~;~*~]~A; ~A:" (ITS-FN1-STRING) (ITS-FN2-STRING) (OR (MEMBER DEVICE '("DSK" NIL :UNSPECIFIC)) (EQUAL DEVICE (FUNCALL HOST ':NAME-AS-FILE-COMPUTER))) DEVICE (STRING-OR-WILD DIRECTORY) (FUNCALL HOST ':NAME-AS-FILE-COMPUTER))) (DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-DIRECTORY) () (FORMAT NIL "~:[~A: ~;~*~]~A;" (MEMBER DEVICE '("DSK" NIL :UNSPECIFIC)) DEVICE (STRING-OR-WILD DIRECTORY))) (DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-DIRED) () (FORMAT NIL "~6A ~A" (ITS-FN1-STRING T) (ITS-FN2-STRING T))) (DEFMETHOD (ITS-PATHNAME-MIXIN :FN1) () (ITS-FN1-STRING T T)) (DEFMETHOD (ITS-PATHNAME-MIXIN :FN2) () (ITS-FN2-STRING T)) ;;; If the device is DSK, avoid printing it. (DECLARE-FLAVOR-INSTANCE-VARIABLES (ITS-PATHNAME-MIXIN) (DEFUN ITS-DEVICE-STRING (&AUX HOSTS) (SETQ HOSTS (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)) (IF (OR (MEMBER DEVICE '("DSK" NIL :UNSPECIFIC)) (EQUAL DEVICE HOSTS)) HOSTS (STRING-APPEND HOSTS ": " DEVICE)))) ;;; If name is structured, its first component is the FN1 and second is FN2 ;;; If only FN2 is present, FN1 is placeholder "" (DECLARE-FLAVOR-INSTANCE-VARIABLES (ITS-PATHNAME-MIXIN) (DEFUN ITS-FN1-STRING (&OPTIONAL NO-QUOTE-P NO-PLACEHOLDER) (COND ((MEMQ NAME '(NIL :UNSPECIFIC)) (IF (OR NO-PLACEHOLDER (AND (MEMQ TYPE '(NIL :UNSPECIFIC)) (MEMQ VERSION '(NIL :UNSPECIFIC)))) NIL "")) ((LISTP NAME) (IF NO-QUOTE-P (CAR NAME) (QUOTE-COMPONENT-STRING (CAR NAME)))) (T (STRING-OR-WILD NAME NO-QUOTE-P))))) (DEFUN STRING-OR-WILD (FIELD &OPTIONAL NO-QUOTE-P) (COND ((EQ FIELD ':WILD) "*") (NO-QUOTE-P (STRING FIELD)) ((QUOTE-COMPONENT-STRING FIELD)))) (DEFUN QUOTE-COMPONENT-STRING (STRING &AUX LENGTH) (SETQ STRING (STRING STRING) LENGTH (STRING-LENGTH STRING)) (DO ((NSTRING NIL) (QUOTE-IDX 0 NQUOTE-IDX) (NQUOTE-IDX -1)) (NIL) (SETQ NQUOTE-IDX (DO ((I (1+ NQUOTE-IDX) (1+ I))) (( I LENGTH)) (AND (FUNCALL-SELF ':CHARACTER-NEEDS-QUOTING-P (AREF STRING I)) (RETURN I)))) (AND (OR NQUOTE-IDX NSTRING) (SETQ NSTRING (IF NSTRING (STRING-APPEND NSTRING (FUNCALL-SELF ':QUOTE-CHARACTER) (SUBSTRING STRING QUOTE-IDX NQUOTE-IDX)) (SUBSTRING STRING QUOTE-IDX NQUOTE-IDX)))) (OR NQUOTE-IDX (RETURN (OR NSTRING STRING))))) (DEFMETHOD (ITS-PATHNAME-MIXIN :QUOTE-CHARACTER) () #/) (DEFMETHOD (ITS-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (CH) (MEMQ CH '(#/; #/: #\SP))) (DEFVAR *ITS-UNINTERESTING-TYPES* '("LISP" "TEXT" NIL :UNSPECIFIC)) (DECLARE-FLAVOR-INSTANCE-VARIABLES (ITS-PATHNAME-MIXIN) (DEFUN ITS-FN2-STRING (&OPTIONAL NO-QUOTE-P) (COND ((AND (LISTP NAME) (CDR NAME)) (IF NO-QUOTE-P (CADR NAME) (QUOTE-COMPONENT-STRING (CADR NAME)))) ((AND (MEMQ TYPE '(NIL :UNSPECIFIC)) (MEMQ VERSION '(NIL :UNSPECIFIC))) NIL) ((EQ VERSION ':OLDEST) "<") ((OR (EQ VERSION ':UNSPECIFIC) (NOT (MEMBER TYPE *ITS-UNINTERESTING-TYPES*))) (STRING-OR-WILD TYPE NO-QUOTE-P)) ((EQ VERSION ':WILD) "*") ((NOT (MEMQ VERSION '(NIL :UNSPECIFIC :NEWEST))) (FORMAT NIL "~D" VERSION)) (T ">")))) ;;; For most components, just upcase the string (DEFMETHOD (ITS-PATHNAME-MIXIN :PARSE-COMPONENT-SPEC) (SPEC) (COND ((LISTP SPEC) (MAPCAR #'(LAMBDA (X) (FUNCALL-SELF ':PARSE-COMPONENT-SPEC X)) SPEC)) ((STRINGP SPEC) (SIX-SIXBIT-CHARACTERS SPEC)) (T SPEC))) (DEFMETHOD (ITS-PATHNAME-MIXIN :PARSE-STRUCTURED-NAME-SPEC) PATHNAME-PASS-THROUGH-SPEC) ;;; Parse an its pathname string. and are quoting characters. (DEFMETHOD (ITS-PATHNAME-MIXIN :PARSE-NAMESTRING) (HOST-SPECIFIED NAMESTRING &OPTIONAL (START 0) END) (OR END (SETQ END (STRING-LENGTH NAMESTRING))) (DO ((I START) (J START (1+ J)) (CH) (TEM) (DEV (AND HOST-SPECIFIED "DSK")) (DIR) (FN1) (FN1P) (FN2) (TYPE) (VERSION)) ((> J END) (COND ((NULL FN2)) ((SETQ TEM (NUMERIC-P FN2)) (SETQ VERSION TEM TYPE ':UNSPECIFIC)) ((EQUAL FN2 ">") (SETQ VERSION ':NEWEST TYPE ':UNSPECIFIC)) ((EQUAL FN2 "<") (SETQ VERSION ':OLDEST TYPE ':UNSPECIFIC)) ((MEMBER FN2 *ITS-UNINTERESTING-TYPES*) (SETQ TYPE FN2 VERSION ':UNSPECIFIC)) (T (SETQ TYPE FN2 VERSION ':NEWEST))) (VALUES DEV DIR FN1 TYPE VERSION)) (SETQ CH (IF (= J END) #\SP (AREF NAMESTRING J))) (COND ((MEMQ CH '(#/ #/)) (SETQ J (1+ J))) ((MEMQ CH '(#/: #/; #/ #\SP #\TAB)) (COND (( I J) (SETQ TEM (SIX-SIXBIT-CHARACTERS NAMESTRING T I J)) (SELECTQ CH (#/: (SETQ DEV TEM)) (#/; (SETQ DIR TEM)) (OTHERWISE (COND (FN2) (FN1P (SETQ FN2 TEM)) (T (SETQ FN1 TEM FN1P T))))))) (IF (EQ CH #/) (SETQ FN1P T)) (SETQ I (1+ J)))))) ;;; Truncate to six characters (DEFUN SIX-SIXBIT-CHARACTERS (STRING &OPTIONAL QUOTE-P (START 0) (END (STRING-LENGTH STRING))) (DO ((I START (1+ I)) (NCH 0) (CH) (NEED-COPY NIL)) ((OR ( I END) (= NCH 6)) (COND ((AND (= START 0) (= I (STRING-LENGTH STRING)) (NOT NEED-COPY)) STRING) ;To avoid consing ((NOT NEED-COPY) (SUBSTRING STRING START I)) (T (DO ((NSTRING (MAKE-ARRAY NCH ':TYPE 'ART-STRING)) (J 0) (K START (1+ K)) (CH)) (( K I) NSTRING) (SETQ CH (AREF STRING K)) (COND ((NOT (AND QUOTE-P (MEMQ CH '(#/ #/)))) (SETQ CH (COND ((< CH 40) (+ CH 40)) ((< CH 140) CH) (T (- CH 40)))) (ASET CH NSTRING J) (SETQ J (1+ J)))))))) (SETQ CH (AREF STRING I)) (IF (AND QUOTE-P (MEMQ CH '(#/ #/))) (SETQ NEED-COPY T) (SETQ NCH (1+ NCH))) (OR (AND ( CH #\SP) ( CH #/_)) ;Already legal SIXBIT (SETQ NEED-COPY T)))) ;;; Return number if string is all digits, else NIL (DEFUN NUMERIC-P (STRING &OPTIONAL PARTIAL-OK SIGN-OK) (DO ((I 0 (1+ I)) (LEN (STRING-LENGTH STRING)) (NUM NIL) (SIGN 1) (CH)) (( I LEN) (AND NUM (* NUM SIGN))) (SETQ CH (AREF STRING I)) (COND ((AND SIGN-OK (ZEROP I) (MEMQ CH '(#/+ #/-))) (IF (EQ CH #/+) (SETQ SIGN 1) (SETQ SIGN -1))) ((AND ( #/9 CH) ( CH #/0)) (SETQ NUM (+ (- CH #/0) (IF NUM (* NUM 10.) 0)))) (PARTIAL-OK (RETURN (AND NUM (* NUM SIGN)) I)) (T (RETURN NIL))))) (DEFMETHOD (ITS-PATHNAME-MIXIN :INIT-FILE) (PROGRAM-NAME) (FUNCALL-SELF ':NEW-PATHNAME ':NAME USER-ID ':TYPE PROGRAM-NAME ':VERSION ':NEWEST)) ;;; These are for things like the microcode files that need to compact both a name and a type ;;; into one pathname. (DEFMETHOD (ITS-PATHNAME-MIXIN :NEW-TYPE-AND-VERSION) (NEW-TYPE NEW-VERSION) (FUNCALL-SELF ':NEW-PATHNAME ':TYPE (SIX-SIXBIT-CHARACTERS (FORMAT NIL "~D~A" (\ NEW-VERSION 1000.) NEW-TYPE)) ':VERSION ':NEWEST)) (DEFMETHOD (ITS-PATHNAME-MIXIN :TYPE-AND-VERSION) (&AUX TYP VERS I) (COND ((STRINGP TYPE) (MULTIPLE-VALUE (VERS I) (NUMERIC-P TYPE T)) (AND I (SETQ TYP (SUBSTRING TYPE I))) (VALUES TYP VERS)) (T (VALUES TYPE TYPE)))) ;;; Patch system interface, more kludges for only six character filenames (DEFMETHOD (ITS-PATHNAME-MIXIN :PATCH-FILE-PATHNAME) (NAM SAME-DIRECTORY-P PATOM TYP &REST ARGS) (SELECTQ TYP (:SYSTEM-DIRECTORY (FUNCALL-SELF ':NEW-PATHNAME ':NAME (IF SAME-DIRECTORY-P PATOM NAM) ':TYPE "(PDIR)" ':VERSION ':NEWEST)) (:VERSION-DIRECTORY (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~A~3*~;~*~C~C~C~]~D" SAME-DIRECTORY-P (SI:SYSTEM-SHORT-NAME NAM) (AREF PATOM 0) (AREF PATOM 1) (AREF PATOM 2) (\ (CAR ARGS) 1000.)) ':TYPE "(PDIR)" ':VERSION ':NEWEST)) (:PATCH-FILE (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~*~;~C~]~D.~D" SAME-DIRECTORY-P PATOM (\ (CAR ARGS) 100.) (\ (CADR ARGS) (IF SAME-DIRECTORY-P 100. 1000.))) ':TYPE (CADDR ARGS) ':VERSION ':NEWEST)))) ;;;; TOPS-20 support (DEFFLAVOR TOPS20-PATHNAME-MIXIN () () (:INCLUDED-FLAVORS PATHNAME)) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-HOST) () (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS)))) (FORMAT NIL "~A:~C~A~C~A.~:[~A~;~*~]~@[~A~]" (STRING-OR-WILD DEVICE) (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM) (STRING-OR-WILD NAME) (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE) (TOPS20-VERSION-STRING)))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-PRINTING) () (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS)))) (FORMAT NIL "~A:~:[~A:~;~*~]~@[~C~A~C~]~:[~A~;~*~]~:[.~A~;~*~]~@[~A~]" (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) (MEMBER DEVICE (FUNCALL-SELF ':SUPPRESSED-DEVICE-NAMES)) (STRING-OR-WILD DEVICE) (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM) (MEMQ NAME '(NIL :UNSPECIFIC)) (STRING-OR-WILD NAME) (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE) (TOPS20-VERSION-STRING)))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-EDITOR) () (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS)))) (FORMAT NIL "~:[~A~;~*~].~:[~A~;~*~]~@[~A~] ~:[~A~;~*~]:~@[~C~A~C~] ~A:" (MEMQ NAME '(NIL :UNSPECIFIC)) (STRING-OR-WILD NAME) (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE) (TOPS20-VERSION-STRING) (MEMQ DEVICE '(NIL :UNSPECIFIC)) (STRING-OR-WILD DEVICE) (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM) (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-DIRED) () (FORMAT NIL "~:[~A~;~*~].~:[~A~;~*~]~@[~A~]" (MEMQ NAME '(NIL :UNSPECIFIC)) (STRING-OR-WILD NAME) (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE) (TOPS20-VERSION-STRING))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-DIRECTORY) () (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS)))) (FORMAT NIL "~:[~A:~;~*~]~@[~C~A~C>~]" (MEMBER DEVICE (FUNCALL-SELF ':SUPPRESSED-DEVICES)) (STRING-OR-WILD DEVICE) (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM)))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (TOPS20-PATHNAME-MIXIN) (DEFUN TOPS20-DIRECTORY-NAME () (COND ((MEMQ DIRECTORY '(NIL :UNSPECIFIED)) NIL) ((NLISTP DIRECTORY) (STRING-OR-WILD DIRECTORY)) (T (FORMAT NIL "~{~A~^.~}" DIRECTORY))))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :CONVERT-TYPE-FOR-HOST) (TYPE) (STRING-OR-WILD TYPE)) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :CONVERT-TYPE-FOR-LISPM) (TYPE) TYPE) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :VERSION-DELIMITER) () #/.) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :DIRECTORY-DELIMITERS) () '((#/< . #/>))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (TOPS20-PATHNAME-MIXIN) (DEFUN TOPS20-VERSION-STRING () (AND (NOT (MEMQ VERSION '(NIL :UNSPECIFIC :NEWEST))) (FORMAT NIL "~C~D" (FUNCALL-SELF ':VERSION-DELIMITER) (SELECTQ VERSION (:OLDEST -2) (:WILD "*") (OTHERWISE VERSION)))))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-COMPONENT-SPEC) (SPEC) (COND ((LISTP SPEC) (MAPCAR #'(LAMBDA (X) (FUNCALL-SELF ':PARSE-COMPONENT-SPEC X)) SPEC)) ((STRINGP SPEC) (TOPS20-STRING-UNTIL-DELIM SPEC NIL 0 NIL T)) (T SPEC))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-STRUCTURED-DIRECTORY-SPEC) PATHNAME-PASS-THROUGH-SPEC) ;;; If spec has dots in it, then the directory is structured. (DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-DIRECTORY-SPEC) (SPEC) (IF (STRINGP SPEC) (DO ((IDX 0) (DIR NIL) (TEM) (DELIM)) (NIL) (MULTIPLE-VALUE (TEM IDX DELIM) (TOPS20-STRING-UNTIL-DELIM SPEC '(#/.) IDX NIL T)) (SETQ DIR (IF (AND (MINUSP DELIM) (NULL DIR)) TEM (NCONC DIR (NCONS TEM)))) (AND (MINUSP DELIM) (RETURN DIR))) SPEC)) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :PRIMARY-DEVICE) () "PS") (DEFMETHOD (TOPS20-PATHNAME-MIXIN :SUPPRESSED-DEVICE-NAMES) () '(NIL :UNSPECIFIC)) ;;; Parse a tops-20 pathname string. (DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-NAMESTRING) (HOST-SPECIFIED NAMESTRING &OPTIONAL (START 0) END) (OR END (SETQ END (STRING-LENGTH NAMESTRING))) (LET* ((DIR-DELIM-ALIST (FUNCALL-SELF ':DIRECTORY-DELIMITERS)) (ALL-DELIMS (NCONC (MAPCAR #'CAR DIR-DELIM-ALIST) '(#/: #/. #/; #\SP)))) (DO ((IDX (OR (STRING-SEARCH-NOT-CHAR #\SP NAMESTRING START END) END)) (TEM) (TEM1) (DELIM) (DIR-DELIM) (DEV) (DIR) (NAM) (TYP) (VERS)) (( IDX END) (VALUES (OR DEV (AND HOST-SPECIFIED (FUNCALL-SELF ':PRIMARY-DEVICE))) DIR NAM TYP VERS)) (COND ((SETQ DIR-DELIM (CDR (ASSOC (AREF NAMESTRING IDX) DIR-DELIM-ALIST))) (AND DIR (FERROR NIL "Directory occurs twice in ~A" NAMESTRING)) (SETQ IDX (1+ IDX)) (DO () (NIL) (MULTIPLE-VALUE (TEM IDX DELIM) (TOPS20-STRING-UNTIL-DELIM NAMESTRING (LIST #/. DIR-DELIM) IDX END)) (SETQ DIR (IF (AND (= DELIM DIR-DELIM) (NULL DIR)) TEM (NCONC DIR (NCONS TEM)))) (AND (= DELIM DIR-DELIM) (RETURN)))) (T (MULTIPLE-VALUE (TEM IDX DELIM) (TOPS20-STRING-UNTIL-DELIM NAMESTRING ALL-DELIMS IDX END T T)) (COND ((ASSQ DELIM DIR-DELIM-ALIST) (SETQ IDX (1- IDX))) ((AND (= DELIM #/;) VERS) ;Attribute like protection (SETQ IDX END))) (COND ((= DELIM #/:) (AND DEV (FERROR NIL "Device occurs twice in ~A" NAMESTRING)) (SETQ DEV TEM)) ((NULL NAM) (SETQ NAM TEM)) ((NULL TYP) (SETQ TYP TEM)) ((NULL VERS) (COND ((SETQ TEM1 (NUMERIC-P TEM)) (SETQ VERS TEM1)) ((STRING-EQUAL TEM "*") (SETQ VERS ':WILD)) ((STRING-EQUAL TEM "-2") (SETQ VERS ':OLDEST)) (T (FERROR NIL "Version must be numeric in ~A" NAMESTRING)))))))))) ;;; Internal parsing function, read the next atom from string to one of delims ;;; EOS-OK means it is alright to fall off the end of the string, that is treated ;;; as a delimiter and -1 is returned for the third value. (DEFUN TOPS20-STRING-UNTIL-DELIM (STRING DELIMS &OPTIONAL (START 0) END EOS-OK QUOTE-P &AUX IDX DELIM (NCH 0) (NEED-COPY NIL)) (DECLARE (RETURN-LIST SUBSTRING END DELIM)) (OR END (SETQ END (STRING-LENGTH STRING))) (DO ((I START (1+ I)) (CHAR)) (( I END) (OR EOS-OK (FERROR NIL "Illegal end of string in ~A" STRING)) (SETQ IDX END DELIM -1)) (SETQ CHAR (AREF STRING I)) (COND ((AND QUOTE-P (= CHAR #/)) ;; TOPS-20 quoting character (AND ( (SETQ I (1+ I)) END) (FERROR NIL "End of string after quote character in ~A" STRING)) (SETQ NEED-COPY T NCH (1+ NCH))) ((MEMQ CHAR DELIMS) (SETQ IDX I DELIM CHAR) (RETURN)) (T (SETQ NCH (1+ NCH)) (AND ( CHAR #/a) ( CHAR #/z) (SETQ NEED-COPY T))))) (VALUES (COND ((AND (= START 0) (= IDX (STRING-LENGTH STRING)) (NOT NEED-COPY)) STRING) ;Avoid consing ((NOT NEED-COPY) (SUBSTRING STRING START IDX)) (T (DO ((SUBSTRING (MAKE-ARRAY NCH ':TYPE 'ART-STRING)) (I 0) (J START (1+ J)) (QUOTE-P NIL) (CHAR)) (( J IDX) SUBSTRING) (SETQ CHAR (AREF STRING J)) (IF (AND (NOT QUOTE-P) (= CHAR #/)) (SETQ QUOTE-P T) (IF QUOTE-P (SETQ QUOTE-P NIL) (SETQ CHAR (CHAR-UPCASE CHAR))) (ASET (LOGAND CHAR 177) SUBSTRING I) (SETQ I (1+ I)))))) (1+ IDX) DELIM)) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :QUOTE-CHARACTER) () #/) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (CH) (NOT (OR (AND ( CH #/A) ( CH #/Z)) (AND ( CH #/0) ( CH #/9)) (MEMQ CH '(#/# #/$ #/_ #/-)) ;;This isn't exactly right (MEMQ CH '(#/% #/*))))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :DIRECTORY-PATHNAME-AS-FILE) DEFAULT-DIRECTORY-PATHNAME-AS-FILE) (DECLARE-FLAVOR-INSTANCE-VARIABLES (PATHNAME) (DEFUN DEFAULT-DIRECTORY-PATHNAME-AS-FILE (IGNORE &AUX DIR NAM) (COND ((EQ DIRECTORY ':ROOT) (FERROR NIL "There is no pathname for the root as a file")) ((OR (ATOM DIRECTORY) (NULL (CDR DIRECTORY))) (SETQ DIR ':ROOT NAM (IF (LISTP DIRECTORY) (CAR DIRECTORY) DIRECTORY))) (T (LET ((LAST (LAST DIRECTORY))) (SETQ DIR (LDIFF DIRECTORY LAST) NAM (CAR LAST))))) (FUNCALL-SELF ':NEW-PATHNAME ':DIRECTORY DIR ':NAME NAM ':TYPE (FUNCALL-SELF ':DIRECTORY-FILE-TYPE)))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :DIRECTORY-FILE-TYPE) () "DIRECTORY") ;;;; Tenex support (DEFFLAVOR TENEX-PATHNAME-MIXIN () (TOPS20-PATHNAME-MIXIN)) (DEFMETHOD (TENEX-PATHNAME-MIXIN :VERSION-DELIMITER) () #/;) (DEFMETHOD (TENEX-PATHNAME-MIXIN :PRIMARY-DEVICE) () "DSK") (DEFMETHOD (TENEX-PATHNAME-MIXIN :SUPPRESSED-DEVICE-NAMES) () '(NIL :UNSPECIFIC "DSK")) (DEFMETHOD (TENEX-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (CH) (NOT (OR (AND ( CH #/A) ( CH #/Z)) (AND ( CH #/0) ( CH #/9)) (AND ( CH #/!) ( CH #/$)) (AND ( CH #/&) ( CH #/))) (MEMQ CH '(#/+ #// #/= #/-)) (AND ( CH #/[) ( CH #/^)) (MEMQ CH '(#/% #/*))))) ;;;; VMS support (DEFFLAVOR VMS-PATHNAME-MIXIN () (MEANINGFUL-ROOT-MIXIN TOPS20-PATHNAME-MIXIN) (:INCLUDED-FLAVORS PATHNAME)) ;;; ALIST of normal file types as expected by software on the LISPM, ;;; and 3-character file types expected by the VAX. (DEFVAR *VMS-FILE-TYPE-ALIST* '(("LISP" . "LSP") ("TEXT" . "TXT") ("MIDAS" . "MID") ("QFASL" . "QFS") ("PRESS" . "PRS"))) (DEFMETHOD (VMS-PATHNAME-MIXIN :VERSION-DELIMITER) () #/;) ;;; I'm not sure what the right thing is here. Maybe SYS$SYSDISK? ;;; There also needs to be some hair such that directory names are ;;; suppressed when logical names are provided with directories. ;;; Perhaps the file job should throw away the directory component ;;; if a "device" includes a directory. I'm going to have to think ;;; about this some more. --RWK (DEFMETHOD (VMS-PATHNAME-MIXIN :PRIMARY-DEVICE) () ':WILD) (DEFMETHOD (VMS-PATHNAME-MIXIN :SUPPRESSED-DEVICE-NAMES) () '(NIL :UNSPECIFIC)) ;;; Let the TOPS-20 parser do the work. Then take the ;;; result, check it against the more limited VMS constraints, and ;;; cannonicalize file types to LISPM standard file types. (DEFWRAPPER (VMS-PATHNAME-MIXIN :PARSE-NAMESTRING) (ARGLIST . BODY) `(PROGN (IF (STRING-SEARCH-CHAR #/ (NTH 1 ARGLIST)) (FERROR () "Illegal chararacter in ~A" (NTH 1 ARGLIST))) (MULTIPLE-VALUE-BIND (DEV DIR NAM TYP VRS) (PROGN ,@BODY) (VMS-DEVNAME-CHECK DEV) (VMS-DIRNAME-CHECK DIR) (IF (EQUAL DIR "000000") (SETQ DIR ':ROOT)) (VMS-FILENAME-COMPONENT-CHECK NAM 9) ;9 alphanumeric chars (VMS-FILENAME-COMPONENT-CHECK TYP 3) ;3 alphanumeric chars (VALUES DEV DIR NAM TYP VRS)))) ;;; There are no quoting characters possible, sigh. (DEFMETHOD (VMS-PATHNAME-MIXIN :QUOTE-CHAR) () ()) (DEFMETHOD (VMS-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (IGNORE) ()) (DEFMETHOD (VMS-PATHNAME-MIXIN :DIRECTORY-DELIMITERS) () '((#/[ . #/]) (#/< . #/>))) ;;; The VMS character set is absurdly limited. devname: