From d6d7d423dfb9c414194b5e8925a08d96bacb5ade Mon Sep 17 00:00:00 2001
From: Gary Palter <palter@clozure.com>
Date: Fri, 30 Apr 2021 16:43:29 -0400
Subject: [PATCH]  * Remove LOOP* as the version of Genera which supports ASDF
 implements destructuring  * Add "Package: CL-USER" to the modeline so a user
 could compile ASDF on Genera without first setting their Lisp context to
 ANSI-CL.

---
 bundle.lisp                  |  2 +-
 find-system.lisp             |  2 +-
 header.lisp                  |  2 +-
 output-translations.lisp     | 26 +++++++-------
 package-inferred-system.lisp | 22 ++++++------
 parse-defsystem.lisp         | 70 ++++++++++++++++++------------------
 plan.lisp                    | 14 ++++----
 uiop/common-lisp.lisp        |  7 ----
 uiop/configuration.lisp      | 30 ++++++++--------
 uiop/os.lisp                 | 24 ++++++-------
 uiop/stream.lisp             | 14 ++++----
 uiop/utility.lisp            | 38 ++++++++++----------
 upgrade.lisp                 |  8 ++---
 13 files changed, 126 insertions(+), 133 deletions(-)

diff --git a/bundle.lisp b/bundle.lisp
index c955655c1..5968d7f9d 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -556,7 +556,7 @@ which is probably not what you want; you probably need to tweak your output tran
   (defmethod component-depends-on :around ((o image-op) (c system))
     (let* ((next (call-next-method))
            (deps (make-hash-table :test 'equal))
-           (linkable (loop* :for (do . dcs) :in next :collect
+           (linkable (loop :for (do . dcs) :in next :collect
                        (cons do
                              (loop :for dc :in dcs
                                :for dep = (and dc (resolve-dependency-spec c dc))
diff --git a/find-system.lisp b/find-system.lisp
index 92de00ab4..0980a2ccd 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -68,7 +68,7 @@
   (defmethod component-depends-on ((o define-op) (s system))
     `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below.
       ;; 2- We don't call-next-method to avoid other methods
-      ,@(loop* :for (o . c) :in (definition-dependency-list s) :collect (list o c))))
+      ,@(loop :for (o . c) :in (definition-dependency-list s) :collect (list o c))))
 
   (defmethod component-depends-on ((o operation) (s system))
     `(,@(when (and (not (typep o 'define-op))
diff --git a/header.lisp b/header.lisp
index 659f96642..c47a7ce81 100644
--- a/header.lisp
+++ b/header.lisp
@@ -1,4 +1,4 @@
-;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
+;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*-
 ;;; This is ASDF 3.3.4.14: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
diff --git a/output-translations.lisp b/output-translations.lisp
index 217d7049b..7ea330d5d 100644
--- a/output-translations.lisp
+++ b/output-translations.lisp
@@ -293,19 +293,19 @@ effectively disabling the output translation facility."
        path)
       ((or pathname string)
        (ensure-output-translations)
-       (loop* :with p = (resolve-symlinks* path)
-              :for (source destination) :in (car *output-translations*)
-              :for root = (when (or (eq source t)
-                                    (and (pathnamep source)
-                                         (not (absolute-pathname-p source))))
-                            (pathname-root p))
-              :for absolute-source = (cond
-                                       ((eq source t) (wilden root))
-                                       (root (merge-pathnames* source root))
-                                       (t source))
-              :when (or (eq source t) (pathname-match-p p absolute-source))
-              :return (translate-pathname* p absolute-source destination root source)
-              :finally (return p)))))
+       (loop :with p = (resolve-symlinks* path)
+             :for (source destination) :in (car *output-translations*)
+             :for root = (when (or (eq source t)
+                                   (and (pathnamep source)
+                                        (not (absolute-pathname-p source))))
+                           (pathname-root p))
+             :for absolute-source = (cond
+                                      ((eq source t) (wilden root))
+                                      (root (merge-pathnames* source root))
+                                      (t source))
+             :when (or (eq source t) (pathname-match-p p absolute-source))
+               :return (translate-pathname* p absolute-source destination root source)
+             :finally (return p)))))
 
 
   ;; Hook into uiop's output-translation mechanism
diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp
index 8e16e7c02..5a9db19cd 100644
--- a/package-inferred-system.lisp
+++ b/package-inferred-system.lisp
@@ -69,17 +69,17 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it."
     (assert (defpackage-form-p defpackage-form))
     (remove-duplicates
      (while-collecting (dep)
-       (loop* :for (option . arguments) :in (cddr defpackage-form) :do
-              (ecase option
-                ((:use :mix :reexport :use-reexport :mix-reexport)
-                 (dolist (p arguments) (dep (string p))))
-                ((:import-from :shadowing-import-from)
-                 (dep (string (first arguments))))
-                #+package-local-nicknames
-                ((:local-nicknames)
-                 (loop* :for (nil actual-package-name) :in arguments :do
-                      (dep (string actual-package-name))))
-                ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
+       (loop :for (option . arguments) :in (cddr defpackage-form) :do
+         (ecase option
+           ((:use :mix :reexport :use-reexport :mix-reexport)
+            (dolist (p arguments) (dep (string p))))
+           ((:import-from :shadowing-import-from)
+            (dep (string (first arguments))))
+           #+package-local-nicknames
+           ((:local-nicknames)
+            (loop :for (nil actual-package-name) :in arguments :do
+              (dep (string actual-package-name))))
+           ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
      :from-end t :test 'equal))
 
   (defun package-designator-name (package)
diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp
index fa6170bed..db3217bb5 100644
--- a/parse-defsystem.lisp
+++ b/parse-defsystem.lisp
@@ -195,44 +195,44 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
   (defun %define-component-inline-methods (ret rest)
     ;; find key-value pairs that look like inline method definitions in REST. For each identified
     ;; definition, parse it and, if it is well-formed, define the method.
-    (loop* :for (key value) :on rest :by #'cddr
-           :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
-           :when name :do
-           ;; parse VALUE as an inline method definition of the form
-           ;;
-           ;;   (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
-           (destructuring-bind (operation-name &rest rest) value
-             (let ((qualifiers '()))
-               ;; ensure that OPERATION-NAME is a symbol.
-               (unless (and (symbolp operation-name) (not (null operation-name)))
-                 (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~
+    (loop :for (key value) :on rest :by #'cddr
+          :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
+          :when name :do
+            ;; parse VALUE as an inline method definition of the form
+            ;;
+            ;;   (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
+            (destructuring-bind (operation-name &rest rest) value
+              (let ((qualifiers '()))
+                ;; ensure that OPERATION-NAME is a symbol.
+                (unless (and (symbolp operation-name) (not (null operation-name)))
+                  (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~
                               designating an operation but ~S."
-                               value operation-name))
-               ;; ensure that REST starts with either a cons (potential lambda list, further checked
-               ;; below) or a qualifier accepted by the standard method combination. Everything else
-               ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
-               ;; has to start with the lambda list.
-               (cond
-                 ((consp (car rest)))
-                 ((not (member (car rest)
-                               *standard-method-combination-qualifiers*))
-                  (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~
+                                value operation-name))
+                ;; ensure that REST starts with either a cons (potential lambda list, further checked
+                ;; below) or a qualifier accepted by the standard method combination. Everything else
+                ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
+                ;; has to start with the lambda list.
+                (cond
+                  ((consp (car rest)))
+                  ((not (member (car rest)
+                                *standard-method-combination-qualifiers*))
+                   (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~
                                qualifiers ~{~S~^ ~} is allowed, not ~S."
-                                value *standard-method-combination-qualifiers* (car rest)))
-                 (t
-                  (setf qualifiers (list (pop rest)))))
-               ;; REST must start with a two-element lambda list.
-               (unless (and (listp (car rest))
-                            (length=n-p (car rest) 2)
-                            (null (cddar rest)))
-                 (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~
+                                 value *standard-method-combination-qualifiers* (car rest)))
+                  (t
+                   (setf qualifiers (list (pop rest)))))
+                ;; REST must start with a two-element lambda list.
+                (unless (and (listp (car rest))
+                             (length=n-p (car rest) 2)
+                             (null (cddar rest)))
+                  (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~
                               a lambda-list of the form (OPERATION COMPONENT) and a method body."
-                               value operation-name))
-               ;; define the method.
-               (destructuring-bind ((o c) &rest body) rest
-                 (pushnew
-                  (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body))
-                  (component-inline-methods ret)))))))
+                                value operation-name))
+                ;; define the method.
+                (destructuring-bind ((o c) &rest body) rest
+                  (pushnew
+                   (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body))
+                   (component-inline-methods ret)))))))
 
   (defun %refresh-component-inline-methods (component rest)
     ;; clear methods, then add the new ones
diff --git a/plan.lisp b/plan.lisp
index 972a65f4c..e810211d8 100644
--- a/plan.lisp
+++ b/plan.lisp
@@ -220,13 +220,13 @@ to be meaningful, or could it just as well have been done in another Lisp image?
 (with-upgradability ()
   (defun* (map-direct-dependencies) (operation component fun)
     "Call FUN on all the valid dependencies of the given action in the given plan"
-    (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
-      :for dep-o = (find-operation operation dep-o-spec)
-      :when dep-o
-      :do (loop :for dep-c-spec :in dep-c-specs
-            :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
-            :when (action-valid-p dep-o dep-c)
-            :do (funcall fun dep-o dep-c))))
+    (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
+          :for dep-o = (find-operation operation dep-o-spec)
+          :when dep-o
+            :do (loop :for dep-c-spec :in dep-c-specs
+                      :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
+                      :when (action-valid-p dep-o dep-c)
+                        :do (funcall fun dep-o dep-c))))
 
   (defun* (reduce-direct-dependencies) (operation component combinator seed)
     "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
diff --git a/uiop/common-lisp.lisp b/uiop/common-lisp.lisp
index dfad7e629..86f4d7e48 100644
--- a/uiop/common-lisp.lisp
+++ b/uiop/common-lisp.lisp
@@ -166,13 +166,6 @@
   (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
 
 
-;;;; Looping
-(eval-when (:load-toplevel :compile-toplevel :execute)
-  (defmacro loop* (&rest rest)
-    #-genera `(loop ,@rest)
-    #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
-
-
 ;;;; compatfmt: avoid fancy format directives when unsupported
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (defun frob-substrings (string substrings &optional frob)
diff --git a/uiop/configuration.lisp b/uiop/configuration.lisp
index 0e9a5a154..0d6524007 100644
--- a/uiop/configuration.lisp
+++ b/uiop/configuration.lisp
@@ -218,21 +218,21 @@ directive.")
   (defun* (resolve-location) (x &key ensure-directory wilden directory)
     "Resolve location designator X into a PATHNAME"
     ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
-    (loop* :with dirp = (or directory ensure-directory)
-           :with (first . rest) = (if (atom x) (list x) x)
-           :with path = (or (resolve-absolute-location
-                             first :ensure-directory (and (or dirp rest) t)
-                                   :wilden (and wilden (null rest)))
-                            (return nil))
-           :for (element . morep) :on rest
-           :for dir = (and (or morep dirp) t)
-           :for wild = (and wilden (not morep))
-           :for sub = (merge-pathnames*
-                       (resolve-relative-location
-                        element :ensure-directory dir :wilden wild)
-                       path)
-           :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
-           :finally (return path)))
+    (loop :with dirp = (or directory ensure-directory)
+          :with (first . rest) = (if (atom x) (list x) x)
+          :with path = (or (resolve-absolute-location
+                            first :ensure-directory (and (or dirp rest) t)
+                            :wilden (and wilden (null rest)))
+                           (return nil))
+          :for (element . morep) :on rest
+          :for dir = (and (or morep dirp) t)
+          :for wild = (and wilden (not morep))
+          :for sub = (merge-pathnames*
+                      (resolve-relative-location
+                       element :ensure-directory dir :wilden wild)
+                      path)
+          :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
+          :finally (return path)))
 
   (defun location-designator-p (x)
     "Is X a designator for a location?"
diff --git a/uiop/os.lisp b/uiop/os.lisp
index 71d584822..4f81d15d4 100644
--- a/uiop/os.lisp
+++ b/uiop/os.lisp
@@ -66,22 +66,22 @@ keywords explicitly."
   (defun detect-os ()
     "Detects the current operating system. Only needs be run at compile-time,
 except on ABCL where it might change between FASL compilation and runtime."
-    (loop* :with o
-           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
-                                         (:os-windows . os-windows-p)
-                                         (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p)
-                                         (:os-haiku . os-haiku-p)
-                                         (:os-mezzano . os-mezzano-p))
-           :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect))
-           :do (setf o feature) (pushnew feature *features*)
-           :else :do (setf *features* (remove feature *features*))
-           :finally
-           (return (or o (error "Congratulations for trying ASDF on an operating system~%~
+    (loop :with o
+          :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
+                                        (:os-windows . os-windows-p)
+                                        (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p)
+                                        (:os-haiku . os-haiku-p)
+                                        (:os-mezzano . os-mezzano-p))
+          :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect))
+            :do (setf o feature) (pushnew feature *features*)
+          :else :do (setf *features* (remove feature *features*))
+          :finally
+             (return (or o (error "Congratulations for trying ASDF on an operating system~%~
 that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
 
   (defmacro os-cond (&rest clauses)
     #+abcl `(cond ,@clauses)
-    #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
+    #-abcl (loop :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
 
   (detect-os))
 
diff --git a/uiop/stream.lisp b/uiop/stream.lisp
index 2a3b983fe..825cccd17 100644
--- a/uiop/stream.lisp
+++ b/uiop/stream.lisp
@@ -352,13 +352,13 @@ If LINEWISE is true, then read and copy the stream line by line, with an optiona
 Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
     (with-open-stream (input input)
       (if linewise
-          (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
-                 :while line :do
-                 (when prefix (princ prefix output))
-                 (princ line output)
-                 (unless eof (terpri output))
-                 (finish-output output)
-                 (when eof (return)))
+          (loop :for (line eof) = (multiple-value-list (read-line input nil nil))
+                :while line :do
+                  (when prefix (princ prefix output))
+                  (princ line output)
+                  (unless eof (terpri output))
+                  (finish-output output)
+                  (when eof (return)))
           (loop
             :with buffer-size = (or buffer-size 8192)
             :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
diff --git a/uiop/utility.lisp b/uiop/utility.lisp
index 70b338f99..1b8e4cf87 100644
--- a/uiop/utility.lisp
+++ b/uiop/utility.lisp
@@ -4,9 +4,9 @@
 (uiop/package:define-package :uiop/utility
   (:use :uiop/common-lisp :uiop/package)
   ;; import and reexport a few things defined in :uiop/common-lisp
-  (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
+  (:import-from :uiop/common-lisp #:compatfmt #:frob-substrings
    #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
-  (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
+  (:export #:compatfmt #:frob-substrings #:compatfmt
    #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
   (:export
    ;; magic helper to define debugging functions:
@@ -185,15 +185,15 @@ Returns two values: \(A B C\) and \(1 2 3\)."
 (with-upgradability ()
   (defun remove-plist-key (key plist)
     "Remove a single key from a plist"
-    (loop* :for (k v) :on plist :by #'cddr
-           :unless (eq k key)
-           :append (list k v)))
+    (loop :for (k v) :on plist :by #'cddr
+          :unless (eq k key)
+            :append (list k v)))
 
   (defun remove-plist-keys (keys plist)
     "Remove a list of keys from a plist"
-    (loop* :for (k v) :on plist :by #'cddr
-           :unless (member k keys)
-           :append (list k v))))
+    (loop :for (k v) :on plist :by #'cddr
+          :unless (member k keys)
+            :append (list k v))))
 
 
 ;;; Sequences
@@ -209,17 +209,17 @@ Returns two values: \(A B C\) and \(1 2 3\)."
   ;; NB: We assume a total order on character types.
   ;; If that's not true... this code will need to be updated.
   (defparameter +character-types+ ;; assuming a simple hierarchy
-    #.(coerce (loop* :for (type next) :on
-                     '(;; In SCL, all characters seem to be 16-bit base-char
-                       ;; Yet somehow character fails to be a subtype of base-char
-                       #-scl base-char
-                       ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
-                       ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
-                       #+lispworks7+ lw:bmp-char
-                       #+lispworks lw:simple-char
-                       character)
-                     :unless (and next (subtypep next type))
-                     :collect type) 'vector))
+    #.(coerce (loop :for (type next) :on
+                    '(;; In SCL, all characters seem to be 16-bit base-char
+                      ;; Yet somehow character fails to be a subtype of base-char
+                      #-scl base-char
+                      ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
+                      ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
+                      #+lispworks7+ lw:bmp-char
+                      #+lispworks lw:simple-char
+                      character)
+                    :unless (and next (subtypep next type))
+                      :collect type) 'vector))
   (defparameter +max-character-type-index+ (1- (length +character-types+)))
   (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
   (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
diff --git a/upgrade.lisp b/upgrade.lisp
index e994f188a..8876d527e 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -139,10 +139,10 @@ previously-loaded version of ASDF."
                            (if (consp x) (values (car x) (cadr x)) (values x :asdf))
                          (find-symbol* s p nil)))
              (asyms (l) (mapcar #'asym l)))
-      (loop* :for (name superclasses slots) :in redefined-classes
-             :for sym = (find-symbol* name :asdf nil)
-             :when (and sym (find-class sym))
-             :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
+      (loop :for (name superclasses slots) :in redefined-classes
+            :for sym = (find-symbol* name :asdf nil)
+            :when (and sym (find-class sym))
+              :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
 
 
 ;;; Self-upgrade functions
-- 
GitLab