Skip to content
Snippets Groups Projects
Commit 3c1c01eb authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

More tweaks and cleanups for GCL.

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