reduce-historical/psl-1983/20-util/pathnames.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% PathNames.SL
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        14 September 1982
% Revised:     9 February 1983
%
% DEC-20 implementation of some Common Lisp pathname functions.
%
% 9-Feb-83 Alan Snyder
%   Revise conversion to string to omit the dot if there is no type or version.
%   Revise conversion from string to interpret trailing dot as specifying
%   an empty type or version.  Change home-directory to specify PS:
%   Fix bug in make-pathname.  Convert to using fast-strings stuff.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load fast-int fast-vector fast-strings))
(BothTimes (load objects))

(when (funboundp 'string2integer)
  (de string2integer (s)
    (makestringintolispinteger s 10 1)
    ))

% The following function is an NEXPR: be sure this module is loaded at
% compile-time if you use this function in code to be compiled!

(dn make-pathname (keyword-arg-list)
  (let ((pn (make-instance 'pathname)))
    (while (not (null keyword-arg-list))
      (let ((keyword (car keyword-arg-list)))
	(setf keyword-arg-list (cdr keyword-arg-list))
	(cond (keyword-arg-list
	       (let ((value (car keyword-arg-list)))
		 (setf keyword-arg-list (cdr keyword-arg-list))
		 (selectq keyword
		   (host (=> pn set-host value))
		   (device (=> pn set-device value))
		   (directory (=> pn set-directory value))
		   (name (=> pn set-name value))
		   (type (=> pn set-type value))
		   (version (=> pn set-version value))
		   ))))))
    pn
    ))

(de pathname-host (pn)
  (=> (pathname pn) host))

(de pathname-device (pn)
  (=> (pathname pn) device))

(de pathname-directory (pn)
  (=> (pathname pn) directory))

(de pathname-name (pn)
  (=> (pathname pn) name))

(de pathname-type (pn)
  (=> (pathname pn) type))

(de pathname-version (pn)
  (=> (pathname pn) version))

(de PathnameP (x)
  (and (VectorP x) (eq (getv x 0) 'pathname)))

(de StreamP (x)
  (and (VectorP x) (object-get-handler-quietly x 'file-name)))

(de truename (x) (pathname x))

(de pathname (x)
  (cond
   ((PathnameP x) x)
   ((StringP x) (string-to-pathname x))
   ((IdP x) (string-to-pathname (id2string x)))
   ((StreamP x) (string-to-pathname (=> x file-name)))
   (t (TypeError x "PathName" "convertible to a pathname"))
   ))

(de namestring (x)
  (setf x (pathname x))
  (let ((dev (pathname-device x))
	(dir (pathname-directory x))
	(name (pathname-name x))
	(type (pathname-type x))
	(vers (pathname-version x))
	)
    (string-concat
     (if dev (string-concat (pathname-field-to-string dev) ":") "")
     (if dir (string-concat "<" (pathname-field-to-string dir) ">") "")
     (if name (pathname-field-to-string name) "")
     (if (or (not (pathname-empty-field? type))
	     (not (pathname-empty-field? vers)))
       (string-concat "." (pathname-field-to-string type)) "")
     (if (not (pathname-empty-field? vers))
       (string-concat "." (pathname-field-to-string vers)) "")
     )))

(de file-namestring (x)
  (setf x (pathname x))
  (let ((name (pathname-name x))
	(type (pathname-type x))
	(vers (pathname-version x))
	)
    (string-concat
     (if name (pathname-field-to-string name) "")
     (if type (string-concat "." (pathname-field-to-string type)) "")
     (if vers (string-concat "." (pathname-field-to-string vers)) "")
     )))

(de directory-namestring (x)
  (setf x (pathname x))
  (let ((dir (pathname-directory x))
	)
    (if dir (string-concat "<" (pathname-field-to-string dir) ">") "")
    ))

(de user-homedir-pathname ()
  (let ((pn (make-instance 'pathname))
	(user-number (Jsys1 0 0 0 0 (const jsGJINF)))
	(dir-name (MkString 100 (char space)))
	)
    (Jsys1 dir-name user-number 0 0 (const jsDIRST))
    (setf dir-name (recopystringtonull dir-name))
    (=> pn set-device "PS")
    (=> pn set-directory dir-name)
    pn
    ))

(de init-file-pathname (program-name)
  (let ((pn (user-homedir-pathname)))
    (=> pn set-name program-name)
    (=> pn set-type "INIT")
    pn
    ))

(de merge-pathname-defaults (pn defaults-pn default-type default-version)
  (setf pn (pathname pn))
  (setf defaults-pn (pathname defaults-pn))
  (setf pn (CopyVector pn))
  (if (not (=> pn host))
    (=> pn set-host (=> defaults-pn host)))
  (cond ((not (=> pn device))
	 (=> pn set-device (=> defaults-pn device))
	 (if (not (=> pn directory))
	   (=> pn set-directory (=> defaults-pn directory)))
	 ))
  (cond ((not (=> pn name))
	 (=> pn set-name (=> defaults-pn name))
	 (if (not (=> pn type)) (=> pn set-type (=> defaults-pn type)))
	 (if (not (=> pn version)) (=> pn set-version (=> defaults-pn version)))
	 ))
  (if (not (=> pn type))
    (=> pn set-type default-type))
  (if (not (=> pn version))
    (=> pn set-version default-version))
  pn
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Internal functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defflavor pathname
  ((host "LOCAL")
   (device NIL)
   (directory NIL)
   (name NIL)
   (type NIL)
   (version NIL)
   )
  ()
  gettable-instance-variables
  )

(defmethod (pathname set-host) (new-host)
  (cond ((StringP new-host) (setf host (string-upcase new-host)))
	((and (ListP new-host)
	      (not (null new-host))
	      (StringP (car new-host)))
	 (setf host (string-upcase (car new-host))))
	(t (StdError "Invalid host specified for pathname."))
	))

(defmethod (pathname set-device) (new-device)
  (cond ((StringP new-device) (setf device (string-upcase new-device)))
	((null new-device) (setf device NIL))
	((and (ListP new-device)
	      (StringP (car new-device)))
	 (setf device (string-upcase (car new-device))))
	((and (IdP new-device)
	      (or (eq new-device 'unspecific)
		  (eq new-device 'wild)))
	 (setf device new-device))
	(t (StdError "Invalid device specified for pathname."))
	))

(defmethod (pathname set-directory) (new-directory)
  (cond ((StringP new-directory) (setf directory (string-upcase new-directory)))
	((null new-directory) (setf directory NIL))
	((and (ListP new-directory)
	      (StringP (car new-directory)))
	 (setf directory (string-upcase (car new-directory))))
	((and (IdP new-directory)
	      (or (eq new-directory 'unspecific)
		  (eq new-directory 'wild)))
	 (setf directory new-directory))
	(t (StdError "Invalid directory specified for pathname."))
	))

(defmethod (pathname set-name) (new-name)
  (cond ((StringP new-name) (setf name (string-upcase new-name)))
	((null new-name) (setf name NIL))
	((and (ListP new-name)
	      (StringP (car new-name)))
	 (setf name (string-upcase (car new-name))))
	((and (IdP new-name)
	      (or (eq new-name 'unspecific)
		  (eq new-name 'wild)))
	 (setf name new-name))
	(t (StdError "Invalid name specified for pathname."))
	))

(defmethod (pathname set-type) (new-type)
  (cond ((StringP new-type) (setf type (string-upcase new-type)))
	((null new-type) (setf type NIL))
	((and (IdP new-type)
	      (or (eq new-type 'unspecific)
		  (eq new-type 'wild)))
	 (setf type new-type))
	(t (StdError "Invalid type specified for pathname."))
	))

(defmethod (pathname set-version) (new-version)
  (cond ((and (FixP new-version) (>= new-version 0))
	 (setf version new-version))
	((null new-version) (setf version NIL))
	((and (IdP new-version)
	      (or (eq new-version 'unspecific)
		  (eq new-version 'wild)
		  (eq new-version 'newest)
		  (eq new-version 'oldest)
		  ))
	 (setf version new-version))
	(t (StdError "Invalid version specified for pathname."))
	))

(de string-to-pathname (s)
  (let ((pn (make-instance 'pathname))
	(i 0)
	j
	ch
	(len (string-length s))
	(name-count 0)
	field
	)
    (while (< i len)
      (setf j (pathname-bite s i))
      (selectq
	(string-fetch s (- j 1))
	(#\: (=> pn set-device (pathname-field-from-string
				(substring s i (- j 1)))))
	(#\> (=> pn set-directory (pathname-field-from-string
				   (substring s (+ i 1) (- j 1)))))
	(#\. (setf name-count (+ name-count 1))
	     (setf field (substring s i (- j 1)))
	     (selectq
	       name-count
	       (1 (=> pn set-name (pathname-field-from-string field))
		  (if (>= j len) (=> pn set-type 'UNSPECIFIC))
		  )
	       (2 (=> pn set-type (pathname-field-from-string field))
		  (if (>= j len) (=> pn set-version 'UNSPECIFIC))
		  )
	       (3 (=> pn set-version (pathname-version-from-string field)))
	       ))
	(t (setf name-count (+ name-count 1))
	   (setf field (substring s i j))
	   (selectq
	     name-count
	     (1 (=> pn set-name (pathname-field-from-string field)))
	     (2 (=> pn set-type (pathname-field-from-string field)))
	     (3 (=> pn set-version (pathname-version-from-string field)))
	     )))
      (setf i j)
      )
    pn
    ))

(de pathname-bite (pn i)
  (let* ((len (string-length pn))
	 (ch (string-fetch pn i))
	 )
    (cond ((= ch #\<)
	   (setf i (+ i 1))
	   (while (< i len)
	     (setf ch (string-fetch pn i))
	     (setf i (+ i 1))
	     (if (= ch #\>) (exit))
	     )
	   )
	  (t
	   (while (< i len)
	     (setf ch (string-fetch pn i))
	     (setf i (+ i 1))
	     (if (= ch #\:) (exit))
	     (if (= ch #\.) (exit))
	     )))
    i
    ))

(de pathname-field-from-string (s)
  (cond ((StringP s)
	 (cond ((string-empty? s) 'UNSPECIFIC)
	       ((string= s "*") 'WILD)
	       (t s)
	       ))
	(t s)))

(de pathname-version-from-string (s)
  (cond ((StringP s)
	 (cond ((string-empty? s) NIL)
	       ((string= s "-2") 'OLDEST)
	       ((string= s "0") 'NEWEST)
	       ((string= s "*") 'WILD)
	       ((string-is-integer s) (string2integer s))
	       (t s)
	       ))
	(t s)))

(de pathname-empty-field? (x)
  (string-empty? (pathname-field-to-string x))
  )

(de pathname-field-to-string (x)
  (cond ((StringP x) x)
	((eq x 'OLDEST) "-2")
	((eq x 'NEWEST) "0")
	((eq x 'UNSPECIFIC) "")
	((eq x 'WILD) "*")
	((null x) "")
	(t (BldMsg "%w" x))))

(de string-is-integer (s)
  (for (from i 0 (string-upper-bound s))
       (always (DigitP (string-fetch s i)))
       ))