Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Ugly pathname functions for Spice Lisp.
;;;    these functions are part of the standard Spice Lisp environment.
;;;
;;; Written by Jim Large
;;;
;;; **********************************************************************

(in-package 'lisp)

(export '(pathname *default-pathname-defaults* parse-namestring merge-pathnames
	  make-pathname pathname-host pathname-device pathname-directory
	  pathname-name pathname-type pathname-version file-namestring
	  directory-namestring host-namestring enough-namestring
	  open close))

;;; Pathname structure

;;; *Default-Pathname-defaults* has all values unspecified except for the
;;;  host.  All pathnames must have a host.  "DEFAULT" is the default device
;;;  for spice.

;;; The pathname type is defined with a defstruct.
;;; This declaration implicitly defines the common lisp functions
;;; pathname-host, pathname-device ... pathname-version.

(defstruct (pathname
	    (:conc-name %pathname-)
	    (:print-function %print-pathname)
	    (:constructor
	     %make-pathname (host device directory name type version))
	    (:predicate pathnamep))
  host
  device
  directory
  name
  type
  version)

(defun %print-pathname (s stream d)
  (declare (ignore d))
  (format stream "#.(pathname ~S)" (namestring s)))

(defun make-pathname (&key (defaults *make-pathname-default-pathname*)
			   (host (%pathname-host defaults))
			   (device (%pathname-device defaults))
			   (directory (%pathname-directory defaults))
			   (name (%pathname-name defaults))
			   (type (%pathname-type defaults))
			   (version (%pathname-version defaults)))
  "Create a pathname from :host, :device, :directory, :name, :type and
  :version.  If any field is ommitted, it is obtained from :defaults as
  though by merge-pathname-defaults."
  (%make-pathname host device directory name type version))

(defvar *default-pathname-defaults* (%make-pathname nil nil nil nil nil nil)
  "This is the default pathname-defaults pathname; if any pathname primitive
  that needs a set of defaults is not given one, it uses this one.  As a
  general rule, however, each program should have its own pathname defaults
  rather than using this one.")
(defvar *make-pathname-default-pathname* *default-pathname-defaults*)

;;; These can not be done by the accessors because the pathname arg may be
;;;  a string or a symbol or etc.

(defun pathname-host (pathname)
  "Returns the host slot of pathname.  Pathname may be a string, symbol,
  or stream."
  (setq pathname (pathname pathname))
  (%pathname-host pathname))

(defun pathname-device (pathname)
  "Returns the device slot of pathname.  Pathname may be a string, symbol,
  or stream."
  (setq pathname (pathname pathname))
  (%pathname-device pathname))

(defun pathname-directory (pathname)
  "Returns the directory slot of pathname.  Pathname may be a string, symbol,
  or stream."
  (setq pathname (pathname pathname))
  (%pathname-directory pathname))

(defun pathname-name (pathname)
  "Returns the name slot of pathname.  Pathname may be a string, symbol,
  or stream."
  (setq pathname (pathname pathname))
  (%pathname-name pathname))

(defun pathname-type (pathname)
  "Returns the type slot of pathname.  Pathname may be a string, symbol,
  or stream."
  (setq pathname (pathname pathname))
  (%pathname-type pathname))

(defun pathname-version (pathname)
  "Returns the version slot of pathname.  Pathname may be a string, symbol,
  or stream."
  (setq pathname (pathname pathname))
  (%pathname-version pathname))

;;; Parse-Namestring  --  Public
;;;
;;;    Just lex the thing and flame out if it can't be done. 
;;;
(defun parse-namestring (thing &optional host 
			       (defaults *default-pathname-defaults*)
			       &key (start 0) end (junk-allowed nil))
  (declare (ignore host defaults))
  "Parses a string representation of a pathname into a pathname.  For
  details on the other silly arguments see the manual."
  (%sp-parse-namestring thing start end junk-allowed))


;;; Pathname  --  Public
;;;
;;;    Call parse-namestring, doo dah, doo dah...
;;;
(defun pathname (thing)
  "Turns Thing into a pathname.  Thing may be a string, symbol, stream,
  or pathname."
  (values (parse-namestring thing)))

;;; Merge-Pathnames  --  Public
;;;
;;; Returns a new pathname whose fields are the same as the fields in PATHNAME
;;;  except that () fields are filled in from defaults.  Type and Version field
;;;  are only done if name field has to be done (see manual for explanation).
;;;
(defun merge-pathnames (pathname &optional
				 (defaults *default-pathname-defaults*)
				 (default-version :newest))
  "Fills in unspecified slots of Pathname from Defaults (defaults to
  *default-pathname-defaults*).  If the version remains unspecified,
  gets it from Default-Version."
  ;;
  ;; finish hairy argument defaulting
  (setq pathname (pathname pathname))
  (setq defaults (pathname defaults))
  ;;
  ;; make a new pathname
  (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)))
