Commit c5f0c70d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Further remove support for GCL 2.6 from UIOP and tests.

Everyone should be using a recent 2.7.0 (in ANSI mode) from master for ASDF.
parent 64841b55
......@@ -345,7 +345,6 @@
(format nil "results/~(~A~)-pathnames.text" *implementation*))
:direction :output
:if-exists :supersede :if-does-not-exist :create)
#-gcl2.6
(setup-asdftest-logical-host :root root)
(multiple-value-bind (systems modules files test-files)
(make-test-files
......@@ -401,7 +400,7 @@
(format t "output translations: ~S~%" (asdf::output-translations))
#+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*)))
#-(or xcl gcl2.6) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
#-xcl ;;---*** pathnames are known to be massively broken on XCL
(progn
;; we're testing with unix, are we not?
(assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname)))
......
......@@ -68,12 +68,10 @@ Some constraints:
#+lispworks
(setf system:*stack-overflow-behaviour* :warn))
#+(or gcl2.6 genera)
#+genera
(unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path)
#+genera (fs:create-directories-recursively (pathname path))
#+gcl2.6 (lisp:system (format nil "mkdir -p ~S"
(namestring (make-pathname :name nil :type nil :defaults path))))))
#+genera (fs:create-directories-recursively (pathname path))))
;;; Survival utilities
(defun asym (name &optional package errorp)
......@@ -88,7 +86,7 @@ Some constraints:
(defun ucall (name &rest args) (apply (asym name :uiop) args))
(defun asymval (name &optional package)
(symbol-value (asym name package)))
(defsetf asymval (name &optional package) (new-value) ;; NB: defun setf won't work on GCL2.6
(defsetf asymval (name &optional package) (new-value)
(let ((sym (gensym "SYM")))
`(let ((,sym (asym ,name ,package)))
(if ,sym
......@@ -252,7 +250,7 @@ Some constraints:
(if (and (asymval :*asdf-cache*) (not in-filesystem))
(acall :register-file-stamp file stamp)
(multiple-value-bind (sec min hr day month year)
(decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime
(decode-universal-time stamp)
(unless in-filesystem
(error "Y U NO use stamp cache?"))
(ucall :run-program
......@@ -277,7 +275,7 @@ Some constraints:
#+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
#+gcl (#+gcl2.6 lisp:quit #-gcl2.6 system:quit code)
#+gcl (system: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) ?
......@@ -434,7 +432,6 @@ is bound, write a message and exit on an error. If
(defun compile-asdf-script ()
(with-test ()
#-gcl2.6
(ecase (with-asdf-conditions () (maybe-compile-asdf))
(:not-found
(leave-test "Testsuite failed: unable to find ASDF source" 3))
......@@ -570,7 +567,6 @@ is bound, write a message and exit on an error. If
(acall :oos (asym :load-op) :test-module-depend))
(defun load-asdf (&optional tag)
#+gcl2.6 (load-asdf-lisp tag) #-gcl2.6
(load-asdf-fasl tag)
(configure-asdf))
......
......@@ -2,8 +2,6 @@
(in-package :asdf)
#+gcl2.6 (leave-test "GCL 2.6 sucks. Skipping test." 0)
(assert (handler-case
(let ((*compile-file-failure-behaviour* :warn))
(load-system 'test-compile-file-failure :force t)
......
......@@ -2,7 +2,6 @@
(in-package :asdf)
(use-package :asdf-test)
#+gcl2.6 (defmacro with-standard-io-syntax (&body body) `(progn ,@body))
(defparameter *tmp-directory* (subpathname *asdf-directory* "build/"))
(setf *central-registry* nil)
......
;;; -*- Lisp -*-
#+gcl2.6 (leave-test "GCL 2.6 doesn't do Logical pathnames" 0)
(setf (logical-pathname-translations "ASDF")
#+(or allegro clisp)
`(("**;*.*.*" ,(asdf::wilden *asdf-directory*)))
......
;;; -*- Lisp -*-
(load (subpathname *asdf-directory* "contrib/wild-modules.lisp"))
(progn
(load (asdf::subpathname *asdf-directory* "contrib/wild-modules.lisp"))
(def-test-system :wild-module
:version "0.0"
:components ((:wild-module "systems" :pathname #p"*.asd")))
#-gcl2.6
(load-system :wild-module))
(def-test-system :wild-module
:version "0.0"
:components ((:wild-module "systems" :pathname #p"*.asd")))
(load-system :wild-module)
......@@ -17,8 +17,6 @@
(:export
#:logical-pathname #:translate-logical-pathname
#:make-broadcast-stream #:file-namestring)
#+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
#+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
#+genera (:shadowing-import-from :scl #:boolean)
#+genera (:export #:boolean #:ensure-directories-exist)
#+mcl (:shadow #:user-homedir-pathname))
......@@ -89,42 +87,6 @@
(setf compiler::*compiler-default-type* (pathname "")
compiler::*lsp-ext* ""))
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
(shadow 'type-of :uiop/common-lisp)
(shadowing-import 'system:*load-pathname* :uiop/common-lisp))
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
(export 'type-of :uiop/common-lisp)
(export 'system:*load-pathname* :uiop/common-lisp))
#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *gcl2.6* t)
(deftype logical-pathname () nil)
(defun type-of (x) (class-name (class-of x)))
(defun wild-pathname-p (path) (declare (ignore path)) nil)
(defun translate-logical-pathname (x) x)
(defvar *compile-file-pathname* nil)
(defun pathname-match-p (in-pathname wild-pathname)
(declare (ignore in-wildname wild-wildname)) nil)
(defun translate-pathname (source from-wildname to-wildname &key)
(declare (ignore from-wildname to-wildname)) source)
(defun %print-unreadable-object (object stream type identity thunk)
(format stream "#<~@[~S ~]" (when type (type-of object)))
(funcall thunk)
(format stream "~@[ ~X~]>" (when identity (system:address object))))
(defmacro with-standard-io-syntax (&body body)
`(progn ,@body))
(defmacro with-compilation-unit (options &body body)
(declare (ignore options)) `(progn ,@body))
(defmacro print-unreadable-object ((object stream &key type identity) &body body)
`(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
(defun ensure-directories-exist (path)
(lisp:system (format nil "mkdir -p ~S"
(namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
#+genera
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (fboundp 'ensure-directories-exist)
......@@ -206,5 +168,5 @@ Return a string made of the parts not omitted or emitted by FROB."
(defmacro compatfmt (format)
#+(or gcl genera)
(frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
(frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format))
......@@ -96,7 +96,7 @@ or the original (parsed) pathname if it is false (the default)."
(or
#+allegro
(probe-file p :follow-symlinks truename)
#-(or allegro clisp gcl2.6)
#-(or allegro clisp)
(if truename
(probe-file p)
(ignore-errors
......@@ -107,19 +107,12 @@ or the original (parsed) pathname if it is false (the default)."
#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
p))))
#+(or clisp gcl2.6)
#+clisp
#.(flet ((probe (probe)
`(let ((foundtrue ,probe))
(cond
(truename foundtrue)
(foundtrue p)))))
#+gcl2.6
(probe '(or (probe-file p)
(and (directory-pathname-p p)
(ignore-errors
(ensure-directory-pathname
(truename* (subpathname
(ensure-directory-pathname p) ".")))))))
#+clisp
(let* ((fs (find-symbol* '#:file-stat :posix nil))
(pp (find-symbol* '#:probe-pathname :ext nil))
......
......@@ -630,8 +630,7 @@ it will filter them appropriately."
(rotatef output-file object-file))
(let* ((keywords (remove-plist-keys
`(:output-file :compile-check :warnings-file
#+clisp :lib-file #+(or ecl mkcl) :object-file
#+gcl2.6 ,@'(:external-format :print :verbose)) keys))
#+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
(output-file
(or output-file
(apply 'compile-file-pathname* input-file :output-file output-file keywords)))
......@@ -701,13 +700,12 @@ it will filter them appropriately."
(defun load* (x &rest keys &key &allow-other-keys)
"Portable wrapper around LOAD that properly handles loading from a stream."
(etypecase x
((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
(apply 'load x
#-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys)))
;; GCL 2.6, Genera can't load from a string-input-stream
((or pathname string #-(or allegro clozure genera) stream)
(apply 'load x keys))
;; Genera can't load from a string-input-stream
;; ClozureCL 1.6 can only load from file input stream
;; Allegro 5, I don't remember but it must have been broken when I tested.
#+(or allegro clozure gcl2.6 genera)
#+(or allegro clozure genera)
(stream ;; make do this way
(let ((*package* *package*)
(*readtable* *readtable*)
......
......@@ -578,7 +578,7 @@ or when loading the package is optional."
import-from export intern
recycle mix reexport
unintern)
#+(or gcl2.6 genera) (declare (ignore documentation))
#+genera (declare (ignore documentation))
(let* ((package-name (string name))
(nicknames (mapcar #'string nicknames))
(names (cons package-name nicknames))
......@@ -600,7 +600,7 @@ or when loading the package is optional."
;; string to list home package and use package:
(inherited (make-hash-table :test 'equal)))
(when-package-fishiness (record-fishy package-name))
#-(or gcl2.6 genera)
#-genera
(when documentation (setf (documentation package t) documentation))
(loop :for p :in (set-difference (package-use-list package) (append mix use))
:do (note-package-fishiness :over-use name (package-names p))
......@@ -751,24 +751,15 @@ UNINTERN -- Remove symbols here from PACKAGE."
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car))
#.(progn
;; Debian's antique GCL 2.7.0 has bugs with compiling multiple-value stuff,
;; but can run ASDF 2.011. Its GCL 2.6.7 has even more issues.
;; 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
(let ((code
#+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* 6)))
'(error "GCL 2.6 or later required to use ASDF"))
((and (= system::*gcl-major-version* 2)
(= system::*gcl-minor-version* 6))
'(progn
(pushnew 'ignorable pcl::*variable-declarations-without-argument*)
(pushnew :gcl2.6 *features*)))
(t
'(pushnew :gcl2.7 *features*)))))
(< system::*gcl-minor-version* 7)))
'(error "GCL 2.7 or later required to use ASDF")))))
(eval code)
code)))
......
......@@ -47,33 +47,19 @@
"Convert the DIRECTORY component from a format usable by the underlying
implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
that is a list and not a string."
#+gcl2.6 (setf directory (substitute :back :parent directory))
(cond
#-(or cmu sbcl scl) ;; these implementations already normalize directory components.
((stringp directory) `(:absolute ,directory))
#+gcl2.6
((and (consp directory) (eq :root (first directory)))
`(:absolute ,@(rest directory)))
((or (null directory)
(and (consp directory) (member (first directory) '(:absolute :relative))))
directory)
#+gcl2.6
((consp directory)
`(:relative ,@directory))
(t
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
(defun denormalize-pathname-directory-component (directory-component)
"Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
by the underlying implementation's MAKE-PATHNAME and other primitives"
#-gcl2.6 directory-component
#+gcl2.6
(let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
directory-component)))
(cond
((and (consp d) (eq :relative (first d))) (rest d))
((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
(t d))))
directory-component)
(defun merge-pathname-directory-components (specified defaults)
"Helper for MERGE-PATHNAMES* that handles directory components"
......@@ -106,7 +92,7 @@ by the underlying implementation's MAKE-PATHNAME and other primitives"
#+(or clisp ecl gcl #|These haven't been tested:|# cormanlisp mcl) nil
"Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
(defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
(defun make-pathname* (&rest keys &key (directory nil)
host (device () #+allegro devicep) name type version defaults
#+scl &allow-other-keys)
"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
......@@ -117,9 +103,6 @@ by the underlying implementation's MAKE-PATHNAME and other primitives"
(apply 'make-pathname
(append
#+allegro (when (and devicep (null device)) `(:device :unspecific))
#+gcl2.6
(when directoryp
`(:directory ,(denormalize-pathname-directory-component directory)))
keys)))
(defun make-pathname-component-logical (x)
......@@ -613,9 +596,9 @@ with a format control-string and other arguments as arguments"
(with-upgradability ()
(defparameter *wild* (or #+cormanlisp "*" :wild)
"Wild component for use with MAKE-PATHNAME")
(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)
(defparameter *wild-directory-component* (or :wild)
"Wild directory component for use with MAKE-PATHNAME")
(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)
(defparameter *wild-inferiors-component* (or :wild-inferiors)
"Wild-inferiors directory component for use with MAKE-PATHNAME")
(defparameter *wild-file*
(make-pathname :directory nil :name *wild* :type *wild*
......
......@@ -170,14 +170,14 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function."))
#-(or gcl2.6 genera)
#-genera
(defmethod slurp-input-stream ((function function) input-stream &key)
(funcall function input-stream))
(defmethod slurp-input-stream ((list cons) input-stream &key)
(apply (first list) input-stream (rest list)))
#-(or gcl2.6 genera)
#-genera
(defmethod slurp-input-stream ((output-stream stream) input-stream
&key linewise prefix (element-type 'character) buffer-size)
(copy-stream-to-stream
......@@ -237,9 +237,9 @@ Programmers are encouraged to define their own methods for this generic function
&key linewise prefix (element-type 'character) buffer-size)
(declare (ignorable stream linewise prefix element-type buffer-size))
(cond
#+(or gcl2.6 genera)
#+genera
((functionp x) (funcall x stream))
#+(or gcl2.6 genera)
#+genera
((output-stream-p x)
(copy-stream-to-stream
stream x
......@@ -267,14 +267,14 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function."))
#-(or gcl2.6 genera)
#-genera
(defmethod vomit-output-stream ((function function) output-stream &key)
(funcall function output-stream))
(defmethod vomit-output-stream ((list cons) output-stream &key)
(apply (first list) output-stream (rest list)))
#-(or gcl2.6 genera)
#-genera
(defmethod vomit-output-stream ((input-stream stream) output-stream
&key linewise prefix (element-type 'character) buffer-size)
(copy-stream-to-stream
......@@ -316,9 +316,9 @@ Programmers are encouraged to define their own methods for this generic function
&key linewise prefix (element-type 'character) buffer-size)
(declare (ignorable stream linewise prefix element-type buffer-size))
(cond
#+(or gcl2.6 genera)
#+genera
((functionp x) (funcall x stream))
#+(or gcl2.6 genera)
#+genera
((input-stream-p x)
(copy-stream-to-stream
x stream
......@@ -774,7 +774,7 @@ It returns a process-info plist with possible keys:
(*standard-output* *stdout*)
(*error-output* *stderr*))
(ext:system %command))
#+gcl (#+gcl2.6 lisp:system #-gcl2.6 system:system %command)
#+gcl (system:system %command)
#+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
#+mkcl ;; PROBABLY BOGUS -- ask jcb
(multiple-value-bind (io process exit-code)
......
......@@ -224,10 +224,9 @@ as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
(if-does-not-exist :error))
"Open FILE for input with given recognizes options, call THUNK with the resulting stream.
Other keys are accepted but discarded."
#+gcl2.6 (declare (ignore external-format))
(with-open-file (s pathname :direction :input
:element-type element-type
#-gcl2.6 :external-format #-gcl2.6 external-format
:external-format external-format
:if-does-not-exist if-does-not-exist)
(funcall thunk s)))
......@@ -245,10 +244,9 @@ Other keys are accepted but discarded."
(if-does-not-exist :create))
"Open FILE for input with given recognizes options, call THUNK with the resulting stream.
Other keys are accepted but discarded."
#+gcl2.6 (declare (ignore external-format))
(with-open-file (s pathname :direction :output
:element-type element-type
#-gcl2.6 :external-format #-gcl2.6 external-format
:external-format external-format
:if-exists if-exists
:if-does-not-exist if-does-not-exist)
(funcall thunk s)))
......@@ -528,8 +526,7 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(defun setup-temporary-directory ()
"Configure a default temporary directory to use."
(setf *temporary-directory* (default-temporary-directory))
;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
#+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
#+gcl (setf system::*tmp-dir* *temporary-directory*))
(defun call-with-temporary-file
(thunk &key
......@@ -541,7 +538,6 @@ If a string, repeatedly read and evaluate from it, returning the last values."
The pathname will be based on appending a random suffix to PREFIX.
This utility will KEEP the file past its extent if and only if explicitly requested.
The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT."
#+gcl2.6 (declare (ignorable external-format))
(check-type direction (member :output :io))
(assert (or want-stream-p want-pathname-p))
(loop
......@@ -558,7 +554,7 @@ The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT
(with-open-file (stream pathname
:direction direction
:element-type element-type
#-gcl2.6 :external-format #-gcl2.6 external-format
:external-format external-format
:if-exists nil :if-does-not-exist :create)
(when stream
(setf okp pathname)
......
......@@ -53,7 +53,7 @@
(fmakunbound function-spec))
((and (consp function-spec) (eq (car function-spec) 'setf)
(consp (cdr function-spec)) (null (cddr function-spec)))
#-gcl2.6 (fmakunbound function-spec))
(fmakunbound function-spec))
(t (error "bad function spec ~S" function-spec))))
(defun undefine-functions (function-spec-list)
(map () 'undefine-function function-spec-list))
......@@ -86,9 +86,7 @@
(destructuring-bind (car . cdr) form
(case car
((defun) `(defun* ,@cdr))
((defgeneric)
(unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
`(defgeneric* ,@cdr)))
((defgeneric) `(defgeneric* ,@cdr))
(otherwise form)))
form)))))
......@@ -328,7 +326,6 @@ the two results passed to STRCAT always reconstitute the original string"
(defun find-class* (x &optional (errorp t) environment)
(etypecase x
((or standard-class built-in-class) x)
#+gcl2.6 (keyword nil)
(symbol (find-class x errorp environment)))))
......
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