From 2c49dbc7148ab084d2f2b1599dba0deac28a77ea Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Mon, 14 Jan 2013 20:45:37 -0500
Subject: [PATCH] 2.26.98: more portability fixes for GCL.

---
 compatibility.lisp                |  5 ++-
 footer.lisp                       |  2 +-
 os.lisp                           |  3 +-
 package.lisp                      |  9 +++--
 run-program.lisp                  |  6 +--
 stream.lisp                       |  1 +
 test/script-support.lisp          | 20 +++++++---
 test/test-logical-pathname.script | 63 ++++++++++++++++---------------
 utility.lisp                      |  1 +
 9 files changed, 61 insertions(+), 49 deletions(-)

diff --git a/compatibility.lisp b/compatibility.lisp
index c7304306..56a8cfc3 100644
--- a/compatibility.lisp
+++ b/compatibility.lisp
@@ -13,6 +13,7 @@
    #:logical-pathname #:translate-logical-pathname
    #:make-broadcast-stream #:file-namestring)
   #+ecl (:export #:use-ecl-byte-compiler-p)
+  ;;#+gcl (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
   #+genera (:import-from :scl #:boolean)
   #+genera (:export #:boolean #:ensure-directories-exist)
   #+mcl (:export #:probe-posix #:current-user-homedir-pathname)
@@ -52,9 +53,9 @@
   (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 lacks output-translations and more.
             (and (= system::*gcl-major-version* 2)
                  (< system::*gcl-minor-version* 7)))
-    (format t "Detected an old GCL 2.6. Only limited functionality available.~%")
     (shadow 'type-of :asdf/compatibility)
-    (export 'with-standard-io-syntax)
+    ;;(shadow 'with-standard-io-syntax :asdf/compatibility)
+    ;;(format t "Detected an old GCL 2.6. Only limited functionality available.~%")
     (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
     (pushnew :gcl<2.7 *features*))
   (unless (member :ansi-cl *features*)
diff --git a/footer.lisp b/footer.lisp
index 68b11628..41cb7e12 100644
--- a/footer.lisp
+++ b/footer.lisp
@@ -7,7 +7,7 @@
    :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action
    :asdf/operate :asdf/bundle :asdf/concatenate-source
    :asdf/output-translations :asdf/source-registry
-   :asdf/backward-internals :asdf/defsystem :asdf/backward-interface :asdf/interface))
+   :asdf/backward-internals :asdf/defsystem :asdf/backward-interface))
 (in-package :asdf/footer)
 
 ;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
