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