From 5825d4acc89d51fc94e30e82e168c0ede7930a7d Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Fri, 14 Jun 2013 21:10:30 -0400
Subject: [PATCH] 3.0.1.9: better OS detection for MCL and ABCL. Restore MCL
 support.

Thanks to Chun Tian (binghe) for his feedback.
MCL has issues with make-pathname failing to override defaults with an explicit NIL component.
---
 asdf.asd           |  2 +-
 header.lisp        |  2 +-
 uiop/image.lisp    |  9 +++++----
 uiop/os.lisp       | 21 ++++++++++++---------
 uiop/pathname.lisp |  7 +++++--
 upgrade.lisp       |  2 +-
 version.lisp-expr  |  2 +-
 7 files changed, 26 insertions(+), 19 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index 623bf8c2..95d1f785 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -74,7 +74,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "3.0.1.8" ;; to be automatically updated by make bump-version
+  :version "3.0.1.9" ;; to be automatically updated by make bump-version
   :depends-on ()
   #+asdf3 :encoding #+asdf3 :utf-8
   ;; For most purposes, asdf itself specially counts as a builtin system.
diff --git a/header.lisp b/header.lisp
index 303ebb23..3f1cb251 100644
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 3.0.1.8: Another System Definition Facility.
+;;; This is ASDF 3.0.1.9: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/uiop/image.lisp b/uiop/image.lisp
index 2296ee3d..1c272932 100644
--- a/uiop/image.lisp
+++ b/uiop/image.lisp
@@ -73,7 +73,7 @@ This is designed to abstract away the implementation specific quit forms."
     #+gcl (lisp:quit code)
     #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
     #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
-    #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
+    #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
     #+mkcl (mk-ext:quit :exit-code code)
     #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
                    (quit (find-symbol* :quit :sb-ext nil)))
@@ -109,7 +109,8 @@ This is designed to abstract away the implementation specific quit forms."
     (system::print-backtrace :out stream :limit count)
     #+(or clozure mcl)
     (let ((*debug-io* stream))
-      (ccl:print-call-history :count count :start-frame-number 1)
+      #+clozure (ccl:print-call-history :count count :start-frame-number 1)
+      #+mcl (ccl:print-call-history :detailed-p nil)
       (finish-output stream))
     #+(or cmu scl)
     (let ((debug:*debug-print-level* *print-level*)
@@ -200,11 +201,11 @@ This is designed to abstract away the implementation specific quit forms."
     #+(or cmu scl) extensions:*command-line-strings*
     #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
     #+gcl si:*command-args*
-    #+genera nil
+    #+(or genera mcl) nil
     #+lispworks sys:*line-arguments-list*
     #+sbcl sb-ext:*posix-argv*
     #+xcl system:*argv*
-    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
+    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
     (error "raw-command-line-arguments not implemented yet"))
 
   (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
diff --git a/uiop/os.lisp b/uiop/os.lisp
index d5d8ac88..3b8be58e 100644
--- a/uiop/os.lisp
+++ b/uiop/os.lisp
@@ -33,20 +33,23 @@
 
   (defun os-windows-p ()
     (or #+abcl (featurep :windows)
-        #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
+        #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
 
   (defun os-genera-p ()
     (or #+genera t))
 
+  (defun os-oldmac-p ()
+    (or #+mcl t))
+
   (defun detect-os ()
-    (flet ((yes (yes) (pushnew yes *features*))
-           (no (no) (setf *features* (remove no *features*))))
-      (cond
-        ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
-        ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
-        ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
-        (t (error "Congratulations for trying XCVB on an operating system~%~
-that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
+    (loop* :with o
+           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
+                                         (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
+           :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
+           :else :do (setf *features* (remove feature *features*))
+           :finally
+           (return (or o (error "Congratulations for trying ASDF on an operating system~%~
+that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
 
   (detect-os))
 
diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp
index a71af46f..99e05d5e 100644
--- a/uiop/pathname.lisp
+++ b/uiop/pathname.lisp
@@ -107,6 +107,7 @@
     "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
    tries hard to make a pathname that will actually behave as documented,
    despite the peculiarities of each implementation"
+    ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
     (declare (ignorable host device directory name type version defaults))
     (apply 'make-pathname
            (append
@@ -182,12 +183,14 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
     ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
     ;; strings and lists of strings or :unspecific
     ;; But CMUCL decides to die on NIL.
+    ;; MCL has issues with make-pathname, nil and defaulting
+    (declare (ignorable defaults))
     #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
                        :host (or #+cmu lisp::*unix-host*)
                        #+scl ,@'(:scheme nil :scheme-specific-part nil
                                  :username nil :password nil :parameters nil :query nil :fragment nil)
                        ;; the default shouldn't matter, but we really want something physical
-                       :defaults defaults))
+                       #-mcl ,@'(:defaults defaults)))
 
   (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
 
@@ -455,7 +458,7 @@ to throw an error if the pathname is absolute"
                  (make-pathname*
                   :directory (unless file-only (cons relative path))
                   :name name :type type
-                  :defaults (or defaults *nil-pathname*))
+                  :defaults (or #-mcl defaults *nil-pathname*))
                  (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
 
   (defun unix-namestring (pathname)
diff --git a/upgrade.lisp b/upgrade.lisp
index b6ff9a2c..118c392c 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
          ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
          ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
-         (asdf-version "3.0.1.8")
+         (asdf-version "3.0.1.9")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)))
diff --git a/version.lisp-expr b/version.lisp-expr
index a15a5578..546eced2 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"3.0.1.8"
+"3.0.1.9"
-- 
GitLab