From 2f979dc53ca6d4545d41cfc11e02bba602a22297 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 19 Dec 2013 21:04:03 -0500
Subject: [PATCH] Support XCL again, by working around implementation bugs,
 documented in TODO.

---
 Makefile                       |  4 +-
 TODO                           | 18 ++++-----
 find-system.lisp               | 11 +++---
 test/asdf-pathname-test.script | 69 +++++++++++++++++++++-------------
 test/test-run-program.script   |  1 +
 uiop/image.lisp                | 12 +++---
 uiop/run-program.lisp          |  5 ++-
 uiop/stream.lisp               |  5 ++-
 8 files changed, 70 insertions(+), 55 deletions(-)

diff --git a/Makefile b/Makefile
index 7a0bd33f..e01e76bd 100644
--- a/Makefile
+++ b/Makefile
@@ -10,13 +10,13 @@ sourceDirectory := $(shell pwd)
 ifdef ASDF_TEST_LISPS
 lisps ?= ${ASDF_TEST_LISPS}
 else
-lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern gcl
+lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern gcl xcl
 endif
 ## NOT SUPPORTED BY OUR AUTOMATED TESTS:
 ##	cormancl genera lispworks-personal-edition mkcl rmcl
 ## Some are manually tested once in a while.
 ## FAIL: gcl -- most implementation bugs are now fixed, but some remain. See TODO.
-## FAIL: xcl -- implementation bugs now prevent ASDF3 from working at all. See TODO.
+## FAIL: xcl -- implementation bugs require lots of papering over during tests. See TODO.
 ## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
 ifdef ASDF_TEST_SYSTEMS
 s ?= ${ASDF_TEST_SYSTEMS}
diff --git a/TODO b/TODO
index de31a040..f0e0bb5e 100644
--- a/TODO
+++ b/TODO
@@ -19,21 +19,21 @@
 ** Modify SBCL and other implementations so they provide UIOP
    independently from ASDF?
 
-* XCL is no longer supported due to an implementation bug:
-  the return in search-for-system-definition fails to return from the
-  (block nil ...) and seems to mistakenly return from
-  some implicit internal block.
-  TODO: either get it fixed, or provide a workaround in uiop/common-lisp.
-  In the meantime, XCL is officially not supported anymore.
-  XCL also has a bug in make-pathname, and probably other bugs;
-  it takes a long time for errors to propagate to the REPL —
+* XCL has bad bugs:
+  make-pathname doesn't handle :type nil properly and
+  has massive lossage in logical-pathname support.
+  If using block () and return in search-for-system-definition
+  instead of return-from, XCL mistakenly has the return jump
+  to the end of the try function or something.
+  It also takes a long time for errors to propagate into a debugging REPL —
   Maybe O(n^3) behavior or worse in walking the C++ stack?
+  The backtrace frames may contains unprintable objects.
 
 * GCL is almost working again; but implementation bugs remain.
   See November 2013 discussion on gcl-devel
 
 * Some out-of-line configuration mechanism for various options?
-   i.e. have files that override some variables around compilation of some systems.
+  i.e. let configuration files override some variables around compilation of some systems.
 
 * Find an easier way to bind variables around compilation and loading of files
 