;;the following is intended to avoid getting a default device from
;; the wrong host.  It is activated only if the pathname has an
;; explicit host spec.
    (if (and host (null device))
	(if (and (%pathname-host defaults)
		 (string-equal host (%pathname-host defaults)))
	    (setq device (%pathname-device defaults))
	    (setq device "DSK")))
    (if (null name)
	(if (null version) (setq version (%pathname-version defaults)))
	(if (null version) (setq version default-version)))
    (%make-pathname
     (or host (%pathname-host defaults))
     (or device (%pathname-device defaults))
     (or directory (%pathname-directory defaults))
     (or name (%pathname-name defaults))
     (or type (%pathname-type defaults))
     version)))

;;; Namestring & Friends

(defun file-namestring (pathname)
  "Returns the name, type, and version of PATHNAME as a string."
;there is a certain amount of magic involved in converting
;keywords into strings, so it is safest to make up a full
;pathname and then let namestring do the conversion
  (setq pathname (pathname pathname))
  (setq pathname (%make-pathname nil nil nil
				 (%pathname-name pathname)
				 (%pathname-type pathname)
				 (%pathname-version pathname)))
  (namestring pathname))

(defun directory-namestring (pathname)
  "Returns the device & directory parts of PATHNAME as a string."
;there is a certain amount of magic involved in converting
;keywords into strings, so it is safest to make up a full
;pathname and then let namestring do the conversion
  (setq pathname (pathname pathname))
  (setq pathname (%make-pathname nil 
				 (%pathname-device pathname)
				 (%pathname-directory pathname)
				 nil nil nil))
  (namestring pathname))

(defun host-namestring (pathname)
  "Returns the host part of PATHNAME as a string."
  (setq pathname (pathname pathname))
  (%pathname-host pathname))

;;; Enough-Namestring

(defun enough-namestring (pathname &optional
				   (defaults *default-pathname-defaults*))
  "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS." 
  (setq pathname (pathname pathname))
  (setq defaults (pathname defaults))
  (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)))
    (when (and host (path-equal host (%pathname-host defaults)))
      (setq host nil))
;note that we have to add the condition (null host), because
;merge-pathnames will not use a default device if the filespec
;includes an explicit host that is different from the default host
    (when (and device (null host)
	       (path-equal device (%pathname-device defaults)))
      (setq device nil))
    (when (and directory
	       (path-equal directory (%pathname-directory defaults)))
      (setq directory nil))
    (when (and name (path-equal name (%pathname-name defaults)))
      (setq name nil))
    (when (and type (path-equal type (%pathname-type defaults)))
      (setq type nil))
;we have to include the not name here because merge-pathnames will
;not use the default version if there is an explicit name
    (when (and version (not name)
               (version-equal version (%pathname-version defaults)))
      (setq version nil))
;unfortunately a..3 always specifies that the type is null.  There is
;no way to leave the type unspecified and also show the version.  So
;we supply the original type in this case.
    (when (and version (not type))
      (setq type (%pathname-type pathname)))
    (namestring (%make-pathname host device directory name type version))))

(defun path-equal (x y)
  (if (eq x :wild) (setq x "*"))
  (if (eq y :wild) (setq y "*"))
  (cond ((and (stringp x) (stringp y))
	 (string-equal x y))
	(t (eq x y))))

(defun version-equal (x y)
  (if (equal x "*") (setq x -3))
  (if (equal y "*") (setq y -3))
  (if (eq x :newest) (setq x 0))
  (if (eq y :newest) (setq y 0))
  (if (eq x :new-version) (setq x -1))
  (if (eq y :new-version) (setq y -1))
  (if (eq x :oldest) (setq x -2))
  (if (eq y :oldest) (setq y -2))
  (if (eq x :wild) (setq x -3))
  (if (eq y :wild) (setq y -3))
  (eq x y))

(defun set-terminal-modes (term &rest modes)
   (if (eq (length modes) 1)
       (%sp-set-terminal-modes term (car modes))
       (%sp-set-terminal-modes term modes)))

(defun open (filename &key (direction :input) (element-type 'string-char)
			  (if-exists :new-version)
			  (if-does-not-exist 
				(cond ((eq direction :probe) nil)
				      ((or (eq direction :input)
					   (memq if-exists
						'(:overwrite :append)))
				        :error)
				      (t :create))))
  "Return a stream which reads from or writes to Filename.
  Defined  keywords:
   :direction - one of :input, :output or :probe
   :element-type - Type of object to read or write, default String-Char
   :if-exists - one of :error, :new-version, :overwrite, :append or nil
   :if-does-not-exist - one of :error, :create or nil
  See the manual for details."
  (%sp-open filename direction (if (memq direction '(:input :probe))
				   :default
				   if-exists)
			       if-does-not-exist element-type))

(defun close (stream &key abort)
  "Closes the given stream.  No more I/O may be preformed, but inquiries
  may still be made.  If :Abort is non-nil, an attempt is made to clean
  up the side effects of having created the stream."
   (%sp-close stream (if abort #o4000 0)))