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

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 @@ ...@@ -345,7 +345,6 @@
(format nil "results/~(~A~)-pathnames.text" *implementation*)) (format nil "results/~(~A~)-pathnames.text" *implementation*))
:direction :output :direction :output
:if-exists :supersede :if-does-not-exist :create) :if-exists :supersede :if-does-not-exist :create)
#-gcl2.6
(setup-asdftest-logical-host :root root) (setup-asdftest-logical-host :root root)
(multiple-value-bind (systems modules files test-files) (multiple-value-bind (systems modules files test-files)
(make-test-files (make-test-files
...@@ -401,7 +400,7 @@ ...@@ -401,7 +400,7 @@
(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*))) #+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 (progn
;; we're testing with unix, are we not? ;; we're testing with unix, are we not?
(assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname))) (assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname)))
......
...@@ -68,12 +68,10 @@ Some constraints: ...@@ -68,12 +68,10 @@ Some constraints:
#+lispworks #+lispworks
(setf system:*stack-overflow-behaviour* :warn)) (setf system:*stack-overflow-behaviour* :warn))
#+(or gcl2.6 genera) #+genera
(unless (fboundp 'ensure-directories-exist) (unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path) (defun ensure-directories-exist (path)
#+genera (fs:create-directories-recursively (pathname 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))))))
;;; Survival utilities ;;; Survival utilities
(defun asym (name &optional package errorp) (defun asym (name &optional package errorp)
...@@ -88,7 +86,7 @@ Some constraints: ...@@ -88,7 +86,7 @@ Some constraints:
(defun ucall (name &rest args) (apply (asym name :uiop) args)) (defun ucall (name &rest args) (apply (asym name :uiop) args))
(defun asymval (name &optional package) (defun asymval (name &optional package)
(symbol-value (asym name 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 (gensym "SYM")))
`(let ((,sym (asym ,name ,package))) `(let ((,sym (asym ,name ,package)))
(if ,sym (if ,sym
...@@ -252,7 +250,7 @@ Some constraints: ...@@ -252,7 +250,7 @@ Some constraints:
(if (and (asymval :*asdf-cache*) (not in-filesystem)) (if (and (asymval :*asdf-cache*) (not in-filesystem))
(acall :register-file-stamp file stamp) (acall :register-file-stamp file stamp)
(multiple-value-bind (sec min hr day month year) (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 (unless in-filesystem
(error "Y U NO use stamp cache?")) (error "Y U NO use stamp cache?"))
(ucall :run-program (ucall :run-program
...@@ -277,7 +275,7 @@ Some constraints: ...@@ -277,7 +275,7 @@ Some constraints:
#+cormanlisp (win32:exitprocess code) #+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code) #+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit 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) #+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) #+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) ? #+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 ...@@ -434,7 +432,6 @@ is bound, write a message and exit on an error. If
(defun compile-asdf-script () (defun compile-asdf-script ()
(with-test () (with-test ()
#-gcl2.6
(ecase (with-asdf-conditions () (maybe-compile-asdf)) (ecase (with-asdf-conditions () (maybe-compile-asdf))
(:not-found (:not-found
(leave-test "Testsuite failed: unable to find ASDF source" 3)) (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 ...@@ -570,7 +567,6 @@ is bound, write a message and exit on an error. If
(acall :oos (asym :load-op) :test-module-depend)) (acall :oos (asym :load-op) :test-module-depend))
(defun load-asdf (&optional tag) (defun load-asdf (&optional tag)
#+gcl2.6 (load-asdf-lisp tag) #-gcl2.6
(load-asdf-fasl tag) (load-asdf-fasl tag)
(configure-asdf)) (configure-asdf))
......
...@@ -2,8 +2,6 @@ ...@@ -2,8 +2,6 @@
(in-package :asdf) (in-package :asdf)
#+gcl2.6 (leave-test "GCL 2.6 sucks. Skipping test." 0)
(assert (handler-case (assert (handler-case
(let ((*compile-file-failure-behaviour* :warn)) (let ((*compile-file-failure-behaviour* :warn))
(load-system 'test-compile-file-failure :force t) (load-system 'test-compile-file-failure :force t)
......
...@@ -2,7 +2,6 @@ ...@@ -2,7 +2,6 @@
(in-package :asdf) (in-package :asdf)
(use-package :asdf-test) (use-package :asdf-test)
#+gcl2.6 (defmacro with-standard-io-syntax (&body body) `(progn ,@body))
(defparameter *tmp-directory* (subpathname *asdf-directory* "build/")) (defparameter *tmp-directory* (subpathname *asdf-directory* "build/"))
(setf *central-registry* nil) (setf *central-registry* nil)
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
#+gcl2.6 (leave-test "GCL 2.6 doesn't do Logical pathnames" 0)
(setf (logical-pathname-translations "ASDF") (setf (logical-pathname-translations "ASDF")
#+(or allegro clisp) #+(or allegro clisp)
`(("**;*.*.*" ,(asdf::wilden *asdf-directory*))) `(("**;*.*.*" ,(asdf::wilden *asdf-directory*)))
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
(load (subpathname *asdf-directory* "contrib/wild-modules.lisp"))
(progn (def-test-system :wild-module
(load (asdf::subpathname *asdf-directory* "contrib/wild-modules.lisp")) :version "0.0"
(def-test-system :wild-module :components ((:wild-module "systems" :pathname #p"*.asd")))
:version "0.0"
:components ((:wild-module "systems" :pathname #p"*.asd"))) (load-system :wild-module)
#-gcl2.6
(load-system :wild-module))
...@@ -17,8 +17,6 @@ ...@@ -17,8 +17,6 @@
(:export (:export
#:logical-pathname #:translate-logical-pathname #:logical-pathname #:translate-logical-pathname
#:make-broadcast-stream #:file-namestring) #: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 (:shadowing-import-from :scl #:boolean)
#+genera (:export #:boolean #:ensure-directories-exist) #+genera (:export #:boolean #:ensure-directories-exist)
#+mcl (:shadow #:user-homedir-pathname)) #+mcl (:shadow #:user-homedir-pathname))
...@@ -89,42 +87,6 @@ ...@@ -89,42 +87,6 @@
(setf compiler::*compiler-default-type* (pathname "") (setf compiler::*compiler-default-type* (pathname "")
compiler::*lsp-ext* "")) 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 #+genera
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(unless (fboundp 'ensure-directories-exist) (unless (fboundp 'ensure-directories-exist)
...@@ -206,5 +168,5 @@ Return a string made of the parts not omitted or emitted by FROB." ...@@ -206,5 +168,5 @@ Return a string made of the parts not omitted or emitted by FROB."
(defmacro compatfmt (format) (defmacro compatfmt (format)
#+(or gcl genera) #+(or gcl genera)
(frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>"))) (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format)) #-(or gcl genera) format))
...@@ -96,7 +96,7 @@ or the original (parsed) pathname if it is false (the default)." ...@@ -96,7 +96,7 @@ 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 gcl2.6) #-(or allegro clisp)
(if truename (if truename
(probe-file p) (probe-file p)
(ignore-errors (ignore-errors
...@@ -107,19 +107,12 @@ or the original (parsed) pathname if it is false (the default)." ...@@ -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)) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
p)))) p))))
#+(or clisp gcl2.6) #+clisp
#.(flet ((probe (probe) #.(flet ((probe (probe)
`(let ((foundtrue ,probe)) `(let ((foundtrue ,probe))
(cond (cond
(truename foundtrue) (truename foundtrue)
(foundtrue p))))) (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 #+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))
......
...@@ -630,8 +630,7 @@ it will filter them appropriately." ...@@ -630,8 +630,7 @@ it will filter them appropriately."
(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 `(:output-file :compile-check :warnings-file
#+clisp :lib-file #+(or ecl mkcl) :object-file #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
#+gcl2.6 ,@'(:external-format :print :verbose)) keys))
(output-file (output-file
(or output-file (or output-file
(apply 'compile-file-pathname* input-file :output-file output-file keywords))) (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
...@@ -701,13 +700,12 @@ it will filter them appropriately." ...@@ -701,13 +700,12 @@ it will filter them appropriately."
(defun load* (x &rest keys &key &allow-other-keys) (defun load* (x &rest keys &key &allow-other-keys)
"Portable wrapper around LOAD that properly handles loading from a stream." "Portable wrapper around LOAD that properly handles loading from a stream."
(etypecase x (etypecase x
((or pathname string #-(or allegro clozure gcl2.6 genera) stream) ((or pathname string #-(or allegro clozure genera) stream)
(apply 'load x (apply 'load x keys))
#-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys))) ;; Genera can't load from a string-input-stream
;; GCL 2.6, Genera can't load from a string-input-stream
;; ClozureCL 1.6 can only load from file 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. ;; 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 (stream ;; make do this way
(let ((*package* *package*) (let ((*package* *package*)
(*readtable* *readtable*) (*readtable* *readtable*)
......
...@@ -578,7 +578,7 @@ or when loading the package is optional." ...@@ -578,7 +578,7 @@ or when loading the package is optional."
import-from export intern import-from export intern
recycle mix reexport recycle mix reexport
unintern) unintern)
#+(or gcl2.6 genera) (declare (ignore documentation)) #+genera (declare (ignore documentation))
(let* ((package-name (string name)) (let* ((package-name (string name))
(nicknames (mapcar #'string nicknames)) (nicknames (mapcar #'string nicknames))
(names (cons package-name nicknames)) (names (cons package-name nicknames))
...@@ -600,7 +600,7 @@ or when loading the package is optional." ...@@ -600,7 +600,7 @@ or when loading the package is optional."
;; string to list home package and use package: ;; string to list home package and use package:
(inherited (make-hash-table :test 'equal))) (inherited (make-hash-table :test 'equal)))
(when-package-fishiness (record-fishy package-name)) (when-package-fishiness (record-fishy package-name))
#-(or gcl2.6 genera) #-genera
(when documentation (setf (documentation package t) documentation)) (when documentation (setf (documentation package t) documentation))
(loop :for p :in (set-difference (package-use-list package) (append mix use)) (loop :for p :in (set-difference (package-use-list package) (append mix use))
:do (note-package-fishiness :over-use name (package-names p)) :do (note-package-fishiness :over-use name (package-names p))
...@@ -751,24 +751,15 @@ UNINTERN -- Remove symbols here from PACKAGE." ...@@ -751,24 +751,15 @@ UNINTERN -- Remove symbols here from PACKAGE."
(remove "asdf" excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car)) :test 'equalp :key 'car))
#.(progn #.(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, ;; 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. ;; so we do this essential feature thing at read-time instead.
#+gcl #+gcl ;; Only support very recent GCL 2.7.0 from November 2013 or later.
(let ((code (let ((code ;; Old ASDF 2.011 might run on GCL 2.7.0. Or not.
(cond (cond
((or (< system::*gcl-major-version* 2) ((or (< system::*gcl-major-version* 2)
(and (= system::*gcl-major-version* 2) (and (= system::*gcl-major-version* 2)
(< system::*gcl-minor-version* 6))) (< system::*gcl-minor-version* 7)))
'(error "GCL 2.6 or later required to use ASDF")) '(error "GCL 2.7 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*)))))
(eval code) (eval code)
code))) code)))
......
...@@ -47,33 +47,19 @@ ...@@ -47,33 +47,19 @@
"Convert the DIRECTORY component from a format usable by the underlying "Convert the DIRECTORY component from a format usable by the underlying
implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
that is a list and not a string." that is a list and not a string."
#+gcl2.6 (setf directory (substitute :back :parent directory))
(cond (cond
#-(or cmu sbcl scl) ;; these implementations already normalize directory components. #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
((stringp directory) `(:absolute ,directory)) ((stringp directory) `(:absolute ,directory))
#+gcl2.6
((and (consp directory) (eq :root (first directory)))
`(:absolute ,@(rest directory)))
((or (null directory) ((or (null directory)
(and (consp directory) (member (first directory) '(:absolute :relative)))) (and (consp directory) (member (first directory) '(:absolute :relative))))
directory) directory)
#+gcl2.6
((consp directory)
`(:relative ,@directory))
(t (t
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
(defun denormalize-pathname-directory-component (directory-component) (defun denormalize-pathname-directory-component (directory-component)
"Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
by the underlying implementation's MAKE-PATHNAME and other primitives" by the underlying implementation's MAKE-PATHNAME and other primitives"
#-gcl2.6 directory-component 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))))
(defun merge-pathname-directory-components (specified defaults) (defun merge-pathname-directory-components (specified defaults)
"Helper for MERGE-PATHNAMES* that handles directory components" "Helper for MERGE-PATHNAMES* that handles directory components"
...@@ -106,7 +92,7 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ...@@ -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 #+(or clisp ecl gcl #|These haven't been tested:|# cormanlisp mcl) nil
"Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") "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 host (device () #+allegro devicep) name type version defaults
#+scl &allow-other-keys) #+scl &allow-other-keys)
"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
...@@ -117,9 +103,6 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ...@@ -117,9 +103,6 @@ by the underlying implementation's MAKE-PATHNAME and other primitives"
(apply 'make-pathname (apply 'make-pathname
(append (append
#+allegro (when (and devicep (null device)) `(:device :unspecific)) #+allegro (when (and devicep (null device)) `(:device :unspecific))
#+gcl2.6
(when directoryp
`(:directory ,(denormalize-pathname-directory-component directory)))
keys))) keys)))
(defun make-pathname-component-logical (x) (defun make-pathname-component-logical (x)
...@@ -613,9 +596,9 @@ with a format control-string and other arguments as arguments" ...@@ -613,9 +596,9 @@ with a format control-string and other arguments as arguments"
(with-upgradability () (with-upgradability ()
(defparameter *wild* (or #+cormanlisp "*" :wild) (defparameter *wild* (or #+cormanlisp "*" :wild)
"Wild component for use with MAKE-PATHNAME") "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") "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") "Wild-inferiors directory component for use with MAKE-PATHNAME")
(defparameter *wild-file* (defparameter *wild-file*
(make-pathname :directory nil :name *wild* :type *wild* (make-pathname :directory nil :name *wild* :type *wild*
......
...@@ -170,14 +170,14 @@ Built-in methods include the following: ...@@ -170,14 +170,14 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function.")) 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) (defmethod slurp-input-stream ((function function) input-stream &key)
(funcall function input-stream)) (funcall function input-stream))
(defmethod slurp-input-stream ((list cons) input-stream &key) (defmethod slurp-input-stream ((list cons) input-stream &key)
(apply (first list) input-stream (rest list))) (apply (first list) input-stream (rest list)))
#-(or gcl2.6 genera) #-genera
(defmethod slurp-input-stream ((output-stream stream) input-stream (defmethod slurp-input-stream ((output-stream stream) input-stream
&key linewise prefix (element-type 'character) buffer-size) &key linewise prefix (element-type 'character) buffer-size)
(copy-stream-to-stream (copy-stream-to-stream
...@@ -237,9 +237,9 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -237,9 +237,9 @@ Programmers are encouraged to define their own methods for this generic function
&key linewise prefix (element-type 'character) buffer-size) &key linewise prefix (element-type 'character) buffer-size)
(declare (ignorable stream linewise prefix element-type buffer-size)) (declare (ignorable stream linewise prefix element-type buffer-size))
(cond (cond
#+(or gcl2.6 genera) #+genera
((functionp x) (funcall x stream)) ((functionp x) (funcall x stream))
#+(or gcl2.6 genera) #+genera
((output-stream-p x) ((output-stream-p x)
(copy-stream-to-stream (copy-stream-to-stream
stream x stream x
...@@ -267,14 +267,14 @@ Built-in methods include the following: ...@@ -267,14 +267,14 @@ Built-in methods include the following:
Programmers are encouraged to define their own methods for this generic function.")) 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) (defmethod vomit-output-stream ((function function) output-stream &key)
(funcall function output-stream)) (funcall function output-stream))
(defmethod vomit-output-stream ((list cons) output-stream &key) (defmethod vomit-output-stream ((list cons) output-stream &key)
(apply (first list) output-stream (rest list))) (apply (first list) output-stream (rest list)))
#-(or gcl2.6 genera) #-genera
(defmethod vomit-output-stream ((input-stream stream) output-stream (defmethod vomit-output-stream ((input-stream stream) output-stream
&key linewise prefix (element-type 'character) buffer-size) &key linewise prefix (element-type 'character) buffer-size)
(copy-stream-to-stream (copy-stream-to-stream
...@@ -316,9 +316,9 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -316,9 +316,9 @@ Programmers are encouraged to define their own methods for this generic function
&key linewise prefix (element-type 'character) buffer-size) &key linewise prefix (element-type 'character) buffer-size)
(declare (ignorable stream linewise prefix element-type buffer-size)) (declare (ignorable stream linewise prefix element-type buffer-size))
(cond (cond
#+(or gcl2.6 genera) #+genera
((functionp x) (funcall x stream)) ((functionp x) (funcall x stream))
#+(or gcl2.6 genera) #+genera
((input-stream-p x) ((input-stream-p x)
(copy-stream-to-stream (copy-stream-to-stream
x stream x stream
...@@ -774,7 +774,7 @@ It returns a process-info plist with possible keys: ...@@ -774,7 +774,7 @@ It returns a process-info plist with possible keys:
(*standard-output* *stdout*) (*standard-output* *stdout*)
(*error-output* *stderr*)) (*error-output* *stderr*))
(ext:system %command)) (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)) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
#+mkcl ;; PROBABLY BOGUS -- ask jcb #+mkcl ;; PROBABLY BOGUS -- ask jcb
(multiple-value-bind (io process exit-code) (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." ...@@ -224,10 +224,9 @@ as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
(if-does-not-exist :error)) (if-does-not-exist :error))
"Open FILE for input with given recognizes options, call THUNK with the resulting stream. "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
Other keys are accepted but discarded." Other keys are accepted but discarded."
#+gcl2.6 (declare (ignore external-format))
(with-open-file (s pathname :direction :input (with-open-file (s pathname :direction :input
:element-type element-type :element-type element-type
#-gcl2.6 :external-format #-gcl2.6 external-format :external-format external-format
:if-does-not-exist if-does-not-exist) :if-does-not-exist if-does-not-exist)
(funcall thunk s))) (funcall thunk s)))