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