(FILECREATED " 4-Mar-86 13:58:51" {GENIE}LISP:<TRANLE.CML>CMLPATHNAME.;5 6683   

      changes to:  (MACROS MAKE-PATHNAME PROBE-FILE MERGE-PATHNAMES FILE-NAMESTRING 
			   USER-HOMEDIR-PATHNAME HOST-NAMESTRING DIRECTORY-NAMESTRING 
			   NAMESTRING PATHNAME-VERSION PATHNAME-TYPE PATHNAME-NAME 
			   PATHNAME-DIRECTORY PATHNAME-DEVICE PATHNAME-HOST)
		   (VARS CMLPATHNAMECOMS *SYSTEM-EXTENSION* *SOURCE-EXTENSION* *VERSION.CHAR* 
			 *EXTENSION.CHAR*)

      previous date: " 3-Mar-86 19:26:42" {ALADIN}LISP:<TRANLE.CML>CMLPATHNAME.;2)


(* Copyright (c) 1986 by IntelliCorp -- all rights reserved)

(PRETTYCOMPRINT CMLPATHNAMECOMS)

(RPAQQ CMLPATHNAMECOMS ((E (* * Implementation for Interlisp-D of Common Lisp PATHNAMES.))
	(INITVARS (*DEFAULT-BINARY-TYPE* "DCOM")
		  (*DEFAULT-SOURCE-TYPE* "")
		  (*DEFAULT-SYSTEM-TYPE* "SYSTEM")
		  (*EXTENSION.CHAR* ".")
		  (*VERSION.CHAR* ";"))
	(GLOBALVARS *DEFAULT-BINARY-TYPE* *DEFAULT-SOURCE-TYPE* *DEFAULT-SYSTEM-TYPE* 
		    *EXTENSION.CHAR* *VERSION.CHAR*)
	(MACROS DIRECTORY-NAMESTRING FILE-NAMESTRING HOST-NAMESTRING MAKE-PATHNAME 
		MERGE-PATHNAMES NAMESTRING PROBE-FILE PATHNAME-DEVICE PATHNAME-DIRECTORY 
		PATHNAME-HOST PATHNAME-NAME PATHNAME-TYPE PATHNAME-VERSION 
		USER-HOMEDIR-PATHNAME)))

(RPAQ? *DEFAULT-BINARY-TYPE* "DCOM")

(RPAQ? *DEFAULT-SOURCE-TYPE* "")

(RPAQ? *DEFAULT-SYSTEM-TYPE* "SYSTEM")

(RPAQ? *EXTENSION.CHAR* ".")

