Artifact ef4b07b918a253cec445c51206ccb7b821c2e63c853d689d5a5f27b63e0d692c:

• File psl-1983/util/pathnamex.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 1903) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% PathNameX.SL - Useful Functions involving Pathnames
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        27 September 1982
% Revised:     4 February 1983
%
% 4-Feb-83 Alan Snyder
%  Added pathname-without-name function.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(BothTimes (load pathnames))

(de pathname-without-name (pn)
  % Return a pathname like PN but with no NAME, TYPE, or VERSION.

  (setf pn (pathname pn))
  (make-pathname 'host (pathname-host pn)
		 'device (pathname-device pn)
		 'directory (pathname-directory pn)
		 ))

(de pathname-without-type (pn)
  % Return a pathname like PN but with no TYPE or VERSION.

  (setf pn (pathname pn))
  (make-pathname 'host (pathname-host pn)
		 'device (pathname-device pn)
		 'directory (pathname-directory pn)
		 'name (pathname-name pn)
		 ))

(de pathname-without-version (pn)
  % Return a pathname like PN but with no VERSION.

  (setf pn (pathname pn))
  (make-pathname 'host (pathname-host pn)
		 'device (pathname-device pn)
		 'directory (pathname-directory pn)
		 'name (pathname-name pn)
		 'type (pathname-type pn)
		 ))

(de pathname-set-default-type (pn typ)
  % Return a pathname like PN, except that if PN specifies no TYPE,
  % then with type TYP and no version.

  (setf pn (pathname pn))
  (cond ((not (pathname-type pn))
	 (make-pathname 'host (pathname-host pn)
			'device (pathname-device pn)
			'directory (pathname-directory pn)
			'name (pathname-name pn)
			'type typ
			))
	(t pn)))

(de pathname-set-type (pn typ)
  % Return a pathname like PN, except with type TYP and no version.

  (setf pn (pathname pn))
  (make-pathname 'host (pathname-host pn)
		 'device (pathname-device pn)
		 'directory (pathname-directory pn)
		 'name (pathname-name pn)
		 'type typ
		 ))