diff --git a/os.lisp b/os.lisp
index d3e80e01..59d731ff 100644
--- a/os.lisp
+++ b/os.lisp
@@ -281,8 +281,7 @@ then returning the non-empty string value of the variable"
 (defun setup-temporary-directory ()
   (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
-  #+gcl (setf system::*tmp-dir* *temporary-directory*))
-
+  #+(and gcl (not gcl<2.7)) (setf system::*tmp-dir* *temporary-directory*))
 
 (defun* call-with-temporary-file
     (thunk &key
diff --git a/package.lisp b/package.lisp
index f8b0839a..43bbea2a 100644
--- a/package.lisp
+++ b/package.lisp
@@ -571,10 +571,11 @@ or when loading the package is optional."
 (defmacro define-package (package &rest clauses)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      #+(or ecl gcl) (defpackage ,package (:use))
-     #+clisp (macrolet ((foo ()
-                          (apply 'ensure-package ',(parse-define-package-form package clauses))
-                          (package-definition-form ',package :nicknamesp nil)))
-               (foo))
+     #+clisp
+     (macrolet ((foo ()
+                  (apply 'ensure-package ',(parse-define-package-form package clauses))
+                  (package-definition-form ',package :nicknamesp nil)))
+       (foo))
      (apply 'ensure-package ',(parse-define-package-form package clauses))))
 
 
diff --git a/run-program.lisp b/run-program.lisp
index 4f8d7d1a..8cbb7a84 100644
--- a/run-program.lisp
+++ b/run-program.lisp
@@ -173,11 +173,9 @@ by /bin/sh in POSIX"
   (declare (ignorable stream element-type))
   (cond
     #+(or gcl<2.7 genera)
-    ((functionp x)
-     (funcall x stream))
+    ((functionp x) (funcall x stream))
     #+(or gcl<2.7 genera)
-    ((output-stream-p x)
-     (copy-stream-to-stream stream x :element-type element-type))
+    ((output-stream-p x) (copy-stream-to-stream stream x :element-type element-type))
     (t
      (error "Invalid ~S destination ~S" 'slurp-input-stream x))))
 
diff --git a/stream.lisp b/stream.lisp
index 3a75d5dc..ec94de9d 100644
--- a/stream.lisp
+++ b/stream.lisp
@@ -4,6 +4,7 @@
 (asdf/package:define-package :asdf/stream
   (:recycle :asdf/stream)
   (:use :cl :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname)
+  #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:with-standard-io-syntax)
   (:export
    #:*default-stream-element-type* #:*stderr* #:setup-stderr
    #:with-safe-io-syntax #:call-with-safe-io-syntax
diff --git a/test/script-support.lisp b/test/script-support.lisp
index 0423cb32..6ba9ff3b 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -39,6 +39,13 @@ Some constraints:
 (defvar *debug-asdf* nil)
 (defvar *quit-when-done* t)
 
+(defun verbose (&optional (verbose t))
+  (loop :for v :in '(*load-verbose* *compile-verbose*
+                     *load-print* *compile-print*)
+        :do (setf (symbol-value v) verbose)))
+
+(verbose nil)
+
 ;;; Minimal compatibility layer
 (eval-when (:compile-toplevel :load-toplevel :execute)
   #+allegro
@@ -148,10 +155,11 @@ Some constraints:
 
 (defun touch-file (file &key (offset 0) timestamp)
   (let ((timestamp (or timestamp (+ offset (get-universal-time)))))
-    (multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp)
+    (multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp #+gcl<2.7 -5)
       (acall :run-shell-command
              "touch -t ~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D ~S"
-             year month day hr min sec (namestring file)))))
+             year month day hr min sec (namestring file))
+      (assert-equal (file-write-date file) timestamp))))
 
 (defun hash-table->alist (table)
   (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
@@ -229,7 +237,7 @@ is bound, write a message and exit on an error.  If
     (funcall thunk)))
 
 (defun load-asdf-lisp (&optional tag)
-  (quietly (load (asdf-lisp tag))))
+  (quietly (load (asdf-lisp tag) :verbose *load-verbose* :print *load-print*)))
 
 (defun load-asdf-fasl (&optional tag)
   (quietly (load (asdf-fasl tag))))
@@ -373,13 +381,15 @@ is bound, write a message and exit on an error.  If
   (setf *package* (find-package :asdf-test)))
 
 ;; Actual scripts rely on this function:
-(defun common-lisp-user::load-asdf () (load-asdf)) 
+(defun common-lisp-user::load-asdf () (load-asdf))
 
 ;; These are shorthands for interactive debugging of test scripts:
 (!a
  common-lisp-user::debug-asdf debug-asdf
  da debug-asdf common-lisp-user::da debug-asdf
- la load-asdf common-lisp-user::la load-asdf)
+ la load-asdf common-lisp-user::la load-asdf
+ ll load-asdf-lisp
+ v verbose)
 
 #| For the record, the following form is sometimes useful to insert in
  asdf/plan:compute-action-stamp to find out what's happening.
diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script
index 156c06dd..fe3bb304 100644
--- a/test/test-logical-pathname.script
+++ b/test/test-logical-pathname.script
@@ -17,38 +17,39 @@
                       :wilden t))))
 
 (with-test ()
- (DBG :logical
-      (logical-pathname-translations "ASDF")
-      (translate-logical-pathname "ASDF:test;test-force.asd")
-      (truename "ASDF:test;test-force.asd"))
+  #-gcl<2.7
+  (DBG :logical
+       (logical-pathname-translations "ASDF")
+       (translate-logical-pathname "ASDF:test;test-force.asd")
+       (truename "ASDF:test;test-force.asd"))
 
- #-(or xcl gcl<2.7)
- (progn
-   (DBG "Test logical pathnames in central registry")
-   (setf *central-registry* '(#p"ASDF:test;"))
-   (initialize-source-registry '(:source-registry :ignore-inherited-configuration))
-   (DBG "loading" (oos 'load-op :test-logical-pathname :force t)))
+  #-(or xcl gcl<2.7)
+  (progn
+    (DBG "Test logical pathnames in central registry")
+    (setf *central-registry* '(#p"ASDF:test;"))
+    (initialize-source-registry '(:source-registry :ignore-inherited-configuration))
+    (DBG "loading" (oos 'load-op :test-logical-pathname :force t)))
 
- #-(or xcl gcl<2.7)
- (progn
-   (DBG "Test logical pathnames in source-registry, non-recursive")
-   (clear-system :test-logical-pathname)
-   (setf *central-registry* '())
-   (initialize-source-registry
-    '(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration))
-   (load-system :test-logical-pathname :force t :verbose t))
+  #-(or xcl gcl<2.7)
+  (progn
+    (DBG "Test logical pathnames in source-registry, non-recursive")
+    (clear-system :test-logical-pathname)
+    (setf *central-registry* '())
+    (initialize-source-registry
+     '(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration))
+    (load-system :test-logical-pathname :force t :verbose t))
 
- #-(or xcl gcl<2.7)
- (progn
-   (DBG "Test logical pathnames in source-registry, recursive")
-   (clear-system :test-logical-pathname)
-   (setf *central-registry* '())
-   (initialize-source-registry
-    ;; Bug: Allegro Express 8.2 and 9.0 incorrectly read #p"ASDF:" as relative.
-    ;; other bug: around 2.26.xx, CLISP borks badly if this is ASDF:
-    ;; and it tries to load ASDF from a logical-pathname.
-    '(:source-registry (:tree #p"ASDF:test;")
-      :ignore-inherited-configuration))
-   (load-system :test-logical-pathname :force t))
+  #-(or xcl gcl<2.7)
+  (progn
+    (DBG "Test logical pathnames in source-registry, recursive")
+    (clear-system :test-logical-pathname)
+    (setf *central-registry* '())
+    (initialize-source-registry
+     ;; Bug: Allegro Express 8.2 and 9.0 incorrectly read #p"ASDF:" as relative.
+     ;; other bug: around 2.26.xx, CLISP borks badly if this is ASDF:
+     ;; and it tries to load ASDF from a logical-pathname.
+     '(:source-registry (:tree #p"ASDF:test;")
+       :ignore-inherited-configuration))
+    (load-system :test-logical-pathname :force t))
 
- (DBG "Done"))
+  (DBG "Done"))
diff --git a/utility.lisp b/utility.lisp
index 4a2621c3..c0512481 100644
--- a/utility.lisp
+++ b/utility.lisp
@@ -4,6 +4,7 @@
 (asdf/package:define-package :asdf/utility
   (:recycle :asdf/utility :asdf)
   (:use :common-lisp :asdf/package :asdf/compatibility)
+  #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:with-standard-io-syntax)
   (:export
    ;; magic helper to define debugging functions:
    #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
-- 
GitLab