diff --git a/find-system.lisp b/find-system.lisp
index f4a0177e..9606712c 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -137,12 +137,11 @@ called with an object of type asdf:system."
   (cleanup-system-definition-search-functions)
 
   (defun search-for-system-definition (system)
-    (block ()
-      (let ((name (coerce-name system)))
-        (flet ((try (f) (if-let ((x (funcall f name))) (return x))))
-          (try 'find-system-if-being-defined)
-          (map () #'try *system-definition-search-functions*)
-          (try 'sysdef-preloaded-system-search)))))
+    (let ((name (coerce-name system)))
+      (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
+        (try 'find-system-if-being-defined)
+        (map () #'try *system-definition-search-functions*)
+        (try 'sysdef-preloaded-system-search))))
 
   (defvar *central-registry* nil
     "A list of 'system directory designators' ASDF uses to find systems.
diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script
index 677dfba2..0da4ca3b 100644
--- a/test/asdf-pathname-test.script
+++ b/test/asdf-pathname-test.script
@@ -3,6 +3,10 @@
 (defpackage :asdf-pathname-test (:use :asdf :uiop :uiop/common-lisp :asdf/cache :asdf-test))
 (in-package :asdf-pathname-test)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  #-xcl (push :asdf-test-logical-pathname *features*)
+  #+xcl (push :buggy-untyped-file *features*))
+
 ;;(setf *unspecific-pathname-type* nil)
 
 ;;; test asdf pathname specifications
@@ -37,6 +41,8 @@
 ;;; (:static-file "module1-1/file3.lisp") means #p"module1-1/file3.lisp"
 
 (defun setup-asdftest-logical-host (&key (root *build-directory*) (bin-type (compile-file-type)))
+  (declare (ignorable root bin-type))
+  #+asdf-test-logical-pathname
   (setf (logical-pathname-translations "ASDFTEST")
         `((,(format nil "**;*.~a" bin-type)
            ,(subpathname root (make-pathname :directory '(:relative :wild-inferiors)
@@ -74,8 +80,8 @@
        :components
        ((:file "file" :pathname ,file-pathname)
         (:file "module2/file" :pathname ,file-pathname)
-        ,@(unless (or (typep system-pathname 'logical-pathname)
-                      (typep module-pathname 'logical-pathname))
+        ,@(unless (or (logical-pathname-p system-pathname)
+                      (logical-pathname-p module-pathname))
             `((:file "typed-file.type" :pathname ,file-pathname)
               (:static-file "static-file.type" :pathname ,file-pathname)
               (:file "module2/typed-file.type" :pathname ,file-pathname)
@@ -105,22 +111,24 @@
       success)))
 
 (defparameter *backtraces* 0)
-(defparameter *max-backtraces* 4)
+(defparameter *max-backtraces* 10)
 
 (defun test-file (file &key configuration (test-status *test-status*) (start-time 0))
   (with-slots (system-count directory-count file-count
                system-failures directory-failures file-failures all-tests) test-status
     (let ((success
-            (block nil
+            (block :foo
               (handler-bind ((error #'(lambda (c)
                                         (incf *backtraces*)
                                         (dolist (o (list *trace-output*))
                                           (format o "BACKTRACES: ~S (max ~S)~%"
                                                   *backtraces* *max-backtraces*)
                                           (when (<= *backtraces* *max-backtraces*)
-                                            (print-condition-backtrace c :stream o)))
-                                        (return nil))))
-                (assert (probe-file* (component-pathname file)))
+                                            #+xcl (safe-format! stream "~&Condition:~%~A~&" c)
+                                            #-xcl (print-condition-backtrace c :stream o)))
+                                        (return-from :foo nil))))
+                (assert (probe-file* (component-pathname file)) ()
+                        "Can't find pathname ~S for component ~S" (component-pathname file) file)
                 (with-open-file (stream (component-pathname file)
                                         :direction :output :if-exists
                                         (or #+(and sbcl os-windows) :rename-and-delete :supersede)
@@ -188,6 +196,7 @@
                                            :untouched)
                                        :missing)))
                     test-files))
+    #+asdf-test-logical-pathname
     (format result-stream "~&~%~% translations: ~a: ~s" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
     (format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
             systems modules files)
@@ -228,8 +237,9 @@
                           (root-directory-namestring (namestring root)))
   (let ((systems
           `(,(subpathname root "asdf-src/system1/")
-            ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1"))
-            ,(parse-namestring "ASDFTEST:system1;")
+            #+asdf-test-logical-pathname
+            ,@'(,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1"))
+                ,(parse-namestring "ASDFTEST:system1;"))
             ,@(when support-string-pathnames
                 `(,(format nil "~{/~a~}/asdf-src/system1" (rest (pathname-directory root)))))))
         (modules
@@ -238,9 +248,10 @@
             ,(make-pathname :directory '(:relative "module2") :name nil :type nil)
             ,(make-pathname :directory '(:relative "module2" "module3") :name nil :type nil)
             ,(subpathname root "asdf-src/system2/module4/")
-            ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4")
-                            :name nil :type nil)
-            ,(parse-namestring "ASDFTEST:system2;module4;")
+            #+asdf-test-logical-pathname
+            ,@'(,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4")
+                                :name nil :type nil)
+                ,(parse-namestring "ASDFTEST:system2;module4;"))
             ,@(when support-string-pathnames
                 `(""
                   "module2"
@@ -255,23 +266,24 @@
                         ,(strcat root-directory-namestring "asdf-src/system2/module4/")))))))
         (files
           `(nil
-            ,(parse-unix-namestring "./untyped-file")
-            ,(parse-unix-namestring "file")
+            #-buggy-untyped-file ,(parse-unix-namestring "./untyped-file")
+            #-buggy-untyped-file ,(parse-unix-namestring "file")
             ,(parse-unix-namestring "./file.lisp")
             ,(parse-unix-namestring "typed-file.type")
-            ,(parse-unix-namestring "module2/untyped-file")
+            #-buggy-untyped-file ,(parse-unix-namestring "module2/untyped-file")
             ,(parse-unix-namestring "module2/file.lisp")
             ,(parse-unix-namestring "module2/module3/file.lisp")
-            ,(subpathname root "asdf-src/system1/module1/untyped-file")
+            #-buggy-untyped-file ,(subpathname root "asdf-src/system1/module1/untyped-file")
             ,(subpathname root "asdf-src/system1/module1/file.lisp")
-            ,(subpathname root "asdf-src/system1/module2/untyped-file")
+            #-buggy-untyped-file ,(subpathname root "asdf-src/system1/module2/untyped-file")
             ,(subpathname root "asdf-src/system1/module2/file.lisp")
             ,(subpathname root "asdf-src/system1/module2/module3/file.lisp")
             ,(subpathname root "asdf-src/system2/module4/file.lisp")
-            ,(make-pathname :host "ASDFTEST" :device nil
-                            :directory '(:absolute "system2" "module4")
-                            :name "file" :type "lisp" :version nil)
-            ,(parse-namestring "ASDFTEST:system2;module4;file.lisp")
+            #+asdf-test-logical-pathname
+            ,@'(,(make-pathname :host "ASDFTEST" :device nil
+                                :directory '(:absolute "system2" "module4")
+                                :name "file" :type "lisp" :version nil)
+                ,(parse-namestring "ASDFTEST:system2;module4;file.lisp"))
             ,@(when support-string-pathnames
                 `(,(strcat root-directory-namestring "asdf-src/system1/module1/file.lisp")))))
         (test-files
@@ -290,11 +302,13 @@
                                          (src-dir "system1" "module2" "module3")
                                          (src-dir "system2" "module4")))
                    ;; :pathname #p"untyped-file"
+                   #-buggy-untyped-file #-buggy-untyped-file
                    collect (make-pathname :directory directory :name "untyped-file" :type nil
                                           :defaults root)
                    ;; :file "file"
                    collect (make-pathname :directory directory :name "file" :type "lisp"
                                           :defaults root)     ; for source files
+                   #-buggy-untyped-file #-buggy-untyped-file
                    collect (make-pathname :directory directory :name "file" :type nil
                                           :defaults root)        ; for static files
                                                                  ;; :file "typed-file.type"
@@ -311,12 +325,13 @@
                    ;; :file "module2/typed-file.type"
                    collect (make-pathname :directory directory :name "typed-file.type" :type "lisp"
                                           :defaults root)          ; for source files
-                                                                   ;;collect (make-pathname :directory directory :name "typed-file.type" :type nil)          ; for static files ;; invalid as static file, unlike the below.
-                                                                   ;; :static-file "module2/static-file.type"
+                   ;; collect (make-pathname :directory directory :name "typed-file.type" :type nil)          ; for static files ;; invalid as static file, unlike the below.
+                   ;; :static-file "module2/static-file.type"
                    collect (make-pathname :directory directory :name "static-file" :type "type"
                                           :defaults root)
 
                                      ;;; source file pathname variations
+                   #-buggy-untyped-file #-buggy-untyped-file
                    collect (make-pathname :directory (append directory '("module2")) :name  "untyped-file" :type nil
                                           :defaults root)
                    collect (make-pathname :directory (append directory '("module2")) :name  "file" :type "lisp"
@@ -396,16 +411,16 @@
                 :modules modules
                 :systems systems)))))
 
-           (when delete-host
-             (setf (logical-pathname-translations "ASDFTEST") nil))
-           (clear-system "test-system")))
+    #+asdf-test-logical-pathname
+    (when delete-host
+      (setf (logical-pathname-translations "ASDFTEST") nil))
+    (clear-system "test-system")))
 
 (asdf:initialize-source-registry)
 (format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*))
 (asdf:initialize-output-translations)
 (format t "output translations: ~S~%" (asdf::output-translations))
 
-;;#-xcl ;;---*** pathnames are known to be massively broken on XCL
 (progn
   ;; we're testing with unix or some emulation, are we not?
   (assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname)))
diff --git a/test/test-run-program.script b/test/test-run-program.script
index 1c4696b0..76b1dc62 100644
--- a/test/test-run-program.script
+++ b/test/test-run-program.script
@@ -11,6 +11,7 @@
       (return (subseq x 0 (1- (length x)))))
     x))
 
+
 (DBG "Testing echo ok 1 via run-program as a list")
 (assert-equal "ok 1"
               (dewindowize (run-program '("echo" "ok" "1") :output '(:string :stripped t))))
diff --git a/uiop/image.lisp b/uiop/image.lisp
index c62f107f..ace1df4a 100644
--- a/uiop/image.lisp
+++ b/uiop/image.lisp
@@ -93,9 +93,10 @@ This is designed to abstract away the implementation specific quit forms."
   (defun raw-print-backtrace (&key (stream *debug-io*) count)
     "Print a backtrace, directly accessing the implementation"
     (declare (ignorable stream count))
-    #+abcl
-    (dolist (frame (sys:backtrace))
-      (println frame stream))
+    #+(or abcl xcl)
+    (loop :for i :from 0
+          :for frame :in #+abcl (sys:backtrace) #+xcl (extensions:backtrace-as-list) :do
+      (safe-format! stream "~&~D: ~S~%" i frame))
     #+allegro
     (let ((*terminal-io* stream)
           (*standard-output* stream)
@@ -135,10 +136,7 @@ This is designed to abstract away the implementation specific quit forms."
     #+sbcl
     (sb-debug:backtrace
      #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
-     stream)
-    #+xcl
-    (dolist (frame (extensions:backtrace-as-list))
-      (println frame stream)))
+     stream))
 
   (defun print-backtrace (&rest keys &key stream count)
     "Print a backtrace"
diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp
index 1950bcca..f511b78c 100644
--- a/uiop/run-program.lisp
+++ b/uiop/run-program.lisp
@@ -777,7 +777,7 @@ It returns a process-info plist with possible keys:
       (system:call-system %command :current-directory directory :wait t)
       #-(and lispworks os-windows)
       (with-current-directory ((unless (os-unix-p) directory))
-        #+(or abcl xcl) (ext:run-shell-command %command)
+        #+abcl (ext:run-shell-command %command)
         #+clisp (clisp-exit-code (ext:shell %command))
         #+cormanlisp (win32:system %command)
         #+ecl (let ((*standard-input* *stdin*)
@@ -790,7 +790,8 @@ It returns a process-info plist with possible keys:
         (multiple-value-bind (io process exit-code)
             (mkcl:run-program #+windows %command #+windows ()
                               #-windows "/bin/sh" #-windows (list "-c" %command)
-                              :input t :output t)))))
+                              :input t :output t))
+        #+xcl (system:%run-shell-command %command))))
 
   (defun %use-system (command &rest keys
                       &key input output error-output ignore-error-status &allow-other-keys)
diff --git a/uiop/stream.lisp b/uiop/stream.lisp
index 279f6901..c4b0d29a 100644
--- a/uiop/stream.lisp
+++ b/uiop/stream.lisp
@@ -535,13 +535,14 @@ If a string, repeatedly read and evaluate from it, returning the last values."
   (defun call-with-temporary-file
       (thunk &key
                (want-stream-p t) (want-pathname-p t) (direction :io) keep after
-               directory prefix suffix type
+               directory prefix suffix (type ".tmp")
                (element-type *default-stream-element-type*)
                (external-format *utf-8-external-format*))
     "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
 
 The temporary file's pathname will be based on concatenating
-PREFIX (defaults to \"tmp\"), a random alphanumeric string, and optional SUFFIX and TYPE,
+PREFIX (defaults to \"uiop\"), a random alphanumeric string,
+and optional SUFFIX and TYPE (defaults to \".tmp\"),
 within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
 
 The file will be open with specified DIRECTION (defaults to :IO),
-- 
GitLab