;;; -*- Mode: Lisp; Package: DSYS; Base: 10; Syntax: Common-Lisp -*-
;;; File: system.lisp 
;;; Author: Richard Harris

(in-package :user)

#+excl
(eval-when (compile load eval)
  (when (eq (find-package :lisp) (find-package :common-lisp))
    (let ((excl::*enable-package-locked-errors* nil))
      (rename-package :common-lisp :common-lisp '(:cl)))
    (make-package :lisp :use nil)
    ((lambda (symbols)
       (import symbols :lisp)
       (export symbols :lisp))
     '(&allow-other-keys &aux &body &environment &key &optional &rest &whole
       * ** *** *applyhook* *break-on-warnings* *debug-io*
       *default-pathname-defaults* *error-output* *evalhook* *features*
       *load-verbose* *macroexpand-hook* *modules* *package* *print-array*
       *print-base* *print-case* *print-circle* *print-escape*
       *print-gensym* *print-length* *print-level* *print-pretty*
       *print-radix* *query-io* *random-state* *read-base*
       *read-default-float-format* *read-suppress* *readtable*
       *standard-input* *standard-output* *terminal-io* *trace-output* +
       ++ +++ - / // /// /= 1+ 1- < <= = > >= abs acons acos acosh adjoin
       adjust-array adjustable-array-p akcl alpha-char-p alphanumericp and
       append apply applyhook apropos apropos-list aref array
       array-dimension array-dimension-limit array-dimensions
       array-element-type array-has-fill-pointer-p array-in-bounds-p
       array-rank array-rank-limit array-row-major-index array-total-size
       array-total-size-limit arrayp ash asin asinh assert assoc assoc-if
       assoc-if-not atan atanh atom bignum bit bit-and bit-andc1 bit-andc2
       bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2
       bit-vector bit-vector-p bit-xor block boole boole-1 boole-2
       boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr
       boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2
       boole-set boole-xor both-case-p boundp break butlast byte
       byte-position byte-size caaaar caaadr caaar caadar caaddr caadr
       caar cadaar cadadr cadar caddar cadddr caddr cadr
       call-arguments-limit car case catch ccase cdaaar cdaadr cdaar
       cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr
       cddr cdr ceiling cerror char char-bit char-bits char-bits-limit
       char-code char-code-limit char-control-bit char-downcase char-equal
       char-font char-font-limit char-greaterp char-hyper-bit char-int
       char-lessp char-meta-bit char-name char-not-equal char-not-greaterp
       char-not-lessp char-super-bit char-upcase char/= char< char<= char=
       char> char>= character characterp check-type cis clear-input
       clear-output close clrhash code-char coerce common commonp
       compilation-speed compile compile-file compiled-function
       compiled-function-p compiler-let complex complexp concatenate cond
       conjugate cons consp constantp copy-alist copy-list copy-readtable
       copy-seq copy-symbol copy-tree cos cosh count count-if count-if-not
       ctypecase decf declaration declare decode-float
       decode-universal-time defconstant define-modify-macro
       define-setf-method defmacro defparameter defsetf defstruct deftype
       defun defvar delete delete-duplicates delete-file delete-if
       delete-if-not denominator deposit-field describe digit-char
       digit-char-p directory directory-namestring disassemble do do*
       do-all-symbols do-external-symbols do-symbols documentation dolist
       dotimes double-float double-float-epsilon
       double-float-negative-epsilon dpb dribble ecase ed eighth elt
       encode-universal-time endp enough-namestring eq eql equal equalp
       error etypecase eval eval-when evalhook evenp every exp export expt
       fboundp fceiling ffloor fifth file-author file-length
       file-namestring file-position file-write-date fill fill-pointer
       find find-all-symbols find-if find-if-not find-package find-symbol
       finish-output first fixnum flet float float-digits float-precision
       float-radix float-sign floatp floor fmakunbound force-output format
       fourth fresh-line fround ftruncate ftype funcall function functionp
       gcd gensym gentemp get get-decoded-time
       get-dispatch-macro-character get-internal-real-time
       get-internal-run-time get-macro-character get-output-stream-string
       get-properties get-setf-method get-setf-method-multiple-value
       get-universal-time getf gethash gfun go graphic-char-p hash-table
       hash-table-count hash-table-p host-namestring identity if ignore
       imagpart import in-package incf inline input-stream-p inspect
       int-char integer integer-decode-float integer-length integerp
       intern internal-time-units-per-second intersection isqrt keyword
       keywordp labels lambda lambda-list-keywords lambda-parameters-limit
       last lcm ldb ldb-test ldiff least-negative-double-float
       least-negative-long-float least-negative-short-float
       least-negative-single-float least-positive-double-float
       least-positive-long-float least-positive-short-float
       least-positive-single-float length let let*
       lisp-implementation-type lisp-implementation-version list list*
       list-all-packages list-length listen listp load locally log logand
       logandc1 logandc2 logbitp logcount logeqv logior lognand lognor
       lognot logorc1 logorc2 logtest logxor long-float long-float-epsilon
       long-float-negative-epsilon long-site-name loop lower-case-p
       machine-instance machine-type machine-version macro-function
       macroexpand macroexpand-1 macrolet make-array make-broadcast-stream
       make-char make-concatenated-stream make-dispatch-macro-character
       make-echo-stream make-hash-table make-list make-package
       make-pathname make-random-state make-sequence make-string
       make-string-input-stream make-string-output-stream make-symbol
       make-synonym-stream make-two-way-stream makunbound map mapc mapcan
       mapcar mapcon maphash mapl maplist mask-field max member member-if
       member-if-not merge merge-pathnames min minusp mips mismatch mod
       most-negative-double-float most-negative-fixnum
       most-negative-long-float most-negative-short-float
       most-negative-single-float most-positive-double-float
       most-positive-fixnum most-positive-long-float
       most-positive-short-float most-positive-single-float
       multiple-value-bind multiple-value-call multiple-value-list
       multiple-value-prog1 multiple-value-setq multiple-values-limit
       name-char namestring nbutlast nconc nil nintersection ninth not
       notany notevery notinline nreconc nreverse nset-difference
       nset-exclusive-or nstring-capitalize nstring-downcase
       nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute
       nsubstitute-if nsubstitute-if-not nth nthcdr null number numberp
       numerator nunion oddp open optimize or otherwise output-stream-p
       package package-name package-nicknames package-shadowing-symbols
       package-use-list package-used-by-list packagep pairlis
       parse-integer parse-namestring pathname pathname-device
       pathname-directory pathname-host pathname-name pathname-type
       pathname-version pathnamep peek-char phase pi plusp pop position
       position-if position-if-not pprint prin1 prin1-to-string princ
       princ-to-string print probe-file proclaim prog prog* prog1 prog2
       progn progv provide psetf psetq push pushnew quote random
       random-state random-state-p rassoc rassoc-if rassoc-if-not ratio
       rational rationalize rationalp read read-byte read-char
       read-char-no-hang read-delimited-list read-from-string read-line
       read-preserving-whitespace readtable readtablep realpart reduce rem
       remf remhash remove remove-duplicates remove-if remove-if-not
       remprop rename-file rename-package replace require rest return
       return-from revappend reverse room rotatef round rplaca rplacd
       safety satisfies sbit scale-float schar search second sequence set
       set-char-bit set-difference set-dispatch-macro-character
       set-exclusive-or set-macro-character set-syntax-from-char setf setq
       seventh sfun shadow shadowing-import shiftf short-float
       short-float-epsilon short-float-negative-epsilon short-site-name
       signed-byte signum simple-array simple-bit-vector
       simple-bit-vector-p simple-string simple-string-p simple-vector
       simple-vector-p sin single-float single-float-epsilon
       single-float-negative-epsilon sinh sixth sleep software-type
       software-version some sort space special special-form-p speed sqrt
       stable-sort standard-char standard-char-p step stream
       stream-element-type streamp string string-capitalize string-char
       string-char-p string-downcase string-equal string-greaterp
       string-left-trim string-lessp string-not-equal string-not-greaterp
       string-not-lessp string-right-trim string-trim string-upcase
       string/= string< string<= string= string> string>= stringp
       structure sublis subseq subsetp subst subst-if subst-if-not
       substitute substitute-if substitute-if-not subtypep svref sxhash
       symbol symbol-function symbol-name symbol-package symbol-plist
       symbol-value symbolp t tagbody tailp tan tanh tenth terpri the
       third throw time trace tree-equal truename truncate type type-of
       typecase typep unexport unintern union unless unread-char
       unsigned-byte untrace unuse-package unwind-protect upper-case-p
       use-package user-homedir-pathname values values-list variable
       vector vector-pop vector-push vector-push-extend vectorp warn when
       with-input-from-string with-open-file with-open-stream
       with-output-to-string write write-byte write-char write-line
       write-string write-to-string y-or-n-p yes-or-no-p zerop))))

(in-package :walker :use '(:lisp))
(in-package :iterate :use '(:lisp :walker))
(export '(iterate))
(in-package :pcl :use '(:walker :iterate :lisp))
(in-package :dsys :use '(:lisp))

#+cmu
(eval-when (compile load eval)
  (let ((vs (lisp-implementation-version)))
    (cond ((and (<= 2 (length vs))
		(eql #\1 (aref vs 0))
		(let ((d (digit-char-p (aref vs 1))))
		  (and d (<= 6 d))))
	   (pushnew :cmu16 *features*))
	  ((string= "8-Dec-1992" vs)
	   (pushnew :cmu16 *features*)
	   (pushnew :cmu17 *features*)
	   (pushnew :cmu17a *features*)
	   (when (fboundp 'pcl::original-defstruct)
	     (setf (macro-function 'defstruct)
		   (macro-function 'pcl::original-defstruct))))
	  (t
	   (warn "assuming this is cmucl 15")))))

#-cmu16
(shadow '(#+(or lucid kcl excl :coral cmu) lisp:merge-pathnames
	  lisp:make-pathname 
	  lisp:pathname-host lisp:pathname-device lisp:pathname-directory
	  lisp:pathname-name lisp:pathname-type lisp:pathname-version
	  #+cmu lisp:directory
	  #+excl lisp:enough-namestring))

#+cmu16
(shadow '(lisp:directory lisp:enough-namestring lisp:make-pathname))

#+lucid
(import '(lcl:def-foreign-synonym-type lcl:def-foreign-struct
	  lcl:def-foreign-function lcl:load-foreign-libraries
	  lcl:malloc-foreign-pointer lcl:free-foreign-pointer
	  lcl:foreign-string-value lcl:foreign-pointer-type))

#+(and cmu (not cmu17a))
(import '(lisp::purify))

(import '(user::*initialize-systems-p*
	  user::initialize-systems
	  user::*choose-source-or-object-file-action*
	  pcl::*default-pathname-extensions*
	  pcl::*pathname-extensions*))

(export '(*dsys-shadowing-import-symbols*
	  directoryp create-directory ensure-directory
	  pathname-as-directory directory-pathname-as-file
	  type-for-directory default-pathname-defaults
	  subfile *subfile-default-root-pathname*
	  *default-directory-string*
	  load-truename compile-file-pathname
	  *default-lisp-pathname-type* *default-fasl-pathname-type*
	  generic-pathname compile-system-file load-system-file
	  source-file object-file load-file-file
	  load-file *skip-load-if-loaded-p* *skip-compile-file-fwd*
	  read-distribution write-distribution
	  set-system-source-file defsystem find-system
	  compile-system load-system compile-system-all load-system-all
	  map-system map-system-all *systems-banner*
	  add-system-location-directory *system-location-directory-list*
	  *initialize-systems-p* initialize-systems))

(defparameter *dsys-shadowing-import-symbols*
  #-cmu16
  '(#+(or lucid kcl excl :coral cmu) merge-pathnames
    make-pathname
    pathname-host pathname-device pathname-directory
    pathname-name pathname-type pathname-version
    #+cmu directory
    #+excl enough-namestring)
  #+cmu16
  '(directory enough-namestring make-pathname))

(defparameter *this-file* "system")

(defparameter *testing-declaration*
  '(optimize (speed 1) (safety 3) (space 1) #+lucid (compilation-speed 3)))

(defparameter *normal-declaration*
  '(optimize (speed 3) (safety #+excl 1 #-excl 0)
             (space 1) #+lucid (compilation-speed 3)))

(defparameter *fast-declaration*
  '(optimize (speed 3) (safety #+excl 1 #-excl 0)
             (space 1) #+lucid (compilation-speed 0)))

(proclaim 
 '(optimize (speed 3) (safety #+excl 1 #-excl 0)
            (space 1) #+lucid (compilation-speed 0)))

#+cmu17a
(defun purify (&rest ignore)
  (declare (ignore ignore))
  nil)

;----------------------------------------

#-cmu16
(progn

;;;  Add a keyword argument :CASE to MAKE-PATHNAME, PATHNAME-HOST,
;;;  PATHNAME-DEVICE, PATHNAME-DIRECTORY, PATHNAME-NAME, and PATHNAME-TYPE.
;;;  The possible values for the argument are :COMMON and :LOCAL.
;;;
;;;  :LOCAL means strings input to MAKE-PATHNAME or output by PATHNAME-xxx
;;;  follow the local file system's conventions for alphabetic case.
;;;  Strings given to MAKE-PATHNAME will be used exactly as written if
;;;  the file system supports both cases.  If the file system only
;;;  supports one case, the strings will be translated to that case.
;;;
;;;  :COMMON means strings input to MAKE-PATHNAME or output by PATHNAME-xxx
;;;  follow this common convention:
;;;    - all uppercase means to use a file system's customary case.
;;;    - all lowercase means to use the opposite of the customary case.
;;;    - mixed case represents itself.
;;;  The second and third bullets exist so that translation from local to
;;;  common and back to local is information-preserving.
;;;
;;;  The default is :LOCAL.

(defun string-case (string &optional (default :upper))
  (declare (type string string))
  (let ((length (length string))
	(upper-p nil)
	(lower-p nil))
      (dotimes (i length (cond (upper-p :upper)
			       (lower-p :lower)
			       (t default)))
	(let ((char (aref string i)))
	  (cond ((upper-case-p char)
		 (when lower-p (return :mixed))
		 (setq upper-p t))
		((lower-case-p char)
		 (when upper-p (return :mixed))
		 (setq lower-p t)))))))

(defun host-default-case (host-or-pathname) ; returns :upper or :lower
  #-symbolics (declare (ignore host-or-pathname))
  #+vms :upper
  #-(or vms symbolics) :lower
  #+symbolics
  (let ((host (etypecase host-or-pathname
		(pathname (scl:send host-or-pathname :host)) 
		(net:host host-or-pathname)
		(string (fs:get-pathname-host host-or-pathname)))))
    (typecase host
      ;;(fs:vms-host :upper) ; need to get these flavor names right
      ;;(fs:unix-host :lower)
      (t :lower))))

(defun convert-pathname-component-to-case (component case pathname)
  (if (stringp component)
      (ecase case
	(#-symbolics :local #+symbolics :common
	 component)
	(#-symbolics :common #+symbolics :local
	 (case (host-default-case pathname)
	   (:upper component)
	   (:lower
	    (case (string-case component)
	      (:upper (string-downcase component))
	      (:lower (string-upcase component))
	      (:mixed component))))))
      component))

(defun pathname-device (pathname &key (case :local))
  (setq pathname (pathname pathname))
  (convert-pathname-component-to-case (lisp:pathname-device pathname) case pathname))

(defun pathname-host (pathname &key (case :local))
  (setq pathname (pathname pathname))
  (convert-pathname-component-to-case (lisp:pathname-host pathname) case pathname))

(defun pathname-directory (pathname &key (case :local))
  (setq pathname (pathname pathname))
  (let ((directory (directory-to-subdirectory-list
		     (lisp:pathname-directory pathname)
		     #+cmu (lisp:pathname-device pathname))))
    (if (listp directory)
	(mapcar #'(lambda (component)
		    (convert-pathname-component-to-case
		      component case pathname))
		directory)	  
	directory)))

(defun pathname-name (pathname &key (case :local))
  (setq pathname (pathname pathname))
  (convert-pathname-component-to-case (lisp:pathname-name pathname) case pathname))

(defun pathname-type (pathname &key (case :local))
  (setq pathname (pathname pathname))
  (convert-pathname-component-to-case (lisp:pathname-type pathname) case pathname))

(defun pathname-version (pathname &key (case :local))
  (setq pathname (pathname pathname))
  (convert-pathname-component-to-case (lisp:pathname-version pathname) case pathname))

(defvar *host-only-pathname-alist* nil)

(defun host-only-pathname (&optional (pathname *default-pathname-defaults*))
  (let* ((host (pathname-host pathname))
	 (a (if (and *host-only-pathname-alist*
		     (eq host (caar *host-only-pathname-alist*)))
		(car *host-only-pathname-alist*)
		(assoc host *host-only-pathname-alist* :test #'equal))))
    (unless a
      (push (setq a (cons host (lisp:make-pathname :host host
						   :device nil
						   :directory nil
						   :name nil
						   :type nil
						   :version nil)))
	    *host-only-pathname-alist*))
    (cdr a)))

(defun make-pathname (&key (case :local)
			   (defaults (host-only-pathname))
			   (host (pathname-host defaults :case case))
			   (device (pathname-device defaults :case case))
			   (directory (pathname-directory defaults :case case))
			   (name (pathname-name defaults :case case))
			   (type (pathname-type defaults :case case))
			   (version (pathname-version defaults :case case)))
  (multiple-value-bind (dir #+cmu dev)
		       (subdirectory-list-to-directory
			(mapcar #'(lambda (component)
				    (convert-pathname-component-to-case
				     component case host))
				directory)
			#+cmu (convert-pathname-component-to-case device case host))
    (lisp:make-pathname
     :host (convert-pathname-component-to-case host case host)
     :device #+cmu dev #-cmu (convert-pathname-component-to-case device case host)
     :directory dir
     :name (convert-pathname-component-to-case name case host)
     :type (convert-pathname-component-to-case type case host)
     :version (convert-pathname-component-to-case version case host))))

)

#+cmu16
(defun make-pathname (&rest args &key 
			    (host nil host-p)
			    (device nil device-p)
			    (directory nil directory-p)
			    (name nil name-p)
			    (type nil type-p)
			    (version nil version-p)
			    defaults case)
  (declare (ignore defaults case))
  (let ((pathname (apply #'lisp:make-pathname args))
	(keep-host-p (or host (not host-p)))
	(keep-device-p (or device (not device-p)))
	(keep-directory-p (or directory (not directory-p)))
	(keep-name-p (or name (not name-p)))
	(keep-type-p (or type (not type-p)))
	(keep-version-p (or version (not version-p))))
    (if (not (and keep-host-p keep-device-p keep-directory-p
		  keep-name-p keep-type-p keep-version-p))
	(lisp:make-pathname :host 
			    (when keep-host-p (pathname-host pathname))
			    :device 
			    (when keep-device-p (pathname-device pathname))
			    :directory 
			    (when keep-directory-p (pathname-directory pathname))
			    :name
			    (when keep-name-p (pathname-name pathname))
			    :type
			    (when keep-type-p (pathname-type pathname))
			    :version
			    (when keep-version-p (pathname-version pathname)))
	pathname)))

;----------------------------------------

;;; See arisia.xerox.com:cl/cleanup/passed/pathname-subdirectory-list

#+(or lucid cleanup genera kcl explorer excl :coral cmu)
(progn

;;Need to deal with . and .. for unix
(defun directory-to-subdirectory-list (pdir #+cmu device)
  (when (pathnamep pdir) (setq pdir (lisp:pathname-directory pdir)))
  #+(or cleanup cmu16)
             pdir
  #+:coral   (if (null pdir)
		 '(:relative)
		 (cons :absolute
		       (let ((result nil)
			     (current 0)
			     next)
			 (loop (unless (setq next (position #\: pdir :start current))
				 (return (nreverse result)))
			       (push (subseq pdir current next) result)
			       (setq current (1+ next))))))
  #+lucid    (if (null pdir)
		 '(:relative)
		 (subst :up ".." 
			(case (car pdir)
			  (:relative pdir)
			  (:current '(:relative))
			  (:root (cons :absolute (cdr pdir))))
			:test #'equal))
  #+genera   (if (and (consp pdir) (eq (car pdir) :relative))
		 pdir
		 (if (null pdir)
		     '(:relative)
		     (cons :absolute (and (listp pdir) pdir))))
  #+(and cmu (not cmu16))
	     (if (or (null device) (equal device "Default"))
		 (cons :relative (coerce pdir 'list))
		 (cons :absolute (coerce pdir 'list)))
  #+kcl      (let* ((dir (if (not (eq (car pdir) :root))
			    (cons :relative pdir)
			    (cons :absolute (cdr pdir))))
		    (tail (cdr dir))
		    (r-result nil))
	       (loop (when (null tail)
		       (return (if r-result (nreverse r-result) dir)))
		     (case (car tail)
		       (:current
			(unless r-result
			  (setq r-result (nreverse (ldiff dir tail)))))
		       (:parent
			(unless r-result
			  (setq r-result (nreverse (ldiff dir tail))))
			(push :up r-result))
		       (t
			(when r-result (push (car tail) r-result))))
		     (setq tail (cdr tail))))	       
  #+explorer (cons :absolute pdir)
  #+excl     (cond ((equal pdir '(:absolute :root))
		    '(:absolute))
		   ((null pdir)
		    '(:relative))
		   (t
		    pdir)))

(defun subdirectory-list-to-directory (s-list #+cmu device)
  (when (null s-list) (setq s-list '(:relative)))
  #+(or cleanup cmu16)
	     s-list
  #+:coral   (if (eq (car s-list) :relative)
		 nil
		 (apply 'concatenate 'string
			(mapcan #'(lambda (component)
				    (list component ":"))
				(cdr s-list))))
  #+lucid    (subst ".." :up 
		    (if (eq (car s-list) :relative)
			s-list
			(cons :root (cdr s-list))))
  #+genera   (if (eq (car s-list) :relative)
		 (if (cdr s-list) s-list nil)
		 (if (cdr s-list) (cdr s-list) :root))
  #+(and cmu (not cmu16))
	     (if (eq (car s-list) :relative)
		 (if (cdr s-list)
		     (values (coerce (cdr s-list) 'vector) "Default")
		     (values nil nil))
		 (values (coerce (cdr s-list) 'vector) device))
  #+kcl      (subst ".." :up (if (eq (car s-list) :relative)
				 (cdr s-list) (cons :root (cdr s-list))))
  #+explorer (if (eq (car s-list) :relative)
		 (error "relative pathnames are not implemented") (cdr s-list))
  #+excl     (cond ((equal s-list '(:absolute))
		    '(:absolute :root))
		   ((equal s-list '(:relative))
		    nil)
		   (t
		    s-list)))
)

#-(or lucid cleanup genera kcl explorer excl :coral cmu)
(error "You must implement functions directory-to-subdirectory-list and 
subdirectory-list-to-directory for your version of CL")

#-cmu16
(defun pathname-directory-merge (pdir dpdir)
  (let ((s-pdir (pathname-directory pdir)))
    (if (eq :relative (car s-pdir))
	(let ((first-part (pathname-directory dpdir)) 
	      (last-part (cdr s-pdir))) 
	  (loop (unless (eq (car last-part) ':up) (return nil))
		(pop last-part) (setq first-part (butlast first-part)))
	  (append first-part last-part))
	s-pdir)))

(defun default-pathname-defaults ()
  #-kcl
  *default-pathname-defaults*
  #+kcl
  (if (not (eq :root (car (pathname-directory *default-pathname-defaults*))))
      (if (or (equal "." (file-namestring *default-pathname-defaults*))
	      (equal ".." (file-namestring *default-pathname-defaults*)))
	  (pathname-as-directory (truename *default-pathname-defaults*))
	  (truename *default-pathname-defaults*))
      *default-pathname-defaults*))

;If path contains a relative directory,
;the result's directory is merged from both path and defaults.
#+(or lucid kcl excl :coral (and cmu (not cmu16)))
(defun merge-pathnames (path &optional (defaults (default-pathname-defaults))
			     (default-version :newest))
  (setq path (pathname path)) (setq defaults (pathname defaults))
  (make-pathname :defaults (lisp:merge-pathnames path defaults default-version)
		 :directory (pathname-directory-merge path defaults)))

(defvar *subfile-default-root-pathname* (default-pathname-defaults))

(defun subfile (directory &key name type (root *subfile-default-root-pathname*))
  (make-pathname :host (pathname-host root)
		 :device (pathname-device root)
		 :directory (append (pathname-directory root)
				    directory)
		 :name name
		 :type type))

(defvar *default-directory-string* #+(or unix mach) "." #-unix "")

#+(or excl cmu16)
(defun enough-namestring (pathname &optional (defaults *default-pathname-defaults*))
  (setq defaults (pathname defaults))
  (setq pathname (merge-pathnames pathname defaults))
  (make-pathname :defaults pathname
		 :directory (let ((pdir (pathname-directory pathname))
				  (ddir (pathname-directory defaults)))
			      (if (or (not (equal (pathname-host pathname)
						  (pathname-host defaults)))
				      (not (equal (pathname-device pathname)
						  (pathname-device defaults)))
				      (atom pdir) (atom ddir)
				      (not (eq (car pdir) (car ddir))))
				  pdir
				  (let ((pdir-tail (cdr pdir))
					(ddir-tail (cdr ddir)))
				    (loop (unless ddir-tail
					    (return (cons ':relative pdir-tail)))
					  (unless (and pdir-tail
						       (equal (car pdir-tail)
							      (car ddir-tail)))
					    (return pdir))
					  (pop pdir-tail) (pop ddir-tail)))))
		 :name (unless (equal (pathname-name pathname)
				      (pathname-name defaults))
			 (pathname-name pathname))
		 :type (unless (equal (pathname-type pathname)
				      (pathname-type defaults))
			 (pathname-type pathname))
		 :version (unless (equal (pathname-version pathname)
				      (pathname-version defaults))
			    (pathname-version pathname))))
		         

#+cmu
(defun directory (pathname)
  (lisp:directory pathname :check-for-subdirs nil))

;----------------------------------------

;;; See the last paragraph of arisia.xerox.com:cl/cleanup/passed/
;;;   pathname-subdirectory-list
;;; (starting with "To keep it simple, we chose not to add to this issue ...").

(defun type-for-directory (host)
  #-genera (declare (ignore host))
  #+(or unix mach :coral) nil
  #+vms "DIR" ;??
  #+genera (pathname-type
	    (directory-pathname-as-file
	     (make-pathname :host host
			    :directory '(:absolute "X")))))

#-(or unix mach vms genera :coral)
(error "You must implement type-for-directory for your version of CL")

(defparameter nwild #+(and cmu (not cmu16)) "*" #-(and cmu (not cmu16)) :wild)
(defparameter dwild #-genera "*" #+genera :wild)

#+genera
(progn
(defun pathname-as-directory (pathname)
  (zl:send (pathname pathname) :pathname-as-directory))

(defun directory-pathname-as-file (pathname)
  (zl:send (pathname pathname) :directory-pathname-as-file))
)

#-genera
(progn
(defun pathname-as-directory (pathname)
  (setq pathname (pathname pathname))
  (make-pathname :host (pathname-host pathname)
		 :device (pathname-device pathname)
		 :directory (let ((dir (pathname-directory pathname))
				  (name #-(or unix mach) (pathname-name pathname)
					#+(or unix mach) (file-namestring pathname)))
			      (when (equal name nwild) (setq name dwild))
			      (cond #+(or unix mach)
				    ((equal name "..") (append dir '(:up)))
				    #+(or unix mach)
				    ((equal name ".") dir)
				    (t (append dir (list name)))))
		 :name nil :type nil :version nil))

(defun directory-pathname-as-file (pathname)
  (setq pathname (pathname pathname))
  (let ((s-list (pathname-directory pathname)))
    (when (null (cdr s-list))
      (error "directory-pathname-as-file can't get file's directory"))
    (let* ((name (car (last s-list)))
	   (unix-up-p #-(or unix mach) nil #+(or unix mach) (eq name ':up)))
      (unless (or (eq name ':up) (stringp name))
	(error "directory-pathname-as-file can't get file's directory"))
      (when (equal name dwild) (setq name nwild))
      (make-pathname :host (pathname-host pathname)
		     :device (pathname-device pathname)
		     :directory (butlast s-list)
		     :name (if unix-up-p "." name)
		     :type (if unix-up-p ""
			       (type-for-directory (pathname-host pathname)))
		     :version nil))))
)

#+genera
(progn

(defun directoryp (pathname)
  (file-directoryp (directory-pathname-as-file pathname)))

(defun file-directoryp (pathname)
  (getf (cdr (second (fs:directory-list pathname))) :directory))

(defun create-directory (pathname)
  (zl:send (pathname pathname) :create-directory))

)

#+:coral
(progn

(defun directoryp (pathname)
  (and (probe-file pathname) (null (pathname-name pathname))))

(defun file-directoryp (pathname)
  (directoryp (pathname-as-directory pathname)))

(defun create-directory (pathname) ;must end in semi-colon
  (user::create-file pathname))

)

#+(and (not cmu) (or unix mach))
(progn

(defun file-directoryp (pathname)
  (directoryp pathname))

#+lucid
(progn

(defun malloc-foreign-string (str)
  (check-type str string)
  (let ((f-str (malloc-foreign-pointer
		:type `(:pointer (:array :character (,(1+ (length str))))))))
    (setf (foreign-string-value f-str) str)
    (setf (foreign-pointer-type f-str) '(:pointer :character))
    f-str))

(def-foreign-function (libc-system (:return-type :unsigned-32bit)
				   (:name "_system")
				   (:language :c))
    (string (:pointer :character)))

;; There is a bug in Lucid 3 that keeps this from working
;; if the user types ctl-c, then aborts out of the debugger
#+lcl4.0
(defun run-unix-command (command)
  (let ((f-command (malloc-foreign-string command)))
    (libc-system f-command)
    (free-foreign-pointer f-command)
    (third (pop lucid::*subprocess-status-list*))))

#-lcl4.0
(defun run-unix-command (command)
  (let ((f-command (malloc-foreign-string command))
	(mask (lucid::sigblock lucid::mask-sigchld)))
    (prog1 (libc-system f-command)
      (lucid::sigsetmask mask)
      (free-foreign-pointer f-command))))

)

#+excl
(eval-when (load compile eval)
  (unless (find-package :ff)
    (require :foreign)))

#+excl
(unless (fboundp 'run-unix-command) ; According to DJW, we need this.
  (let ((entry-point (ff:convert-to-lang "system" :language :c)))
    (ff:remove-entry-point entry-point)
    (load "" :unreferenced-lib-names (list entry-point))
    (ff:defforeign 'run-unix-command
	:entry-point entry-point
	:arguments '(string))))

#+kcl
(defun run-unix-command (command)
  (si::system command))

#-(or lucid excl kcl cmu)
(error "You must implement run-unix-command for your version of CL")

(defun unix-test (letter pathname)
  (zerop
    (run-unix-command 
      (format nil  "~A/bin/test -~A ~A"
	      #-(and excl hp) "exec " #+(and excl hp) ""
	      letter (namestring pathname)))))

(defun directoryp (pathname)
  (unix-test #\d pathname))

(defun create-directory (pathname)
  (zerop
    (run-unix-command 
      (format nil "/bin/mkdir ~A" (namestring (directory-pathname-as-file pathname))))))

(defun file-readable-p (pathname)
  (unix-test #\r pathname))

(defun file-writable-p (pathname)
  (unix-test #\w (if (probe-file pathname)
		     pathname
		     (directory-pathname-as-file pathname))))

(defun file-executable-p (pathname)
  (unix-test #\x pathname))

)

(defvar *for-input-p* t)

#+(and cmu (not cmu16))
(import '(mach:unix-file-kind mach:unix-mkdir mach:get-unix-error-msg
	  mach:unix-mkdir mach:unix-stat mach:unix-utimes))

#+(and cmu cmu16)
(import '(unix:unix-file-kind unix:unix-mkdir unix:get-unix-error-msg
	  unix:unix-mkdir unix:unix-stat unix:unix-utimes))

#+cmu
(progn ; With the help of src/hemlock/dired.lisp

(defun file-directoryp (pathname)
  (directoryp pathname))

(defun directoryp (pathname)
  (eq (unix-file-kind (ext:unix-namestring pathname *for-input-p*)) :directory))

(defun create-directory (pathname)
  (let ((name (ext:unix-namestring (directory-pathname-as-file pathname) nil)))
    (multiple-value-bind (winp err) 
	(unix-mkdir name #o755)
      (unless winp
	(error "Couldn't make directory ~S: ~A"
		 name
		 (get-unix-error-msg err))))))

(defun pathname-mode (pathname)
  (multiple-value-bind (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
      (unix-stat (ext:unix-namestring pathname *for-input-p*))
    (declare (ignore reslt dev-or-err ino nlink uid gid rdev size atime mtime)
	     (fixnum mode))
    mode))

(defun pathname-mode-test (pathname bit)
  (let ((mode (pathname-mode pathname)))
    (when mode (logbitp bit mode))))

(defun file-readable-p (pathname)
  (pathname-mode-test pathname 8))

(defun file-writable-p (pathname)
  (pathname-mode-test (if (probe-file pathname)
			  pathname
			  (directory-pathname-as-file 
			   (truename (make-pathname :defaults pathname
						    :name nil
						    :type nil
						    :version nil))))
		      7))

(defun file-executable-p (pathname)
  (pathname-mode-test pathname 6))

(defun run-unix-command (command)
  (ext:process-exit-code
   (ext:run-program "/bin/sh" `("-c" ,command) 
		    :pty nil :input nil :output nil)))

)

#-(or genera unix mach :coral)
(error "You must implement directoryp and create-directory for your version of CL")

(defun ensure-directory (directory &optional (exists-p 'unknown))
  (declare (ignore exists-p))
  (setq directory (make-pathname :defaults directory
				 :name nil :type nil :version nil))
  (let ((*for-input-p* nil))
    (unless (directoryp directory)
      (if (not (#-cmu probe-file #+cmu pathname-mode
		  (directory-pathname-as-file directory)))
	  (error "~a exists, but is not a directory" (namestring directory))
	  (let ((dir (pathname-directory directory)))
	    (when (cdr dir)
	      (ensure-directory (make-pathname :defaults directory
					       :directory (butlast dir))))
	    (create-directory directory))))))

;----------------------------------------

(defsetf file-write-date set-file-write-date)

#+genera
(defun set-file-write-date (path date)
  (fs:change-file-properties path nil ':creation-date date)
  date)

#+(and lucid unix)
(progn

(def-foreign-synonym-type u_char :unsigned-8bit)
(def-foreign-synonym-type u_short :unsigned-16bit)
(def-foreign-synonym-type u_int :unsigned-32bit)
(def-foreign-synonym-type u_long :unsigned-32bit)

(def-foreign-synonym-type ino_t u_long)
(def-foreign-synonym-type time_t :signed-32bit)
(def-foreign-synonym-type dev_t :signed-16bit)
(def-foreign-synonym-type off_t :signed-32bit)

(def-foreign-struct stat
  (st_dev	:type dev_t)		; device inode resides on
  (st_ino	:type ino_t)		; this inode's number
  (st_mode	:type :unsigned-16bit)	; protection
  (st_nlink	:type :signed-16bit)	; file's number of hard links
  (st_uid	:type :signed-16bit)	; user-id of owner
  (st_gid	:type :signed-16bit)	; group-id of owner
  (st_rdev	:type dev_t)		; the device type, for inode
					; that is device
  (st_size	:type off_t)		; total size of file
  (st_atime	:type time_t)		; file last access time
  (st_spare1	:type :signed-32bit)
  (st_mtime	:type time_t)		; file last modify time
  (st_spare2	:type :signed-32bit)
  (st_ctime	:type time_t)		; file last status change time
  (st_spare3	:type :signed-32bit)
  (st_blksize	:type :signed-32bit)	; optimal blocksize for file
					; system i/o ops
  (st_blocks	:type :signed-32bit)	; actual number of blocks
					; allocated
  (st_spare4	:type (:array :signed-32bit (2))))

(def-foreign-function (libc-stat (:return-type :signed-32bit)
				 (:name "_stat")
				 (:language :c))
    (path (:pointer :character))
    (buf (:pointer stat)))

(def-foreign-struct utimes
  (ut_atime	:type :signed-32bit)	; file last access time
  (ut_spare1	:type :signed-32bit)
  (ut_mtime	:type :signed-32bit)	; file last modify time
  (ut_spare2	:type :signed-32bit))

(def-foreign-function (libc-utimes (:return-type :unsigned-32bit)
		                   (:name "_utimes")
		                   (:language :c))
    (path (:pointer :character))
    (tvp (:pointer utimes)))

(load-foreign-libraries nil)

(defun set-file-write-date (path date)
  (let* ((current-fwd (file-write-date path))
	 (pathname (namestring path))
	 (f-path (malloc-foreign-string pathname))
	 (buf (malloc-foreign-pointer :type '(:pointer stat)))
	 (utimes (malloc-foreign-pointer :type '(:pointer utimes))))
    (when (zerop (libc-stat f-path buf))
      (let ((current-atime (stat-st_atime buf))
	    (current-spare1 (stat-st_spare1 buf))
	    (current-mtime (stat-st_mtime buf))
	    (current-spare2 (stat-st_spare2 buf)))
	(setf (utimes-ut_atime utimes) current-atime)
	(setf (utimes-ut_spare1 utimes) current-spare1)
	(setf (utimes-ut_mtime utimes) (+ current-mtime (- date current-fwd)))
	(setf (utimes-ut_spare2 utimes) current-spare2)
	(libc-utimes f-path utimes)))
      (free-foreign-pointer f-path)
      (free-foreign-pointer buf)
      (free-foreign-pointer utimes))
  date)

)

#+(and kcl bsd)
(progn

(defvar *link* nil)

(clines "
#include <sys/types.h>
#include <sys/stat.h>

object
change_file_write_date(opath,delta_fwd)
     object opath;
     int delta_fwd;
{
  char *path;
  struct stat buf;

  path=object_to_string(opath);
  if(0==stat(path,&buf))
    {buf.st_mtime += delta_fwd;
     if(0==utimes(path,&buf.st_atime))
       return(Ct);}
  return Cnil;
}
")

(defentry change-file-write-date (object int) (object "change_file_write_date"))

(defla change-file-write-date (path date)
  (declare (ignore path date))
  nil)

(defparameter cfwd-link *link*)

(defun set-file-write-date (path date)
  (when cfwd-link
    (change-file-write-date (namestring path) (- date (file-write-date path))))
  date)

(eval-when (load)
(when (and (null cfwd-link) (compiled-function-p #'set-file-write-date))
  (format t "~%Ignore the previous message: \"undefined _utimes symbol\""))
)

)

#+cmu
(progn

(defvar *utimes-buffer* (make-list 4 :initial-element 0))

(defun set-file-write-date (pathname date)
  (let ((ses-name (ext:unix-namestring pathname nil))
	(secs (- date lisp::unix-to-universal-time)))
    (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime)
	(unix-stat ses-name)
      (declare (ignore ino mode nlink uid gid rdev size))
      (unless winp (error "Couldn't stat file ~S failed: ~A."  ses-name dev-or-err))
      #-cmu16
      (progn
	(setf (car *utimes-buffer*) atime)
	(setf (caddr *utimes-buffer*) secs)
	(unix-utimes ses-name *utimes-buffer*))
      #+cmu16
      (progn
	(unix-utimes ses-name atime 0 secs 0))))) ; why do I have to use zeros here?

)

#-(or genera (and lucid unix) (and kcl bsd) cmu)
(defun set-file-write-date (path date)
  (declare (ignore path))
  date)

;----------------------------------------

;From pcl/defsys.lisp
(eval-when (compile load eval)
  #+(and Symbolics Lispm)
  (multiple-value-bind (major minor) (sct:get-release-version)
    (etypecase minor
      (integer)
      (string (setf minor (parse-integer minor :junk-allowed t))))
    (pushnew :genera *features*)
    (ecase major
      ((6)
       (pushnew :genera-release-6 *features*))
      ((7)
       (pushnew :genera-release-7 *features*)
       (ecase minor
	 ((0 1) (pushnew :genera-release-7-1 *features*))
	 ((2)   (pushnew :genera-release-7-2  *features*))
	 ((3)   (pushnew :genera-release-7-3  *features*))
	 ((4)   (pushnew :genera-release-7-4  *features*))))
      ((8)
       (pushnew :genera-release-8 *features*)
       (ecase minor
	 ((0) (pushnew :genera-release-8-0 *features*))
	 ((1) (pushnew :genera-release-8-1 *features*))))))
  
  #+CLOE-Runtime
  (let ((version (lisp-implementation-version)))
    (when (string-equal version "2.0" :end1 (min 3 (length version)))
      (pushnew :cloe-release-2 *features*)))

  (dolist (feature *features*)
    (when (and (symbolp feature)                ;3600!!
               (equal (symbol-name feature) "CMU"))
      (pushnew :CMU *features*)))
  
  #+TI
  (if (eq (si:local-binary-file-type) :xld)
      (pushnew ':ti-release-3 *features*)
      (pushnew ':ti-release-2 *features*))

  #+Lucid
  (when (search "IBM RT PC" (machine-type))
    (pushnew :ibm-rt-pc *features*))

  #+ExCL
  (cond ((search "sun3" (lisp-implementation-version))
	 (push :sun3 *features*))
	((search "sun4" (lisp-implementation-version))
	 (push :sun4 *features*)))

  #+(and HP Lucid)
  (push :HP-Lucid *features*)
  #+(and HP (not Lucid) (not excl))
  (push :HP-HPLabs *features*)

  #+Xerox
  (case il:makesysname
    (:lyric (push :Xerox-Lyric *features*))
    (otherwise (push :Xerox-Medley *features*)))

  )

(defparameter *default-pathname-extensions*
  (car '(#+(and (not imach) genera)          ("lisp"  . "bin")
	 #+(and imach genera)                ("lisp"  . "ibin")
	 #+Cloe-Runtime                      ("l"     . "fasl")
	 #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")
	 #+(and dec common vax ultrix)       ("lsp"   . "fas")
	 #+KCL                               ("lsp"   . "o")
	 #+IBCL                              ("lsp"   . "o")
	 #+Xerox                             ("lisp"  . "dfasl")
	 #+(and Lucid MC68000)               ("lisp"  . "lbin")
	 #+(and Lucid VAX)                   ("lisp"  . "vbin")
	 #+(and Lucid Prime)                 ("lisp"  . "pbin")
	 #+(and Lucid SUNRise)               ("lisp"  . "sbin")
	 #+(and Lucid SPARC)                 ("lisp"  . "sbin")
	 #+(and Lucid IBM-RT-PC)             ("lisp"  . "bbin")
	 #+(and Lucid MIPS)                  ("lisp"  . "mbin")
	 #+(and Lucid PRISM)                 ("lisp"  . "abin")
	 #+(and Lucid PA)                    ("lisp"  . "hbin")
	 #+(and excl SPARC)                  ("cl"    . "sparc")
	 #+(and excl m68k)                   ("cl"    . "m68k")
	 #+excl                              ("cl"    . "fasl")
	 #+:CMU ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
	 #+HP-HPLabs                         ("l"     . "b")
	 #+TI ("lisp" . #.(string (si::local-binary-file-type)))
	 #+:gclisp                           ("LSP"   . "F2S")
	 #+pyramid                           ("clisp" . "o")
	 #+:coral                            ("lisp"  . "fasl")
	 #-(or symbolics (and dec common vax) KCL IBCL Xerox 
	       lucid excl :CMU HP TI :gclisp pyramid coral)
	                                     ("lisp"  . "lbin"))))

#+kcl
(eval-when (load)

(clines "
object LSP_string;
object get_lisp_file_type(){return LSP_string;}")

(defentry get-lisp-file-type (object) (object "get_lisp_file_type"))

(setf (car *default-pathname-extensions*) (get-lisp-file-type))

)

(defparameter *default-lisp-pathname-type* 
  (car *default-pathname-extensions*))

(defparameter *default-fasl-pathname-type* 
  (cdr *default-pathname-extensions*))

(defparameter *pathname-extensions*
  (let* ((files-renamed-p nil)
	 (proper-extensions *default-pathname-extensions*))
    (cond ((null proper-extensions) '("l" . "lbin"))
          ((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
          (t proper-extensions))))

(defparameter *lisp-pathname-type* 
  (car *pathname-extensions*))

(defparameter *fasl-pathname-type*
  (cdr *pathname-extensions*))

(defvar *use-default-pathname-type* t)

(defun lisp-pathname-type ()
  (if *use-default-pathname-type*
      *default-lisp-pathname-type*
      *lisp-pathname-type*))

(defun fasl-pathname-type ()
  (if *use-default-pathname-type*
      *default-fasl-pathname-type*
      *fasl-pathname-type*))

;;;  13. COMPILE-FILE-PATHNAME pathname &key :output-file           [Function]
;;;
;;;    Returns the pathname that COMPILE-FILE would write into, if given the
;;;    same arguments.  If the pathname argument is a logical pathname and the
;;;    :output-file argument is unspecified, the result is a logical pathname.
;;;    If an implementation supports additional keyword arguments to
;;;    COMPILE-FILE, COMPILE-FILE-PATHNAME must accept the same arguments.

; What to do about the version?
#-cltl2
(defun compile-file-pathname (pathname &key output-file)
  (or output-file
      (let ((pathname (pathname pathname)))
	(make-pathname :defaults pathname
		       :type (fasl-pathname-type)
		       :version nil))))

(defun load-source-pathname (&optional (errorp nil))
  (let ((pathname (or #+Lispm sys:fdefine-file-pathname
		      #+excl  excl::*source-pathname*
		      #+lucid lucid::*source-pathname*
		      #-(or Lispm excl lucid akcl) nil)))
    (if (null pathname)
	(when errorp
	  (error "~S called but a file isn't being loaded." 'load-source-pathname))
	(pathname pathname))))

(defun load-pathname (&optional (errorp nil))
  (let ((pathname (or #+akcl  si:*load-pathname*
		      #+cmu16 *load-pathname*
		      #-(or Lispm excl lucid akcl) nil)))
    (if (null pathname)
	(when errorp
	  (error "~S called but a file isn't being loaded." 'load-pathname))
	(pathname pathname))))

#-cmu17
(defvar *load-truename* nil)

(defun load-truename (&optional (errorp nil))
  (let ((pathname (or *load-truename*
		      #+cmu (and lisp::*fasl-file* (pathname lisp::*fasl-file*))
		      #+Xerox (il:fullname *standard-input*))))
    (unless pathname
      (when (setq pathname (load-source-pathname))
	(setq pathname (truename pathname))))
    (if (null pathname)
	(when errorp
	  (error "~S called but a file isn't being loaded." 'load-truename))
	pathname)))

;----------------------------------------

(defstruct (system-file
	     (:constructor make-system-file (system pathname))
	     (:print-function print-system-file))
  system
  pathname
  (type-alist nil)
  (loaded-file-info nil)
  (property-list ()))

(defun print-system-file (sf stream depth)
  (declare (ignore depth))
  (format stream "#<system-file ~s>" (enough-namestring (system-file-pathname sf))))

(defvar *system-file-data* (make-hash-table :test 'equal))

(defun system-file-loaded-file (system-file)
  (lfi-truename (system-file-loaded-file-info system-file)))

(defun system-file-loaded-fwd (system-file)
  (lfi-fwd (system-file-loaded-file-info system-file)))

(defvar *system-directory-system*)

(defun system-file (system path)
  (setq path (pathname path))
  (let* ((key (cons (and system (system-name system))
		    (if (eq system *system-directory-system*)
			(pathname-name path)
			(namestring path))))
	 (value (gethash key *system-file-data*)))
    (if (or (null value)
	    (and (eq system *system-directory-system*)
		 (not (equal (system-file-pathname value) path))))
	(setf (gethash key *system-file-data*)
	      (make-system-file system path))
	value)))

(defun default-file-type (type)
  (ecase type
    (:lisp (lisp-pathname-type))
    (:bin  (fasl-pathname-type))))

(defun set-type-file (sf type pathname)
  (let ((a (assoc type (system-file-type-alist sf))))
    (if a
	(setf (cdr a) pathname)
	(push (cons type pathname)
	      (system-file-type-alist sf))))
  pathname)

(defsetf type-file set-type-file)

(defun type-file (sf type &optional object-p)
  (or (cdr (assoc type (system-file-type-alist sf)))
      (setf (type-file sf type)
	    (make-pathname :defaults
			   (let ((path (system-file-pathname sf))
				 (s (system-file-system sf)))
			     (merge-pathnames 
			      path
			      (or (if object-p
				      (system-default-object-pathname s)
				      (system-default-source-pathname s))
				  "")))
			   :type (default-file-type type)))))

(defun source-file (sf)
  (type-file sf :lisp))

(defsetf source-file (sf) (pathname)
  `(set-type-file ,sf :lisp ,pathname))

(defun object-file (sf)
  (type-file sf :bin t))

(defsetf object-file (sf) (pathname)
  `(set-type-file ,sf :bin ,pathname))

(defvar *loaded-file-info* (make-hash-table :test 'equal))

(defstruct (loaded-file-info
	     (:constructor make-loaded-file-info ())
	     (:conc-name lfi-)
	     (:print-function print-loaded-file-info))
  (truename nil) (fwd 0) (ut 0) (sf-list nil) (linkp nil))

(defun print-loaded-file-info (lfi stream depth)
  (declare (ignore depth))
  (format stream "#<lfi ~A>" (enough-namestring (lfi-truename lfi))))

(defun get-loaded-file-info (path)
  (let ((key (make-pathname :defaults path :type nil :version nil)))
    (or (gethash key *loaded-file-info*)
	(setf (gethash key *loaded-file-info*)
	      (make-loaded-file-info)))))

;----------------------------------------

; :ask :load-newest :load-source :load-object :compile-and-load
(defvar *choose-source-or-object-file-action*
  :ask)

(defun choose-source-or-object-file (source object)
  (ecase *choose-source-or-object-file-action*
    (:ask 
     (if (> (file-write-date source) (file-write-date object))
	 (progn
	   (clear-input *terminal-io*)
	   (format t "~&Source file ~S is newer than binary file ~S.
Load Source, Binary, or Compiled source (S, B or C): "
		   (enough-namestring source)
		   (enough-namestring object))
	   (loop (case (char-upcase (read-char *terminal-io*))
		   (#\S (return :source))
		   (#\B (return :object))
		   (#\C (compile-file source :output-file object)
			(return :object))
		   (t (clear-input *terminal-io*)
		      (format t "~&Please type S, B, or C: ")))))	     
	 :object))
    (:compile-and-load
     (when (> (file-write-date source) (file-write-date object))
       (compile-file source :output-file object))
     :object)
    (:load-newest
     (if (> (file-write-date source) (file-write-date object))
	 :source :object))
    (:load-source :source)
    (:load-object :object)))

(defun load-file-file (source object &optional error-p)
  (if (probe-file source)
      (if (probe-file object)
	  (if (eq :source (choose-source-or-object-file source object))
	      source
	      object)
	  source)
      (if (probe-file object)
	  object
	  (if error-p
	      (error "Cannot find ~A or ~A"
		     (enough-namestring source)
		     (enough-namestring object))
	      nil))))

(defvar *skip-load-if-loaded-p* nil)
(defvar *fake-load-p* nil)
(defvar *load-pathname* nil)

(defvar *skip-compile-file-fwd* nil)
(defvar *compile-file-truename* nil)
(defvar *compile-file-pathname* nil)
(defvar *compile-file-unwritable-error-p* t)

(eval-when (compile load eval)
(unless (get 'load ':definition-before-system)
  (setf (get 'load ':definition-before-system) (symbol-function 'load)))
(setf (symbol-function 'real-load) (get 'load ':definition-before-system))
)

(defun load-file-load-path (file &optional (if-does-not-exist ':error))
  (let* ((default (make-pathname :defaults (default-pathname-defaults)
				 :type nil))
	 (path (merge-pathnames file default))
	 (path-type (pathname-type path))
	 (load-path (if (and path-type (not (eq path-type ':unspecific)))
			(if (probe-file path)
			    path
			    (if if-does-not-exist
				(error "Cannot find ~A"
				       (enough-namestring path))
				nil))
			(load-file-file
			 (make-pathname :defaults path
					:type (lisp-pathname-type))
			 (make-pathname :defaults path
					:type (fasl-pathname-type))
			 if-does-not-exist))))
    (values load-path path)))

(defun load-file (file &rest options 
		       &key (if-does-not-exist ':error) link lf-verbose lfi
		       &allow-other-keys)
  (if #-excl nil #+excl (equal "" file)
      (apply #'real-load file options)
      (multiple-value-bind (load-path path)
	  (load-file-load-path file if-does-not-exist)
	(when load-path
	  (let* ((*load-pathname* path)
		 #+(and kcl bsd) (si:*load-pathname* path) ; needed for si:faslink
		 (fwd (file-write-date load-path))
		 (truename (truename load-path))
		 (load-lfi (get-loaded-file-info load-path))
		 (lf-fwd (lfi-fwd (if lfi
				      (if (< (lfi-ut lfi) (lfi-ut load-lfi))
					  load-lfi lfi)
				      load-lfi)))
		 (success-p nil))
	    (unless (and *skip-load-if-loaded-p*
			 (eql fwd lf-fwd))
	      (unwind-protect 
		   (let ((*load-truename* truename))
		     (setf (lfi-truename load-lfi) truename)
		     (setf (lfi-fwd load-lfi) fwd)
		     (setf (lfi-ut load-lfi) (get-universal-time))
		     (setf (lfi-linkp load-lfi) link)
		     (unless *fake-load-p*
		       (let ((*skip-load-if-loaded-p* nil)
			     (*skip-compile-file-fwd* nil)
			     #+(and kcl bsd)
			     (*link* (and (equal "o" (pathname-type truename)) link))
			     (opt nil))
			 (loop (when (null options) 
				 (return (setq options (nreverse opt))))
			       (let ((key (pop options))
				     (value (pop options)))
				 (unless (member key '(:lf-verbose :link :lfi
						       :if-does-not-exist))
				   (setq opt (list* value key opt)))))
			 (when lf-verbose
			   (format t "~&Loading ~A~%" (enough-namestring load-path)))
			 (#-(and kcl bsd) progn #+(and kcl bsd) if 
			     #+(and kcl bsd) *link*
			     #+(and kcl bsd) (si:faslink load-path *link*)
			     (apply #'real-load load-path options))))
		     (setq success-p t))
		(unless success-p
		  (setf (lfi-fwd load-lfi) 0))))
	    load-path)))))

(let (#+excl (excl::*enable-package-locked-errors* nil))
  (setf (symbol-function 'load) (symbol-function 'load-file)))

(defun fake-load (file)
  (let ((*fake-load-p* t))
    (load-file file)))

(defun fwd (pathname &optional error-if-not-found-p)
  (if (probe-file pathname)
      (file-write-date pathname)
      (if error-if-not-found-p
	  (error "File ~A was not found" (enough-namestring pathname))
	  0)))

(eval-when (compile load eval)
(unless (get 'compile-file ':definition-before-system)
  (setf (get 'compile-file ':definition-before-system)
	(symbol-function 'compile-file)))
(setf (symbol-function 'real-compile-file)
      (get 'compile-file ':definition-before-system))
)

(defun new-compile-file (input-file &rest options &key output-file &allow-other-keys)
  (let ((*package* (find-package "USER")))
    (if (null *skip-compile-file-fwd*)
	(apply #'real-compile-file input-file options)
	(let ((output-file-p output-file)
	      (default (make-pathname :defaults (default-pathname-defaults)
				      :type nil)))
	  (setq input-file (merge-pathnames input-file default))
	  (when (member (pathname-type input-file) '(nil :unspecific))
	    (setq input-file (make-pathname :defaults input-file
					    :type (lisp-pathname-type))))
	  (setq output-file (if output-file 
				(merge-pathnames output-file)
				(make-pathname :defaults input-file
					       :type (fasl-pathname-type))))
	  (when (or *compile-file-unwritable-error-p*
		    (and (probe-file input-file)
			 #+(or unix mach) (file-writable-p output-file)
			 #-(or unix mach) t))
	    (let* ((input-fwd (fwd input-file t))
		   (required-fwd (max input-fwd *skip-compile-file-fwd*))
		   (output-fwd (fwd output-file)))
	      (declare (integer input-fwd required-fwd output-fwd))
	      (when (zerop output-fwd)
		#+cmu (ensure-directory output-file))
	      (multiple-value-prog1
		  (if (> output-fwd required-fwd)
		      output-file
		      (let ((*skip-load-if-loaded-p* nil)
			    (*skip-compile-file-fwd* nil)
			    #+(and kcl bsd)
			    (*link* nil))
			(apply #'real-compile-file input-file
			       (if output-file-p
				   options
				   (list* :output-file output-file options)))))
		(#-kcl progn #+kcl unless #+kcl compiler::*error-p*
		       (setq *skip-compile-file-fwd* required-fwd)))))))))

(let (#+excl (excl::*enable-package-locked-errors* nil))
  (setf (symbol-function 'compile-file) (symbol-function 'new-compile-file)))

;----------------------------------------

(defvar *load-only-p* nil)

;compile (source sf) if (fwd (object sf)) <= (max (fwd (source sf)) time)
;load (object sf) if (fwd (object sf)) /= loaded-write-date
;force-p is nil, some fwd, or t
(defun compile-system-file (sf &optional force-p)
  (let ((*skip-compile-file-fwd* 
	 (if (eql force-p 't) #.(expt 10 10) (or force-p 0)))
	(*use-default-pathname-type* nil))
    (unless *load-only-p*
      (compile-file (source-file sf) :output-file (object-file sf)))
    (load-system-file sf :newest)
    *skip-compile-file-fwd*))

;load (object sf) if (fwd (object sf)) /= loaded-write-date
;force-p is nil, :newest, or t
(defun load-system-file (sf &optional force-p (error-p t))
  (let* ((*use-default-pathname-type* nil)
	 (*choose-source-or-object-file-action*
	  (if force-p :load-newest :load-object))
	 (load (load-file-file (source-file sf) (object-file sf) error-p)))
    (when load
      (let* ((*skip-load-if-loaded-p* (not (eq force-p t)))
	     (link (getf (system-file-property-list sf) ':link))
	     (loaded-file (load-file load :lf-verbose t :verbose nil :link link
				     :lfi (system-file-loaded-file-info sf)))
	     (lfi (get-loaded-file-info loaded-file)))
	(setf (system-file-loaded-file-info sf) lfi)
	(pushnew sf (lfi-sf-list lfi)))))
  force-p)

;----------------------------------------

(defvar *systems-banner* nil)

(defvar *load-newest-p* t)
(defvar *verbose* t)
(defvar *load-skip* nil)
(defvar *all-systems* nil)
(defvar *system-location-directory-list* nil)
(defvar compile-system-op)
(defvar compile-system-all-op)
(defvar load-system-op)

(defstruct (system
	     (:constructor make-system-internal (name pretty-name))
	     (:print-function print-system))
  name ; a symbol in the defsys package
  (source-file nil) ; NIL or a pathname
  (default-source-pathname nil)
  (default-object-pathname nil)
  pretty-name ; a string
  (modules ())
  (primary-module nil))

(unless (boundp '*system-directory-system*)
  (setq *system-directory-system*
	(make-system-internal 'dsys::system-directory "System Directory")))

(defstruct (module
	     (:constructor make-module (system type name contents))
	     (:print-function print-module))
  system
  name ; a symbol or nil
  type ; file,system,serial,parallel
  contents) 

(defstruct (system-operation
	     (:conc-name s-o-)
	     (:print-function print-system-operation))
  (operation nil)
  (inferior-system-operation nil)
  (file-operation nil)
  (state-operation nil)
  (system-function #'default-system-function))

(defun print-system (system stream depth)
  (declare (ignore depth))
  (format stream "#<system ~A>" (system-pretty-name system)))

(defun module-data (module)
  (or (module-name module)
      (case (module-type module)
	(system (module-contents module))
	(file (enough-namestring (system-file-pathname (module-contents module))))
	(forms (module-contents module))
	((serial parallel load compile)
	 (mapcar #'module-data (module-contents module)))
	(t (error "Unknown module-type ~S" (module-type module))))))

(defun print-module (module stream depth)
  (declare (ignore depth))
  (let ((*print-level* (or *print-level* 3))
	(*print-length* (or *print-length* 3)))
    (format stream "#<Module ~S>" (module-data module))))

(defun print-system-operation (s-o stream depth)
  (declare (ignore depth))
  (format stream "#<system-operation ~A>" (s-o-operation s-o)))

;----------------------------------------

(defun compile-state-op (x y)
  (declare (type (or (member nil t) integer) x y))
  (cond ((or (null y) (eq x 't)) x)
	((or (null x) (eq y 't)) y)
	((< y x) x)
	(t y)))

(defun load-state-op (x y)
  (or x y))

(defvar *system-name-package* (find-package "KEYWORD"))

(defun normalize-system-name (system-name)
  (when (and (symbolp system-name)
	     (not (eq *system-name-package* (symbol-package system-name))))
    (setq system-name (symbol-name system-name)))
  (when (stringp system-name)
    (setq system-name (intern (string-upcase system-name) *system-name-package*)))
  (unless (symbolp system-name)
    (error "~S is not a string or a symbol" system-name))
  system-name)

(defun find-system-simple (system-name &optional error-p)
  (setq system-name (normalize-system-name system-name))
  (or (find system-name *all-systems* :key #'system-name)
      (case error-p
	((nil) nil)
	(:create (let ((system (make-system-internal system-name
						     (string-capitalize system-name))))
		   (setq *all-systems* (nconc *all-systems* (list system)))
		   system))
	(t (error "System ~A not found" system-name)))))

(defun delete-system (system-name)
  (setq *all-systems* (delete (normalize-system-name system-name) *all-systems*
			      :key #'system-name)))

(defun set-system-source-file (system-name source-file
			       &optional (source-file-directory
					  (default-pathname-defaults)))
  (let ((system (find-system-simple system-name :create)))
    (setf (system-source-file system) 
	  (system-file system (merge-pathnames source-file source-file-directory)))
    system))

(defun add-system-location-directory (directory)
  (unless (member directory *system-location-directory-list* :test #'equal)
    (push directory *system-location-directory-list*))
  directory)

(defun maybe-load-system-source-file-locator (system-name)
  (setq system-name (normalize-system-name system-name))
  (unless (eq system-name ':system)
    (dolist (directory *system-location-directory-list*)
      (when (directoryp directory)
	(let* ((sf (system-file *system-directory-system*
				(make-pathname :defaults directory
					       :name (string-downcase system-name))))
	       (*use-default-pathname-type* nil)
	       (source (source-file sf))
	       (object (object-file sf)))
	  (when (load-file-file source object nil)
	    (load-system-file sf :newest)
	    (return t)))))))

(defun find-system (system-name &optional error-p)
  (let ((*use-default-pathname-type* nil)
	(system (if (system-p system-name)
		    system-name
		    (progn
		      (maybe-load-system-source-file-locator system-name)
		      (find-system-simple system-name error-p)))))
    (when (and system (not (eq (system-name system) ':system)))
      (let ((source-file (system-source-file system)))
	(when (and (null source-file)
		   (null (system-primary-module system)))
	  (error "The source file for ~A has not been declared"
		 (system-name system)))
	(when (and source-file (probe-file (source-file source-file)))
	  (load-system-file source-file :newest))))
    (when (and error-p (null (system-primary-module system)))
      (error "System ~A not defined" (system-name system)))
    system))

;----------------------------------------

(defmacro defsystem (name options &body body)
  `(define-system ',name ',options ',body))

(defvar *system*)
(defvar *modules*)

(defun find-module (type name contents)
  (if (null type)
      (or (find name *modules* :key #'module-name)
	  (error "The module named ~S was not found" name))
      (or (dolist (module *modules*)
	    (when (and (eq type (module-type module))
		       (equal contents (module-contents module)))
	      (return module)))
	  (let ((module (make-module *system* type name contents)))
	    (push module *modules*)
	    module))))

(defun parse-module (form)
  (typecase form
    ((or string pathname)
     (find-module 'file nil (system-file *system* form)))
    (symbol
     (find-module nil form nil))
    (atom
     (error "a defsystem module must be a string, symbol or list"))
    (t
     (case (car form)
       (:serial
	(find-module 'serial nil (mapcar #'parse-module (cdr form))))
       (:parallel
	(find-module 'parallel nil (mapcar #'parse-module (cdr form))))
       (:module 
	(let ((mname (cadr form))
	      (mcontents (caddr form))
	      (arglist (cdddr form))
	      type)
	  (dolist (arg arglist)
	    (when (and (listp arg) (eq (car arg) :type))
	      (setq type (cadr arg))))
	  (when (eq type :system)
	    (find-module 'system mname (normalize-system-name mcontents)))))
       (:load
	(find-module 'load nil (mapcar #'parse-module (cdr form))))
       (:compile
	(find-module 'compile nil (mapcar #'parse-module (cdr form))))
       (:file
	(let* ((name (eval (getf (cdr form) ':name)))
	       (source (eval (getf (cdr form) ':source)))
	       (object (eval (getf (cdr form) ':object)))
	       (link (eval (getf (cdr form) ':link)))
	       (sf (system-file *system* (or name source object))))
	  (when source (setf (source-file sf) source))
	  (when object (setf (object-file sf) object))
	  (when link
	    (setf (getf (system-file-property-list sf) ':link) link))
	  (find-module 'file nil sf)))
       (:system
	(find-module 'system nil (normalize-system-name (cadr form))))
       (:forms
	(find-module 'forms nil (cdr form)))
       (t
	(error "a defsystem module list must begin with one of ~S"
	       '(:file :system :serial :parallel :module :forms)))))))

;Note that the :serial and :parallel here have a different meaning 
;than in the Symbolics version.
;  :serial is to be used for files containing macros to force following files
;    to be recompiled.
(defun define-system (name options body)
  (let* ((*system* (find-system-simple name :create))
	 (pretty-name (or (getf options :pretty-name)
			  (system-pretty-name *system*)))
	 (source-file (system-source-file *system*))
	 (*default-pathname-defaults*
	  (make-pathname :defaults (or (getf options :default-pathname)
				       (and source-file
					    (system-file-pathname source-file))
				       (default-pathname-defaults))
			 :name nil :type nil :version nil))
	 (*modules* nil))
    (setf (system-pretty-name *system*) pretty-name)
    (setf (system-default-source-pathname *system*) *default-pathname-defaults*)
    (setf (system-default-object-pathname *system*) *default-pathname-defaults*)
    (setf (system-primary-module *system*) (parse-module `(:parallel ,@body)))
    (setf (system-modules *system*) *modules*)
    (system-name *system*)))

(defun operate-on-module (module initial-state system-operation)
  (operate-on-module1 module initial-state system-operation))

(defun operate-on-module-sequence (module initial-state system-operation serial-p)
  (let ((state initial-state)
	(operation (s-o-state-operation system-operation)))
    (dolist (m (module-contents module))
      (let ((module-state (operate-on-module m (if serial-p state initial-state)
					     system-operation)))
	(when operation
	  (setq state (funcall operation state module-state)))))
    state))

(defun operate-on-module1 (module initial-state system-operation)
  (case (module-type module)
    (system
     (operate-on-system (module-contents module) initial-state
			(s-o-inferior-system-operation system-operation)))
    (file
     (let ((operation (s-o-file-operation system-operation)))
       (if operation
	   (funcall operation (module-contents module) initial-state)
	   initial-state)))
    (load
     (if (member (s-o-operation system-operation) '(:load :compile))
	 (let ((*load-only-p* t))
	   (operate-on-module-sequence module initial-state system-operation nil))
	 initial-state))
    (compile
     (if (eq :compile (s-o-operation system-operation))
	 (operate-on-module-sequence module initial-state system-operation nil)
	 initial-state))
    (forms
     (let ((*skip-load-if-loaded-p* nil)
	   (*skip-compile-file-fwd* nil))
       (eval (getf (module-contents module) (s-o-operation system-operation)))
       initial-state))
    (serial
     (operate-on-module-sequence module initial-state system-operation t))
    (parallel
     (operate-on-module-sequence module initial-state system-operation nil))
    (t (error "Unknown module-type ~S" (module-type module)))))

(defvar *retry-operation-list* nil)

(defun retry-operation (function retry-string)
  (loop (block retry-operation-loop
	  (let ((*retry-operation-list*
		 (cons (cons #'(lambda ()
				 (return-from retry-operation-loop nil))
			     retry-string)
		       *retry-operation-list*)))
	    (return-from retry-operation
	      (funcall function))))))

(defun operate-on-system (system initial-state system-operation)
  (when system-operation
    (setq system (find-system system t))
    (retry-operation
     #'(lambda ()
	 (setq system (find-system system t))
	 (let ((*system* system)
	       (*default-pathname-defaults* (system-default-source-pathname system)))
	   (funcall (s-o-system-function system-operation)
		    system initial-state system-operation)))
     (format nil "Retry system operation ~A on system ~A." 
	     (s-o-operation system-operation)
	     (system-pretty-name system)))))

(defun default-system-function (system initial-state system-operation)
  (operate-on-module (system-primary-module system) initial-state system-operation))

(defvar *loaded-systems* nil)
(defvar *in-loading-systems-p* nil)

(defmacro loading-systems (&body forms)
  `(if *in-loading-systems-p*
       (progn ,@forms)
       (let ((*in-loading-systems-p* t)
	     (*loaded-systems* *loaded-systems*))
	 ,@forms)))

(defun load-system-function (system initial-state system-operation)
  (loading-systems
    (let ((success nil)
	  (op (s-o-operation system-operation))
	  (a (assoc system *loaded-systems*)))
      (unless a (push (setq a (cons system nil)) *loaded-systems*))
      (if (case (cdr a) (:load (eq op :load)) (:compile t))
	  initial-state
	  (progn
	    (setf (cdr a) (if (eq (cdr a) :compile) :compile op))
	    (unwind-protect
		 (prog1
		     (default-system-function system initial-state system-operation)
		   (setq success t))
	      (unless success
		(setf (cdr a) nil))))))))

(defun make-load-system-operation (operation)
  (make-system-operation
    :operation operation
    :file-operation (if (eq operation :load)
			#'load-system-file #'compile-system-file)
    :state-operation (if (eq operation :load)
			 #'load-state-op #'compile-state-op)
    :system-function #'load-system-function))

(setq load-system-op (make-load-system-operation :load))
(setf (s-o-inferior-system-operation load-system-op) load-system-op)

(setq compile-system-op (make-load-system-operation :compile))
(setf (s-o-inferior-system-operation compile-system-op) load-system-op)

(setq compile-system-all-op (make-load-system-operation :compile))
(setf (s-o-inferior-system-operation compile-system-all-op) compile-system-all-op)

(defmacro with-deferred-warnings (&body forms)
  `(#+Genera
    compiler:compiler-warnings-context-bind
    #+TI
    COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
    #+:LCL3.0
    lucid-common-lisp:with-deferred-warnings
    #+cmu
    with-compilation-unit #+cmu ()
    #-(or Genera TI :LCL3.0 cmu)
    progn
    ,@forms))

(defvar *compile-system-proclamation* *normal-declaration*)

(defvar *required-systems*)

(defun required-systems-function (system initial-state system-operation)
  (push system *required-systems*)
  (default-system-function system initial-state system-operation))

(defvar required-systems-op 
  (make-system-operation :operation :required-systems
			 :system-function #'required-systems-function))
(setf (s-o-inferior-system-operation required-systems-op) required-systems-op)

(defun required-systems (system)
  (setq system (find-system system t))
  (let ((*required-systems* nil))
    (operate-on-system system nil required-systems-op)
    (delete system *required-systems*)))

(defun compile-system (system &key recompile
			      ((:verbose *verbose*) t)
			      ((:load-newest-p *load-newest-p*) t))
  (proclaim *compile-system-proclamation*)
  (with-deferred-warnings
    (operate-on-system system recompile compile-system-op)))

(defun load-system (system &key (reload :newest)
			   ((:verbose *verbose*) t)
			   ((:load-newest-p *load-newest-p*) t))
  (operate-on-system system reload load-system-op))

(defun compile-system-all (system &key recompile
				  ((:verbose *verbose*) t)
				  ((:load-newest-p *load-newest-p*) t))
  (proclaim *compile-system-proclamation*)
  (with-deferred-warnings
    (operate-on-system system recompile compile-system-all-op)))

;----------------------------------------

(defun files-in-directory (directory)
  (let ((result-files nil) ; (dir type name1 name2...) ...
	(result-directories nil))
    (dolist (file (directory directory))
      (if (directoryp file)
	  (let* ((dir (pathname-as-directory file))
		 (name (car (last (pathname-directory dir)))))
	    (setq result-directories
		  (nconc (mapcar #'(lambda (files)
				     (cons (cons name (car files))
					   (cdr files)))
				 (files-in-directory dir))
			 result-directories)))
	  (let* ((type (pathname-type file))
		 (last-ch (and (stringp type)
			       (plusp (length type)) 
			       (aref type (1- (length type))))))
	    (unless (or (eql last-ch #\~) (equal type "o"))
	      (let ((e (find type result-files :test #'equal :key #'cadr)))
		(unless e (push (setq e (list '() type)) result-files))
		(push (pathname-name file) (cddr e)))))))
    (nconc result-files result-directories)))

(defun write-directory (dir)
  (write-distribution :files (files-in-directory dir)
		      :root dir
		      :output-file (make-pathname
				     :name (car (last (pathname-directory dir)))
				     :type "dist")))

(defvar *default-timezone*
  #+kcl 5 ;EST
  #-kcl (multiple-value-bind (sec min hour day month year dow dst-p tz)
	    (decode-universal-time 0)
	  (declare (ignore sec min hour day month year dow dst-p))
	  tz))  

(defun write-distribution (&key files header substitutions
				(root *subfile-default-root-pathname*)
				(verbose-p t)
				#+(or unix mach) (compress-p nil)
				#+(or unix mach) (compress-uu-split-p nil)
				(output-file (subfile '() :name "dist" :type "lisp"
						      :root root)))
  (declare (optimize (speed 3) (safety 0) #+lucid (compilation-speed 0)))
  (with-open-file (out output-file :direction :output :if-exists :supersede)
    (when header (write-line header out))
    (dolist (dir-files files)
      (let ((dir (car dir-files))
	    (type (cadr dir-files)))
	(dolist (name (cddr dir-files))
	  (let* ((path (subfile dir :name name :type type :root root))
		 (fwd (and (probe-file path) (file-write-date path)))
		 line)
	    (unless fwd (error "File ~A does not exist."
			       (enough-namestring path root)))
	    (format out ";>; ~S ~S ~S ~S~%" name type dir fwd)
	    (when verbose-p
	      (multiple-value-bind (sec min hour day month year dow dst-p tz)
		  (decode-universal-time fwd *default-timezone*)
		(declare (ignore sec dow dst-p tz))
		(format t "~&~2,'0D:~2,'0D ~2,'0D/~2,'0D/~2,'0D  ~A~%"
			hour min month day (mod year 100)
			(namestring (enough-namestring path root)))))
	    (with-open-file (in path :direction :input)	      
	      (loop (setq line (or (read-line in nil) (return nil)))
		    (dolist (subst substitutions)
		      (let* ((find (first subst))
			     (find-len (length find))
			     (sreplace (second subst)))
			(when (and (>= (length line) find-len)
				   (string= find line :end2 find-len))
			  (setq line sreplace))))
		    (write-line line out)))))))
    (format out ";>; ~S~%" nil))
  (format t "~&Finished writing files.~%")
  #+(or unix mach)
  (when (or compress-p compress-uu-split-p)
    (compress-file output-file compress-uu-split-p)))

(defun read-distribution (&key (root *subfile-default-root-pathname*)
			       (input-file (subfile '() :name "dist" :type "lisp"
						    :root root))
			       (verbose-p t)
			       #+(or unix mach) (uncompress-p nil)
			       #+(or unix mach) (uu-unsplit-uncompress-p nil))
  (declare (optimize (speed 3) (safety 0) #+lucid (compilation-speed 0)))
  (when verbose-p
    (format t "~%read-distribution: input-file ~S, root ~S~%" input-file root)
    #+(or unix mach) (when (or uncompress-p uu-unsplit-uncompress-p)
		       (format t "~%uncompress-p ~S, uu-unsplit ~S~%"
			       uncompress-p uu-unsplit-uncompress-p)))
  #+(or unix mach)
  (when (or uncompress-p uu-unsplit-uncompress-p)
    (uncompress-file input-file uu-unsplit-uncompress-p))
  (with-open-file (in input-file :direction :input)
    (let (line (last-dir nil))
      (loop (setq line (read-line in))
	    (when (and (>= (length line) 4)
		       (string= ";>; " line :end2 4))
	      (return nil)))
      (loop (with-input-from-string (d line :start 4)
	      (let* ((name (or (read d) (return nil)))
		     (type (read d))
		     (dir (read d))
		     (fwd (read d))
		     (path (subfile dir :name name :type type :root root)))
		(unless (equal dir last-dir)
		  (setq last-dir dir)
		  (ensure-directory (subfile dir :root root)))
		(let ((if-exists (if (not (probe-file path))
				     nil
				     (let ((pfwd (file-write-date path)))
				       (if (= fwd pfwd)
					   :supersede
					   :new-version)))))
		  (when verbose-p
		    (multiple-value-bind (sec min hour day month year dow dst-p tz)
			(decode-universal-time fwd *default-timezone*)
		      (declare (ignore sec dow dst-p tz))
		      (format t "~&~2,'0D:~2,'0D ~2,'0D/~2,'0D/~2,'0D  ~A~%"
			      hour min month day (mod year 100)
			      (namestring (enough-namestring path root)))))
		  (with-open-file (out path 
				       :direction :output
				       :if-exists if-exists)		    
		    (loop (setq line (read-line in))
			  (when (and (>= (length line) 4)
				     (string= ";>; " line :end2 4))
			    (return nil))
			  (write-line line out))))
		(setf (file-write-date path) fwd)))))))

#+(or unix mach)
(progn

(defvar *compressed-file-line-count* 1500)

(defun compress-file (input-file &optional uu-split-p)
  (setq input-file (merge-pathnames input-file))
  (let ((ns (namestring input-file))
	(file-ns (file-namestring input-file)))
    (run-unix-command 
     (format nil "compress -c ~A > ~A.Z" ns ns))
    (when uu-split-p
      (let ((uu (format nil "~A.Z.uu" ns))
	    (part 1))
	(run-unix-command 
	 (format nil "uuencode ~A.Z ~A.Z > ~A" ns file-ns uu))
	(with-open-file (in uu :direction :input)
	  (let ((line (read-line in nil))
		(uu-date (file-write-date uu)))
	    (loop (unless line (return nil))
		  (let ((uu-part (format nil "~a.~d" uu part))
			(lines 0))
		    (with-open-file (out uu-part :direction :output
					 :if-exists :supersede)
		      (format out ">>> \"~A.Z.uu\" ~D    ~D~%"
			      file-ns part uu-date)
		      (format out "--- Beginning of part ~D~%" part)
		      (loop (write-line line out)
			    (incf lines)
			    (setq line (read-line in nil))
			    (when (or (>= lines *compressed-file-line-count*) 
				      (null line))
			      (return nil)))
		      (format out "--- End of part ~D~%" part)))
		  (incf part))))
	(let ((next-uu-part (probe-file (format nil "~a.~d" uu part))))
	  (when next-uu-part (delete-file next-uu-part)))))))

(defun uncompress-file (output-file &optional uu-unsplit-p)
  (setq output-file (merge-pathnames output-file))
  (macrolet ((c-a-s (var value)		; compare and set
	       `(let ((v ,value))
		 (if ,var
		     (unless (equal ,var v)
		       (error "Wrong value for ~A" ,var))
		     (setq ,var v)))))
    (let ((z-file (format nil "~A.Z" (namestring output-file)))
	  (uu-file (format nil "~A.Z.uu" (namestring output-file)))
	  (uu-file-fns (format nil "~A.Z.uu" (file-namestring output-file))))
      (when uu-unsplit-p
	(let ((check-fwd nil)
	      (out nil)
	      (success-p nil)
	      (part 1))
	  (unwind-protect
	       (loop (let ((ns-part (format nil "~A.~D" uu-file part)))
		       (unless (probe-file ns-part)
			 (setq success-p t)
			 (return nil))
		       (with-open-file (in ns-part :direction :input)
			 (loop (let ((line (read-line in)))
				 (when (and (> (length line) 4)
					    (string= ">>>" line :end2 3))
				   (with-input-from-string (in line :start 3)
				     (c-a-s uu-file-fns (read in))
				     (c-a-s part (read in))
				     (c-a-s check-fwd (read in)))
				   (return nil))))
			 (read-line in)
			 (loop (let ((line (read-line in))
				     (term "--- End of part ")
				     (lterm #.(length "--- End of part ")))
				 (when (and (>= (length line) lterm)
					    (string= line term :end1 lterm))
				   (return nil))
				 (unless out
				   (setq out
					 (open uu-file :direction :output
					       :if-exists :supersede)))
				 (write-line line out)))))
		     (incf part))
	    (when out (close out :abort (not success-p)))))
	(when (probe-file z-file)
	  (delete-file z-file))
	(run-unix-command 
	 (format nil "cd ~A;uudecode ~A" 
		 (directory-namestring output-file) uu-file-fns)))
      (when (probe-file output-file)
	(delete-file output-file))
      (run-unix-command 
       (format nil "uncompress ~A.Z" (namestring output-file))))))

(defun mail-compressed-uu-files (&key users file intro-subject intro-file)
  (unless (listp users) (setq users (list users)))
  (setq file (merge-pathnames file))
  (let* ((ns (namestring file))
	 (file-ns (file-namestring file))
	 (uu (format nil "~A.Z.uu" ns))
	 (parts nil))
    (let ((part 1))
      (loop (let ((uu-part (format nil "~a.~d" uu part)))
	      (unless (probe-file uu-part)
		(return nil))
	      (push (list uu-part (file-namestring uu-part)) parts)
	      (incf part)))
      (setq parts (nreverse parts)))
    (dolist (user users)
      (when intro-file
	(let ((subject (or intro-subject "Instructions")))
	  (format t "~&~A~%" subject)
	  (run-unix-command
	   (format nil "mail -s '~A' ~A < ~A"
		   subject user (namestring intro-file)))
	  (sleep 15)))			; Try to make sure this part arrives first.
      (format t "~&mailed-~A~%" file-ns)
      (run-unix-command
       (format nil "mail -s 'File: mailed-~A' ~A < ~A"
	       file-ns user
	       (namestring (subfile '() :name *this-file* :type "lisp")))))
    (let ((part 1))
      (dolist (uu-part parts) (format t "~A~%" (second uu-part))
	(dolist (user users)
	  (run-unix-command
	    (format nil "mail -s 'File: ~A' ~A < ~A"
		    (second uu-part) user (first uu-part))))
	(incf part)))))
)

;----------------------------------------

(defvar *version-directory-alist* nil)

(defun version-directory-for (name)
  (or (cdr (assoc name *version-directory-alist* :test #'string=))
      (let* ((len (length name))
	     (directories (mapcan #'(lambda (pathname)
				      (when (file-directoryp pathname)
					(let ((last (pathname-name pathname)))
					  (when (and (<= len (length last))
						     (string= name last :end2 len))
					    (list last)))))
				  (directory (directory-pathname-as-file
					      (subfile `(,dwild))))))
	     (dname (cond ((null directories)
			   (error "Can't find a subdirectory beginning with ~A" name))
			  ((null (cdr directories))
			   (car directories))
			  (t
			   (loop (let ((dname (dolist (n directories)
						(when (y-or-n-p "Use ~A? " n)
						  (return n)))))
				   (when dname (return dname))))))))
	(push (cons name dname) *version-directory-alist*)
	dname)))

(defparameter *basic-files*
  `((() "lisp"
     ,*this-file*
     "init")))

(defvar *auto-load-systems* nil)

(defvar *initialize-systems-p* t)

;; If we are going to save a world, we must avoid any use of sun's yp stuff
(defvar *check-for-user-systems-p* 
  #+(or (and cmu sunos) (and kcl sun)) nil
  #-(or (and cmu sunos) (and kcl sun)) t)

(defun initialize-systems (&key revert-p system-only-p)
  (let ((*initialize-systems-p* nil))
    (setq *system-location-directory-list* nil)
    (add-system-location-directory (subfile '("systems")))
    (unless (or system-only-p (not *check-for-user-systems-p*))
      (let ((dir (subfile '("systems") :root (user-homedir-pathname))))
	(when (directoryp dir)
	  (add-system-location-directory dir))))
    (when (or revert-p (null *all-systems*))
      (setq *all-systems* nil)
      (setq *auto-load-systems* '(system))    
      (set-system-source-file 'system "system" (subfile '()))
      (define-system 'system `(:pretty-name "System"
			       :default-pathname ,(subfile '()))
	'((:file :name "system" #+(and kcl bsd) :link 
	                        #+(and kcl bsd (not |NeXT|)) "-lc"
	                        #+(and kcl bsd |NeXT|) "-lsys_s"))))
    (let ((*compile-file-unwritable-error-p* #-(and kcl |NeXT|) nil 
					     #+(and kcl |NeXT|) t))
      (loading-systems
       (compile-system 'system)
       (unless system-only-p
	 (dolist (directory *system-location-directory-list*)
	   (when (directoryp directory)
	     (dolist (path (sort (directory (make-pathname :defaults directory
							   :name nwild :type "lisp"))
				 #'string< :key #'pathname-name))
	       (find-system (pathname-name path) nil))))
	 (when (member 'system *auto-load-systems*)
	   (setq *auto-load-systems* 
		 (cons 'system (delete 'system *auto-load-systems*))))
	 (mapc #'compile-system-all *auto-load-systems*))))))

(defvar *default-file-location* nil)

(defun check-file-location (file)
  (when file
    (setq file (pathname file))
    (setq *default-file-location*
	  (and (if (pathname-type file)
		   (probe-file file)
		   (or (probe-file (make-pathname :defaults file
						  :type (lisp-pathname-type)))
		       (probe-file (make-pathname :defaults file
						  :type (fasl-pathname-type)))))
	       file))))

(check-file-location *default-file-location*)

(defun initialize ()
  (let* ((self (or *default-file-location*
		   (let ((path (or (load-pathname)
				   (load-source-pathname))))
		     (if (and path (probe-file path))
			 path
			 (load-truename)))
		   (setq *default-file-location*
			 (loop
			  (format t "~&Type the pathname of the file being loaded: ")
			  (when (check-file-location (read-line))
			    (return *default-file-location*))))))
	 (self-name (pathname-name self))
	 (*skip-load-if-loaded-p* t)
	 (mailed-p (and (>= (length self-name) #.(length "mailed-"))
			(string-equal "mailed-" self-name 
				      :end2 #.(length "mailed-"))))
	 (dist-name (make-pathname
		      :defaults self
		      :type "lisp"
		      :name (if mailed-p 
				(subseq self-name #.(length "mailed-"))
				self-name)))
	 (reload-p (not (and #+(and kcl bsd) cfwd-link))))
    (when self
      (loading-systems
	(when (compiled-function-p (symbol-function 'initialize))
	  (when (equal (pathname-type self) "lisp")
	    (setq self (make-pathname :defaults self 
				      :type (fasl-pathname-type)
				      :version nil)))
	  (when (and (null *load-truename*) #+(and kcl bsd) cfwd-link)
	    (fake-load self)))
	(setq *subfile-default-root-pathname* 
	      (make-pathname :defaults self :name nil :type nil :version nil))
	(unless (eq ':absolute (car (pathname-directory self)))
	  (setq *subfile-default-root-pathname* 
		(truename *subfile-default-root-pathname*)))
	(if (string-equal *this-file* self-name)
	    (when *initialize-systems-p* (initialize-systems))
	    (progn
	      (format t "~%Since the loaded file is not named ~S, ~
it must be a distribution file.~%" *this-file*)
	      (unless (compiled-function-p (symbol-function 'read-distribution))
		(compile 'read-distribution))
	      (read-distribution 
	       :input-file dist-name
	       #+(or unix mach) :uu-unsplit-uncompress-p #+(or unix mach) mailed-p)
	      (setq *choose-source-or-object-file-action* :compile-and-load)
	      (when *initialize-systems-p*
		(when reload-p
		  (initialize-systems :system-only-p t)
		  (read-distribution 
		    :input-file dist-name))
		(initialize-systems))
	      (unless mailed-p
		(when (find-symbol "ABORT" "USER")
		  (format t "~&Done!~%")
		  (funcall (find-symbol "ABORT" "USER")))
		(error "Done!"))))))))

(initialize)
