Commit 0a6a0e77 authored by Robert Goldman's avatar Robert Goldman
Browse files

Merge branch 'master' into 'master'

Two more changes for Genera

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