MCL and mk:defsystem

[Eugene Z. <vi...@ci...>]

Happy NY,

Recently I modified DEFSYSTEM-3.2i to get it work with MCL. For
some reason, MCL's MAKE-PATHNAME generates malformed pathname when
file name is specified by file-namestring instead of separate
pathname-name and pathname-type.
Below is a patched function NEW-APPEND-DIRECTORIES, which fixes that
behavior. It could be better just to stick with pathname-name and
-type to avoid #+:MCL stuff, but I was afraid to break the code for
other compilers.
It would be great to hear feedback from MCL users, since this was
tested only with 68k MCL 3.4: I have no PPC-based Mac nearby.

-- 
  Eugene


(defun new-append-directories (absolute-dir relative-dir)
  ;; Version of append-directories for CLtL2-compliant lisps. In particular,
  ;; they must conform to section 23.1.3 "Structured Directories". We are
  ;; willing to fix minor aberations in this function, but not major ones.
  ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
  ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0.
  (setf absolute-dir (or absolute-dir "")
	relative-dir (or relative-dir ""))
  (let* ((abs-dir (pathname absolute-dir))
	 (rel-dir (pathname relative-dir))
	 (host (pathname-host abs-dir))
	 (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
		     (pathname-device rel-dir)
		   (pathname-device abs-dir)))
	 (abs-directory (directory-to-list (pathname-directory abs-dir)))
	 (abs-keyword (when (keywordp (car abs-directory))
			(pop abs-directory)))
	 (abs-name (file-namestring abs-dir)) ; was pathname-name
	 (rel-directory (directory-to-list (pathname-directory rel-dir)))
	 (rel-keyword (when (keywordp (car rel-directory))
			(pop rel-directory)))
	 (rel-file (file-namestring rel-dir))
         #+:MCL(rel-name (pathname-name rel-dir))
         #+:MCL(rel-type (pathname-type rel-dir))
	 (directory nil))
    ;; TI Common Lisp pathnames can return garbage for file names because
    ;; of bizarreness in the merging of defaults.  The following code makes
    ;; sure that the name is a valid name by comparing it with the
    ;; pathname-name.  It also strips TI specific extensions and handles
    ;; the necessary case conversion.  TI maps upper back into lower case
    ;; for unix files!
    #+TI(if (search (pathname-name abs-dir) abs-name :test #'string-equal)
	    (setf abs-name (string-right-trim "." (string-upcase abs-name)))
	    (setf abs-name nil))
    #+TI(if (search (pathname-name rel-dir) rel-file :test #'string-equal)
	    (setf rel-file (string-right-trim "." (string-upcase rel-file)))
	    (setf rel-file nil))
    ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
    ;; and filename "foo". The namestring of a pathname with
    ;; directory '(:absolute :root "foo") ignores everything after the
    ;; :root.
    #+(and allegro-version>= (version>= 4 0))
    (when (eq (car abs-directory) :root) (pop abs-directory))
    #+(and allegro-version>= (version>= 4 0))
    (when (eq (car rel-directory) :root) (pop rel-directory))

    (when (and abs-name (not (null-string abs-name))) ; was abs-name
      (cond ((and (null abs-directory) (null abs-keyword))
	     #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
	     (setf abs-directory (list abs-name)))
	    (t
	     (setf abs-directory (append abs-directory (list abs-name))))))
    (when (and (null abs-directory)
	       (or (null abs-keyword)
		   ;; In Lucid, an abs-dir of nil gets a keyword of
		   ;; :relative since (pathname-directory (pathname ""))
		   ;; returns (:relative) instead of nil.
		   #+:lucid (eq abs-keyword :relative))
	       rel-keyword)
      ;; The following feature switches seem necessary in CMUCL
      ;; Marco Antoniotti 19990707
      #+:CMU
      (if (typep abs-dir 'logical-pathname)
	  (setf abs-keyword :absolute)
	  (setf abs-keyword rel-keyword))
      #-:CMU
      (setf abs-keyword rel-keyword))
    (setf directory (append abs-directory rel-directory))
    (when abs-keyword (setf directory (cons abs-keyword directory)))
    (namestring
     (make-pathname :host host
		    :device device
		    :directory
		    #-(and :cmu (not :cmu17)) directory
		    #+(and :cmu (not :cmu17)) (coerce directory 'simple-vector)
		    :name #-:MCL rel-file
                    #+:MCL rel-name
                    #+:MCL :type
                    #+:MCL rel-type
))))