(RPAQ? *VERSION.CHAR* ";")
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *DEFAULT-BINARY-TYPE* *DEFAULT-SOURCE-TYPE* *DEFAULT-SYSTEM-TYPE* *EXTENSION.CHAR* 
	    *VERSION.CHAR*)
)
(DECLARE: EVAL@COMPILE 

(DEFMACRO DIRECTORY-NAMESTRING (PATHNAME)
			       "Interlisp version of DIRECTORY-NAMESTRING."
			       (BQUOTE (MKSTRING (FILENAMEFIELD (\, PATHNAME)
								(QUOTE DIRECTORY)))))

(DEFMACRO FILE-NAMESTRING (PATHNAME)
			  "Interlisp version of FILE-NAMESTRING."
			  (BQUOTE (LET ((UNPACKED-F (UNPACKFILENAME.STRING (\, PATHNAME))))
				       (DECLARE (LOCALVARS UNPACKED-F))
				       (DECLARE (GLOBALVARS *EXTENSION.CHAR* *VERSION.CHAR*))
				       (CONCAT (OR (LISTGET UNPACKED-F (QUOTE NAME))
						   "")
					       *EXTENSION.CHAR*
					       (OR (LISTGET UNPACKED-F (QUOTE EXTENSION))
						   "")
					       *VERSION.CHAR*
					       (OR (LISTGET UNPACKED-F (QUOTE VERSION))
						   "")))))

(DEFMACRO HOST-NAMESTRING (PATHNAME)
			  "Interlisp version of HOST-NAMESTRING."
			  (BQUOTE (MKSTRING (FILENAMEFIELD (\, PATHNAME)
							   (QUOTE HOST)))))

(DEFMACRO MAKE-PATHNAME (&KEY (HOST NIL HOST?)
			      (DEVICE NIL DEVICE?)
			      (DIRECTORY NIL DIRECTORY?)
			      (NAME NIL NAME?)
			      (TYPE NIL TYPE?)
			      (VERSION NIL VERSION?)
			      (DEFAULTS NIL DEFAULTS?))
	  "Interlisp version of MAKE-PATHNAME."
	  (BQUOTE
	    (PACKFILENAME.STRING
	      (\,@ (AND HOST? (BQUOTE ((QUOTE HOST)
				       (\, HOST)))))
	      (\,@ (AND DEVICE? (BQUOTE ((QUOTE DEVICE)
					 (\, DEVICE)))))
	      (\,@ (AND DIRECTORY? (BQUOTE ((QUOTE DIRECTORY)
					    (\, DIRECTORY)))))
	      (\,@ (AND NAME? (BQUOTE ((QUOTE NAME)
				       (\, NAME)))))
	      (\,@ (AND TYPE? (BQUOTE ((QUOTE EXTENSION)
				       (\, (COND
					     ((OR (STRINGP TYPE)
						  (KEYWORDP TYPE)
						  (CONSTANTEXPRESSIONP TYPE))
					       (COND
						 ((STRING-EQUAL TYPE (QUOTE :LISP))
						   *DEFAULT-SOURCE-TYPE*)
						 ((STRING-EQUAL TYPE (QUOTE :SYSTEM))
						   *DEFAULT-SYSTEM-TYPE*)
						 (T TYPE)))
					     (T (BQUOTE (LET ((EXT (\, TYPE)))
							     (DECLARE (LOCALVARS EXT))
							     (DECLARE (GLOBALVARS 
								      *DEFAULT-SOURCE-TYPE* 
								      *DEFAULT-SYSTEM-TYPE*))
							     (COND
							       ((STRING-EQUAL EXT (QUOTE :LISP))
								 *DEFAULT-SOURCE-TYPE*)
							       ((STRING-EQUAL EXT (QUOTE 
										    :SYSTEM))
								 *DEFAULT-SYSTEM-TYPE*)
							       (T EXT)))))))))))
	      (\,@ (AND VERSION? (BQUOTE
			  ((QUOTE VERSION)
			   (\, (COND
				 ((OR (STRINGP VERSION)
				      (KEYWORDP VERSION)
				      (CONSTANTEXPRESSIONP VERSION))
				   (COND
				     ((STRING-EQUAL VERSION (QUOTE :NEWEST))
				       NIL)
				     (T VERSION)))
				 (T (BQUOTE (LET ((VER (\, VERSION)))
					         (DECLARE (LOCALVARS VER))
					         (COND
						   ((STRING-EQUAL VER (QUOTE :NEWEST))
						     NIL)
						   (T VER)))))))))))
	      (\,@ (AND DEFAULTS? (BQUOTE ((QUOTE BODY)
					   (\, DEFAULTS))))))))

(DEFMACRO MERGE-PATHNAMES (PATHNAME &OPTIONAL (DEFAULTS NIL DEFAULTS?)
				    (DEFAULT-VERSION NIL DEFAULT-VERSION?))
			  "Interlisp version of MERGE-PATHNAME."
			  (BQUOTE (PACKFILENAME.STRING (QUOTE BODY)
						       (\, PATHNAME)
						       (\,@ (AND DEFAULTS?
								 (BQUOTE ((QUOTE BODY)
									  (\, DEFAULTS)))))
						       (\,@ (AND DEFAULT-VERSION?
								 (BQUOTE ((QUOTE VERSION)
									  (\, DEFAULT-VERSION)))
								 )))))

(DEFMACRO NAMESTRING (PATHNAME)
		     "Interlisp version of NAMESTRING."
		     (COND
		       ((NLISTP PATHNAME)
			 (BQUOTE (COND
				   ((STREAMP (\, PATHNAME))
				     (FULLNAME (\, PATHNAME)))
				   (T (MKSTRING (\, PATHNAME))))))
		       (T (BQUOTE (LET ((PATH (\, PATHNAME)))
				       (DECLARE (LOCALVARS PATH))
				       (COND
					 ((STREAMP PATH)
					   (FULLNAME PATH))
					 (T (MKSTRING PATH))))))))

(DEFMACRO PROBE-FILE (FILE)
		     "Interlisp version of probe-file."
		     (BQUOTE (INFILEP (\, FILE))))

(DEFMACRO PATHNAME-DEVICE (PATHNAME)
			  "Interlisp version of PATHNAME-DEVICE."
			  (BQUOTE (FILENAMEFIELD (\, PATHNAME)
						 (QUOTE DEVICE))))

(DEFMACRO PATHNAME-DIRECTORY (PATHNAME)
			     "Interlisp version of PATHNAME-DIRECTORY."
			     (BQUOTE (FILENAMEFIELD (\, PATHNAME)
						    (QUOTE DIRECTORY))))

(DEFMACRO PATHNAME-HOST (PATHNAME)
			"Interlisp version of PATHNAME-HOST."
			(BQUOTE (FILENAMEFIELD (\, PATHNAME)
					       (QUOTE HOST))))

(DEFMACRO PATHNAME-NAME (PATHNAME)
			"Interlisp version of PATHNAME-NAME."
			(BQUOTE (FILENAMEFIELD (\, PATHNAME)
					       (QUOTE NAME))))

(DEFMACRO PATHNAME-TYPE (PATHNAME)
			"Interlisp version of PATHNAME-TYPE."
			(BQUOTE (FILENAMEFIELD (\, PATHNAME)
					       (QUOTE EXTENSION))))

(DEFMACRO PATHNAME-VERSION (PATHNAME)
			   "Interlisp version of PATHNAME-VERSION."
			   (BQUOTE (FILENAMEFIELD (\, PATHNAME)
						  (QUOTE VERSION))))

(DEFMACRO USER-HOMEDIR-PATHNAME (&OPTIONAL HOST)
				"Interlisp version of USER-HOMEDIR-PATHNAME."
				(QUOTE LOGINHOST/DIR))
)
(PUTPROPS CMLPATHNAME COPYRIGHT ("IntelliCorp" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL)))
STOP