Commit d6d7d423 authored by Gary Palter 's avatar Gary Palter
Browse files

* 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.
parent 6e2df328
Pipeline #3529 passed with stages
in 49 minutes and 56 seconds
......@@ -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))
......
......@@ -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))
......
;;; -*- 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:
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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?"
......
......@@ -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))
......
......@@ -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))
......
......@@ -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*)))
......
......@@ -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
......
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