Commit 3c1c01eb authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

More tweaks and cleanups for GCL.

parent 32c1e741
......@@ -5,8 +5,6 @@
;;(setf *unspecific-pathname-type* nil)
#+gcl (trace compile-file-pathname*)
;;; test asdf pathname specifications
;;;
;;; Originally written by James Anderson, refactored by Francois-Rene Rideau
......@@ -332,7 +330,6 @@
(delete-host t)
(support-string-pathnames nil)
(support-absolute-string-pathnames nil))
#+gcl (format t "root: ~S~%" root)
(unwind-protect
(let ((root-directory-namestring (format nil "~{/~a~}/" (rest (pathname-directory root))))
(test-status (setf *test-status* (make-instance 'test-status)))
......@@ -399,7 +396,6 @@
(asdf:initialize-output-translations)
(format t "output translations: ~S~%" (asdf::output-translations))
#+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*)))
#-xcl ;;---*** pathnames are known to be massively broken on XCL
(progn
;; we're testing with unix, are we not?
......@@ -408,7 +404,6 @@
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t) #p"/foo/bar/baz/")
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t :wilden t) (wilden #p"/foo/bar/baz/"))
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory nil :wilden t) (wilden #p"/foo/bar/"))
#-gcl
(assert-pathname-equal (resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :ensure-directory nil :wilden t) #p"/foo/bar/**/baz/*.*")
(assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-1))))
......
......@@ -12,7 +12,7 @@ usage () {
echo " - quit with exit status >0 if an unhandled error occurs"
echo " you need to supply the .script in the second argument"
echo " lisps include abcl, allegro, allegromodern, ccl (clozure),"
echo " clisp, cmucl, ecl, gcl, gclcvs, sbcl, scl and xcl."
echo " clisp, cmucl, ecl, gcl, sbcl, scl and xcl."
echo "OPTIONS:"
echo " -d -- debug mode"
echo " -h -- show this message."
......@@ -422,9 +422,6 @@ test_clean_load () {
fi
}
test_load_systems () {
case $lisp in
gcl) return 0 ;; # This one is hopeless
esac
cd ${ASDFDIR}
mkdir -p build/results/
echo "Loading all these systems: $*"
......
......@@ -561,7 +561,6 @@ is bound, write a message and exit on an error. If
(register-directory *asdf-directory*)
(register-directory *uiop-directory*)
(register-directory *test-directory*)
(DBG :lalatu (asymval :*central-registry*))
(quietly
(acall :oos (asym :load-op) :uiop))
(acall :oos (asym :load-op) :test-module-depend))
......
......@@ -9,22 +9,24 @@
(:static-file "level2/static.file")
(:static-file "test-tmp.cl")))
(DBG "loading test-system-pathnames")
(load-system 'test-system-pathnames)
(DBG "checking that test-system-pathnames loaded properly")
(assert (find-package :test-package)
() "package test-package not found")
(assert (find-symbol (symbol-name '*file-tmp*) :test-package)
(assert (find-symbol* '*file-tmp* :test-package nil)
() "symbol `*file-tmp*` not found")
(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
(assert (symbol-value (find-symbol* '*file-tmp* :test-package))
() "symbol `*file-tmp*` has wrong value")
(assert (probe-file (test-fasl "sources/level1/file1"))
(assert (probe-file* (test-fasl "sources/level1/file1"))
() "compiled file not found")
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil
"symbol `*file-tmp2*` not found")
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
(assert (find-symbol* '*file-tmp2* :test-package nil)
() "symbol `*file-tmp2*` not found")
(assert (symbol-value (find-symbol* '*file-tmp2* :test-package)
() "symbol `*file-tmp2*` has wrong value")
(assert (probe-file (test-fasl "sources/level1/level2/file2"))
(assert (probe-file* (test-fasl "sources/level1/level2/file2"))
() "compiled file not found")
......@@ -80,12 +80,21 @@
(defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
(unless (use-ecl-byte-compiler-p) (require :cmp)))
#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
#+gcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :ansi-cl *features*)
(error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
(setf compiler::*compiler-default-type* (pathname "")
compiler::*lsp-ext* ""))
compiler::*lsp-ext* "")
#.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
(cond
#+gcl
((or (< system::*gcl-major-version* 2)
(and (= system::*gcl-major-version* 2)
(< system::*gcl-minor-version* 7)))
'(error "GCL 2.7 or later required to use ASDF")))))
(eval code)
code))
#+genera
(eval-when (:load-toplevel :compile-toplevel :execute)
......
......@@ -65,8 +65,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(defun truename* (p)
"Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
;; avoids both logical-pathname merging and physical resolution issues
(and p (handler-case (with-pathname-defaults () (truename p))
(#-gcl file-error #+gcl error () nil))))
(and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
(defun safe-file-write-date (pathname)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
......@@ -97,24 +96,26 @@ or the original (parsed) pathname if it is false (the default)."
(or
#+allegro
(probe-file p :follow-symlinks truename)
#-(or allegro clisp)
#+gcl
(if truename
(probe-file p)
(ignore-errors
(let ((pp (physicalize-pathname p)))
(and
#+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
#+(and lispworks unix) (system:get-file-stat pp)
#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
p))))
#+(or clisp gcl)
(truename* p)
(let ((kind (car (si::stat p))))
(when (eq kind :link)
(setf kind (ignore-errors (car (si::stat (truename* p))))))
(ecase kind
((nil) nil)
((:file :link)
(cond
((file-pathname-p p) p)
((directory-pathname-p p)
(subpathname p (car (last (pathname-directory p)))))))
(:directory (ensure-directory-pathname p)))))
#+clisp
#.(flet ((probe (probe)
`(let ((foundtrue ,probe))
(cond
(truename foundtrue)
(foundtrue p)))))
#+clisp
(let* ((fs (find-symbol* '#:file-stat :posix nil))
(pp (find-symbol* '#:probe-pathname :ext nil))
(resolve (if pp
......@@ -125,11 +126,19 @@ or the original (parsed) pathname if it is false (the default)."
`(if truename
,resolve
(and (ignore-errors (,fs p)) p))
(probe resolve)))
#+gcl
(probe '(or (probe-file p)
(truename* (ensure-directory-pathname p))))))
(#-gcl file-error #+gcl error () nil)))))))
(probe resolve))))
#-(or allegro clisp gcl)
(if truename
(probe-file p)
(ignore-errors
(let ((pp (physicalize-pathname p)))
(and
#+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
#+(and lispworks unix) (system:get-file-stat pp)
#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
p)))))
(file-error () nil)))))))
(defun directory-exists-p (x)
"Is X the name of a directory that exists on the filesystem?"
......@@ -533,7 +542,7 @@ in an atomic way if the implementation allows."
(defun delete-file-if-exists (x)
"Delete a file X if it already exists"
(when x (handler-case (delete-file x) (#-gcl file-error #+gcl error () nil))))
(when x (handler-case (delete-file x) (file-error () nil))))
(defun delete-empty-directory (directory-pathname)
"Delete an empty directory"
......
......@@ -572,7 +572,7 @@ possibly in a different process. Otherwise just call THUNK."
(defun load-pathname ()
"Portably return the LOAD-PATHNAME of the current source file or fasl"
*load-pathname*) ;; see magic for GCL in uiop/common-lisp
*load-pathname*) ;; magic no longer needed for GCL.
(defun lispize-pathname (input-file)
"From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
......@@ -591,7 +591,7 @@ possibly in a different process. Otherwise just call THUNK."
(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
"Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
(let* ((keys
(remove-plist-keys `(#+(or (and allegro (not (version>= 8 2))) gcl) :external-format
(remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
,@(unless output-file '(:output-file))) keys)))
(if (absolute-pathname-p output-file)
;; what cfp should be doing, w/ mp* instead of mp
......@@ -629,7 +629,7 @@ it will filter them appropriately."
'compile-file* output-file object-file)
(rotatef output-file object-file))
(let* ((keywords (remove-plist-keys
`(:output-file :compile-check :warnings-file #+gcl :external-format
`(:output-file :compile-check :warnings-file
#+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
(output-file
(or output-file
......
......@@ -255,7 +255,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(strcat (nth-value 1 (unix:unix-current-directory)) "/"))
#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
#+ecl (ext:getcwd)
#+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
#+gcl (let ((*default-pathname-defaults* *nil-pathname*)) (truename *nil-pathname*))
#+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
#+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd)
......
......@@ -749,19 +749,7 @@ UNINTERN -- Remove symbols here from PACKAGE."
#+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car))
#.(progn
;; What more, the compiler doesn't look like it's doing eval-when quite like we'd like,
;; so we do this essential feature thing at read-time instead.
#+gcl ;; Only support very recent GCL 2.7.0 from November 2013 or later.
(let ((code ;; Old ASDF 2.011 might run on GCL 2.7.0. Or not.
(cond
((or (< system::*gcl-major-version* 2)
(and (= system::*gcl-major-version* 2)
(< system::*gcl-minor-version* 7)))
'(error "GCL 2.7 or later required to use ASDF")))))
(eval code)
code)))
:test 'equalp :key 'car)))
;; Compatibility with whoever calls asdf/package
(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment