From mevenson at common-lisp.net Tue Jul 29 22:55:16 2014 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 Jul 2014 22:55:16 -0000 Subject: [Armedbear-cvs] r14715 - trunk/abcl/contrib/jss Message-ID: <20140729225516.20841.65660@lisp.not.org> Author: mevenson Date: Tue Jul 29 22:55:15 2014 New Revision: 14715 Log: jss: GET-JAVA-FIELD now finds non-public inherited fields with TRY-HARDER. Robert Goldman contributes in : GET-JAVA-FIELD, when its optional TRY-HARDER argument is NIL, will return any public field on its argument object, whether defined locally or inherited. When TRY-HARDER argument is true, on the other hand, it will return non-public fields as well as public ones but only non-public fields that are defined locally -- not non-public fields that are inherited. This non-orthogonality seems wrong (just read the contorted description above and imagine it as a docstring!). I am attaching a proposed patch which searches up the class hierarchy to find inherited non-public fields when TRY-HARDER is true. Modified: trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Fri Jul 18 17:03:20 2014 (r14714) +++ trunk/abcl/contrib/jss/invoke.lisp Tue Jul 29 22:55:15 2014 (r14715) @@ -325,8 +325,9 @@ (jobject-class object)))) (jfield (if (java-object-p field) field - (find field (#"getDeclaredFields" class) - :key 'jfield-name :test 'equal)))) + (or (find-declared-field field class) + (error "Unable to find a FIELD named ~a for ~a" + field object))))) (#"setAccessible" jfield +true+) (values (#"get" jfield object) jfield)) (if (symbolp object) @@ -334,6 +335,23 @@ (jfield class field)) (jfield field object)))) +(defun find-declared-field (field class) + "Return a FIELD object corresponding to the definition of FIELD +\(a string\) visible at CLASS. *Not* restricted to public classes, and checks +all superclasses of CLASS. + Returns NIL if no field object is found." + (loop while class + for field-obj = (get-declared-field class field) + if field-obj + do (return-from find-declared-field field-obj) + else + do (setf class (jclass-superclass class))) + nil) + +(defun get-declared-field (class fieldname) + (find fieldname (#"getDeclaredFields" class) + :key 'jfield-name :test 'equal)) + ;; TODO use #"getSuperclass" and #"getInterfaces" to see whether there ;; are fields in superclasses that we might set (defun set-java-field (object field value &optional (try-harder *running-in-osgi*)) Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Fri Jul 18 17:03:20 2014 (r14714) +++ trunk/abcl/contrib/jss/jss.asd Tue Jul 29 22:55:15 2014 (r14715) @@ -1,8 +1,8 @@ ;;;; -*- Mode: LISP -*- (asdf:defsystem :jss :author "Alan Ruttenberg, Mark Evenson" - :version "3.0.7" - :description "<> asdf:defsystem asdf:defsystem Author: mevenson Date: Fri Jul 18 17:03:20 2014 New Revision: 14714 Log: ASDF 3.1.2.9 changeset: 2488:0a1ded36af37 bookmark: master tag: default/master tag: tip user: Francois-Rene Rideau summary: Tweak the debian changelog. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo Sat May 17 10:51:33 2014 (r14713) +++ trunk/abcl/doc/asdf/asdf.texinfo Fri Jul 18 17:03:20 2014 (r14714) @@ -909,6 +909,7 @@ regarding source-registry or output-translations. @end defun + at vindex *image-dump-hook* This function is pushed onto the @code{uiop:*image-dump-hook*} by default, which means that if you save an image using @code{uiop:dump-image}, or via @code{asdf:image-op} and @code{asdf:program-op}, @@ -2388,25 +2389,150 @@ of the system in memory @end itemize + at cindex ASDF-USER package When system definitions are loaded from @file{.asd} files, -a new scratch package is created for them to load into, -so that different systems do not overwrite each others operations. -The user may also wish to (and is recommended to) -include @code{defpackage} and @code{in-package} forms -in his system definition files, however, -so that they can be loaded manually if need be. +they are implicitly loaded into the @code{ASDF-USER} package, +which uses @code{ASDF}, @code{UIOP} and @code{UIOP/COMMON-LISP}@footnote{ +Note that between releases 2.27 and 3.0.3, only @code{UIOP/PACKAGE}, +not all of @code{UIOP}, was used; if you want your code to work +with releases earlier than 3.1.2, you may have to explicitly define a package +that uses @code{UIOP}, or use proper package prefix to your symbols, as in + at code{uiop:version<}.} +Programmers who do anything non-trivial in a @file{.asd} file, +such as defining new variables, functions or classes, +should include @code{defpackage} and @code{in-package} forms in this file, +so they will not overwrite each others' extensions. +Such forms might also help the files behave identically +if loaded manually with @code{cl:load} for development or debugging, +though we recommend you use the function @code{asdf::load-asd} instead, +which the @code{slime-asdf} contrib knows about. The default value of @code{*system-definition-search-functions*} -is a list of two functions. +is a list of three functions. The first function looks in each of the directories given by evaluating members of @code{*central-registry*} -for a file whose name is the name of the system and whose type is @file{asd}. -The first such file is returned, +for a file whose name is the name of the system and whose type is @file{asd}; +the first such file is returned, whether or not it turns out to actually define the appropriate system. The second function does something similar, -for the directories specified in the @code{source-registry}. -Hence, it is strongly advised to define a system - at var{foo} in the corresponding file @var{foo.asd}. +for the directories specified in the @code{source-registry}, +but searches the filesystem only once and caches its results. +The third function makes the @code{package-inferred-system} extension work, + at pxref{The package-inferred-system extension}. + +Because of the way these search functions are defined, +you should put the definition for a system + at var{foo} in a file named @file{foo.asd}, +in a directory that is +in the central registry or +which can be found using the +source registry configuration. + + at c FIXME: Move this discussion to the system definition grammar, or somewhere else. + at anchor{System names} + at cindex System names + at cindex Primary system name + at findex primary-system-name +It is often useful to define multiple systems in a same file, +but ASDF can only locate a system's definition file based on the system +name. +For this reason, +ASDF 3's system search algorithm has been extended to +allow a file @file{foo.asd} to contain +secondary systems named @var{foo/bar}, @var{foo/baz}, @var{foo/quux}, etc., +in addition to the primary system named @var{foo}. +The first component of a system name, +separated by the slash character, @code{/}, +is called the primary name of a system. +The primary name may be +extracted by function @code{asdf::primary-system-name}; +when ASDF 3 is told to find a system whose name has a slash, +it will first attempt to load the corresponding primary system, +and will thus see any such definitions, and/or any +definition of a @code{package-inferred-system}. at footnote{ +ASDF 2.26 and earlier versions +do not support this primary system name convention. +With these versions of ASDF +you must explicitly load @file{foo.asd} +before you can use system @var{foo/bar} defined therein, +e.g. using @code{(asdf:find-system "foo")}. +We do not support ASDF 2, and recommend that you should upgrade to ASDF 3. +} +If your file @file{foo.asd} also defines systems +that do not follow this convention, e.g., a system named @var{foo-test}, +ASDF will not be able to automatically locate a definition for these systems, +and will only see their definition +if you explicitly find or load the primary system +using e.g. @code{(asdf:find-system "foo")} before you try to use them. +We strongly recommend against this practice, +though it is currently supported for backward compatibility. + + at end defun + + at defun primary-system-name name + +Internal (not exported) function, @code{asdf::primary-system-name}. +Returns the primary system name (the portion before +the slash, @code{/}, in a secondary system name) from @var{name}. + + at end defun + + at defun locate-system name + +This function should typically @emph{not} be invoked directly. It is +exported as part of the API only for programmers who wish to provide +their own @code{*system-definition-search-functions*}. + +Given a system @var{name} designator, +try to locate where to load the system definition from. + at c (This does not include the loading of the system definition, + at c which is done by @code{find-system}, + at c or the loading of the system itself, which is done by @code{load-system}; + at c however, for systems the definition of which has already been loaded, + at c @code{locate-system} may return an object of class @code{system}.) +Returns five values: @var{foundp}, @var{found-system}, @var{pathname}, + at var{previous}, and @var{previous-time}. + at var{foundp} is true when a system was found, +either a new as yet unregistered one, or a previously registered one. +The @var{found-system} return value +will be a @code{system} object, if a system definition is found in your +source registry. + at c This system may be registered (by @code{register-system}) or may not, if + at c it's preloaded code. Fare writes: + at c In the case of preloaded code, as for "asdf", "uiop", etc., + at c themselves, the system objects are not registered until after they are + at c initially located by sysdef-preloaded-system-search as a fallback when + at c no source code was found. +The system definition will @emph{not} be +loaded if it hasn't been loaded already. + at var{pathname} when not null is a path from which to load the system, +either associated with @var{found-system}, or with the @var{previous} system. +If @var{previous} is not null, it will be a @emph{previously loaded} + at code{system} object of the same name (note that the system + at emph{definition} is previously-loaded: the system itself may or may not be). + at var{previous-time} when not null is +the timestamp of the previous system definition file, at the +time when the @var{previous} system definition was loaded. + +For example, if your current registry has @file{foo.asd} in + at file{/current/path/to/foo.asd}, +but system @code{foo} was previously loaded from @file{/previous/path/to/foo.asd} +then @var{locate-system} will return the following values: + at enumerate + at item + at var{foundp} will be @code{T}, + at item + at var{found-system} will be @code{NIL}, + at item + at var{pathname} will be @code{#p"/current/path/to/foo.asd"}, + at item + at var{previous} will be an object of type @code{SYSTEM} with + at code{system-source-file} slot value of + at code{#p"/previous/path/to/foo.asd"} + at item + at var{previous-time} will be the timestamp of + at code{#p"/previous/path/to/foo.asd"} at the time it was loaded. + at end enumerate @end defun @defun find-component base path @@ -2725,8 +2851,8 @@ New component types are defined by subclassing one of the existing component classes and specializing methods on the new component class. - at emph{FIXME: this should perhaps be explained more throughly, -not only by example ...} + at c FIXME: this should perhaps be explained more throughly, + at c not only by example ... As an example, suppose we have some implementation-dependent functionality that we want to isolate @@ -2769,10 +2895,10 @@ @c FIXME: Moved this material here, but it isn't very comfortable @c here.... Also needs to be revised to be coherent. -To be successfully buildable, this graph of actions but be acyclic. -If, as a user, extender or implementer of ASDF, you fail -to keep the dependency graph without cycles, -ASDF will fail loudly as it eventually finds one. +To be successfully build-able, this graph of actions must be acyclic. +If, as a user, extender or implementer of ASDF, you introduce +a cycle into the dependency graph, +ASDF will fail loudly. To clearly distinguish the direction of dependencies, ASDF 3 uses the words @emph{requiring} and @emph{required} as applied to an action depending on the other: @@ -2963,7 +3089,7 @@ our source-registry configuration mechanism described below, because it is easier to setup in a portable way across users and implementations. -Addtionally, some people dislike truename, +Additionally, some people dislike truename, either because it is very slow on their system, or because they are using content-addressed storage where the truename of a file is related to a digest of its individual contents, @@ -3251,9 +3377,9 @@ When considering environment variable @code{CL_SOURCE_REGISTRY} ASDF will skip to next configuration if it's an empty string. It will @code{READ} the string as a SEXP in the DSL -if it begins with a paren @code{(} -and it will be interpreted much like @code{TEXINPUTS} -list of paths, where +if it begins with a paren @code{(}, +otherwise it will be interpreted much like @code{TEXINPUTS}, +as a list of paths, where * paths are separated by a @code{:} (colon) on Unix platforms (including cygwin), @@ -3709,7 +3835,7 @@ SYMBOL | ;; symbol naming a function that takes two arguments: ;; the pathname to be translated and the matching ;; DIRECTORY-DESIGNATOR - LAMBDA ;; A form which evalutates to a function taking two arguments: + LAMBDA ;; A form which evaluates to a function taking two arguments: ;; the pathname to be translated and the matching ;; DIRECTORY-DESIGNATOR @@ -3770,7 +3896,7 @@ If the @code{translate-pathname} mechanism cannot achieve a desired translation, the user may provide a function which provides the -required algorithim. Such a translation function is specified by +required algorithm. Such a translation function is specified by supplying a list as the second @code{directory-designator} the first element of which is the keyword @code{:function}, and the second element of which is @@ -5613,3 +5739,6 @@ @printindex vr @bye + + at c LocalWords: clbuild tarballs defsystem Quicklisp initarg uiop fasl + at c LocalWords: namestring initargs fasls Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sat May 17 10:51:33 2014 (r14713) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Fri Jul 18 17:03:20 2014 (r14714) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- -;;; This is ASDF 3.1.2.2: Another System Definition Facility. +;;; This is ASDF 3.1.2.9: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -402,7 +402,7 @@ (imported) (t (push name intern))))))) (labels ((sort-names (names) - (sort names #'string<)) + (sort (copy-list names) #'string<)) (table-keys (table) (loop :for k :being :the :hash-keys :of table :collect k)) (when-relevant (key value) @@ -845,8 +845,8 @@ (uiop/package:define-package :uiop/common-lisp (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) - (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package) - (:reexport :common-lisp) + (:use :uiop/package) + (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) @@ -855,7 +855,7 @@ #:logical-pathname #:translate-logical-pathname #:make-broadcast-stream #:file-namestring) #+genera (:shadowing-import-from :scl #:boolean) - #+genera (:export #:boolean #:ensure-directories-exist) + #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) #+mcl (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) @@ -935,9 +935,20 @@ #+genera (eval-when (:load-toplevel :compile-toplevel :execute) + (unless (fboundp 'lambda) + (defmacro lambda (&whole form &rest bvl-decls-and-body) + (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1)) + `#',(cons 'lisp::lambda (cdr form)))) (unless (fboundp 'ensure-directories-exist) (defun ensure-directories-exist (path) - (fs:create-directories-recursively (pathname path))))) + (fs:create-directories-recursively (pathname path)))) + (unless (fboundp 'read-sequence) + (defun read-sequence (sequence stream &key (start 0) end) + (scl:send stream :string-in nil sequence start end))) + (unless (fboundp 'write-sequence) + (defun write-sequence (sequence stream &key (start 0) end) + (scl:send stream :string-out sequence start end) + sequence))) #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick (read-from-string @@ -1213,7 +1224,7 @@ ;;; Characters (with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. - (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + (defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char))) #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow??? (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) @@ -1390,7 +1401,7 @@ (etypecase fun (function fun) ((or boolean keyword character number pathname) (constantly fun)) - (hash-table (lambda (x) (gethash x fun))) + (hash-table #'(lambda (x) (gethash x fun))) (symbol (fdefinition fun)) (cons (if (eq 'lambda (car fun)) (eval fun) @@ -1750,10 +1761,13 @@ (defun operating-system () "The operating system of the current host" (first-feature - '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + '(:cygwin + (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd - (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + (:solaris :solaris :sunos) + (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) + :unix :genera))) (defun architecture () @@ -2552,7 +2566,7 @@ "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." (let ((sub (when maybe-subpath (pathname maybe-subpath))) - (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) + (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) (or (and base (subpathp sub base)) sub))) (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) @@ -3297,13 +3311,14 @@ directory-pathname (unix:get-unix-error-msg errno)))) #+cormanlisp (win32:delete-directory directory-pathname) #+ecl (si:rmdir directory-pathname) + #+genera (fs:delete-directory directory-pathname) #+lispworks (lw:delete-directory directory-pathname) #+mkcl (mkcl:rmdir directory-pathname) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) @@ -3337,7 +3352,7 @@ (error "~S was asked to delete ~S but the directory does not exist" 'delete-filesystem-tree directory-pathname)) (:ignore nil))) - #-(or allegro cmu clozure sbcl scl) + #-(or allegro cmu clozure genera sbcl scl) ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, ;; except on implementations where we can prevent DIRECTORY from following symlinks; ;; instead spawn a standard external program to do the dirty work. @@ -3347,7 +3362,7 @@ #+allegro (symbol-call :excl.osi :delete-directory-and-files directory-pathname :if-does-not-exist if-does-not-exist) #+clozure (ccl:delete-directory directory-pathname) - #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type)) + #+genera (fs:delete-directory directory-pathname :confirm nil) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) @@ -3995,7 +4010,9 @@ (beforef (gensym "BEFORE")) (afterf (gensym "AFTER"))) `(flet (,@(when before - `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) , at before))) + `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) + ,@(when after `((declare (ignorable ,pathname)))) + , at before))) ,@(when after (assert pathnamep) `((,afterf (,pathname) , at after)))) @@ -4120,7 +4137,7 @@ #+(or cmu scl) (unix:unix-exit code) #+ecl (si:quit code) #+gcl (system:quit code) - #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) + #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) @@ -4144,8 +4161,8 @@ (declare (ignorable stream count condition)) #+abcl (loop :for i :from 0 - :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do - (safe-format! stream "~&~D: ~A~%" i frame)) + :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do + (safe-format! stream "~&~D: ~A~%" i frame)) #+allegro (let ((*terminal-io* stream) (*standard-output* stream) @@ -4169,20 +4186,20 @@ (debug:backtrace (or count most-positive-fixnum) stream)) #+(or ecl mkcl) (let* ((top (si:ihs-top)) - (repeats (if count (min top count) top)) - (backtrace (loop :for ihs :from 0 :below top + (repeats (if count (min top count) top)) + (backtrace (loop :for ihs :from 0 :below top :collect (list (si::ihs-fun ihs) (si::ihs-env ihs))))) (loop :for i :from 0 :below repeats - :for frame :in (nreverse backtrace) :do - (safe-format! stream "~&~D: ~S~%" i frame))) + :for frame :in (nreverse backtrace) :do + (safe-format! stream "~&~D: ~S~%" i frame))) #+gcl (let ((*debug-io* stream)) (ignore-errors (with-safe-io-syntax () - (if condition - (conditions::condition-backtrace condition) - (system::simple-backtrace))))) + (if condition + (conditions::condition-backtrace condition) + (system::simple-backtrace))))) #+lispworks (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) @@ -4196,8 +4213,8 @@ stream) #+xcl (loop :for i :from 0 :below (or count most-positive-fixnum) - :for frame :in (extensions:backtrace-as-list) :do - (safe-format! stream "~&~D: ~S~%" i frame))) + :for frame :in (extensions:backtrace-as-list) :do + (safe-format! stream "~&~D: ~S~%" i frame))) (defun print-backtrace (&rest keys &key stream count condition) "Print a backtrace" @@ -4297,14 +4314,14 @@ ;; SBCL and Allegro already separate user arguments from implementation arguments. #-(or sbcl allegro) (unless (eq *image-dumped-p* :executable) - ;; LispWorks command-line processing isn't transparent to the user - ;; unless you create a standalone executable; in that case, - ;; we rely on cl-launch or some other script to set the arguments for us. - #+lispworks (return *command-line-arguments*) - ;; On other implementations, on non-standalone executables, - ;; we trust cl-launch or whichever script starts the program - ;; to use -- as a delimiter between implementation arguments and user arguments. - #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) + ;; LispWorks command-line processing isn't transparent to the user + ;; unless you create a standalone executable; in that case, + ;; we rely on cl-launch or some other script to set the arguments for us. + #+lispworks (return *command-line-arguments*) + ;; On other implementations, on non-standalone executables, + ;; we trust cl-launch or whichever script starts the program + ;; to use -- as a delimiter between implementation arguments and user arguments. + #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) (rest arguments))) (defun argv0 () @@ -4339,7 +4356,7 @@ Then, comes the restore process itself: First, call each function in the RESTORE-HOOK, -in the order they were registered with REGISTER-RESTORE-HOOK. +in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. Second, evaluate the prelude, which is often Lisp text that is read, as per EVAL-INPUT. Third, call the ENTRY-POINT function, if any is specified, with no argument. @@ -4384,7 +4401,7 @@ (dump-hook *image-dump-hook*) #+clozure prepend-symbols #+clozure (purify t) #+sbcl compression - #+(and sbcl windows) application-type) + #+(and sbcl os-windows) application-type) "Dump an image of the current Lisp environment at pathname FILENAME, with various options. First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of @@ -4458,7 +4475,7 @@ (when compression (list :compression compression)) ;;--- only save runtime-options for standalone executables (when executable (list :toplevel #'restore-image :save-runtime-options t)) - #+(and sbcl windows) ;; passing :application-type :gui will disable the console window. + #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. ;; the default is :console - only works with SBCL 1.1.15 or later. (when application-type (list :application-type application-type))))) #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) @@ -5295,7 +5312,7 @@ #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) (%wait-process-result (apply '%run-program (%normalize-system-command command) :wait t keys)) - #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl) + #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) #+(and lispworks os-windows) (system:call-system %command :current-directory directory :wait t) @@ -5312,6 +5329,8 @@ (*error-output* *stderr*)) (ext:system %command)) #+gcl (system:system %command) + #+genera (error "~S not supported on Genera, cannot run ~S" + '%system %command) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) #+mkcl (mkcl:system %command) #+xcl (system:%run-shell-command %command)))) @@ -6342,7 +6361,7 @@ "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will be applied to the results to yield a configuration form. Current values of TAG include :source-registry and :output-translations." - (let ((files (sort (ignore-errors + (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list (remove-if 'hidden-pathname-p (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) @@ -6639,7 +6658,7 @@ ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.1.2.2") + (asdf-version "3.1.2.9") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -6651,26 +6670,26 @@ (when-upgrading () (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. - ;; NB: it's too late to do anything about functions in UIOP! - ;; If you introduce some critically incompatibility there, you must change name. + ;; NB: it's too late to do anything about functions in UIOP! + ;; If you introduce some critically incompatibility there, you must change name. '(#:component-relative-pathname #:component-parent-pathname ;; component #:source-file-type #:find-system #:system-source-file #:system-relative-pathname ;; system - #:find-component ;; find-component - #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action - #:component-depends-on #:operation-done-p #:component-depends-on - #:traverse ;; backward-interface + #:find-component ;; find-component + #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action + #:component-depends-on #:operation-done-p #:component-depends-on + #:traverse ;; backward-interface #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan - #:operate ;; operate - #:parse-component-form ;; defsystem - #:apply-output-translations ;; output-translations - #:process-output-translations-directive - #:inherit-source-registry #:process-source-registry ;; source-registry - #:process-source-registry-directive - #:trivial-system-p)) ;; bundle - (redefined-classes + #:operate ;; operate + #:parse-component-form ;; defsystem + #:apply-output-translations ;; output-translations + #:process-output-translations-directive + #:inherit-source-registry #:process-source-registry ;; source-registry + #:process-source-registry-directive + #:trivial-system-p)) ;; bundle + (redefined-classes ;; redefining the classes causes interim circularities - ;; with the old ASDF during upgrade, and many implementations bork + ;; with the old ASDF during upgrade, and many implementations bork '((#:compile-concatenated-source-op (#:operation) ())))) (loop :for name :in redefined-functions :for sym = (find-symbol* name :asdf nil) :do @@ -6678,12 +6697,12 @@ ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh. #-clisp (fmakunbound sym))) (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf)) - (find-symbol* s p nil))) - (asyms (l) (mapcar #'asym l))) + (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))))))) + :for sym = (find-symbol* name :asdf nil) + :when (and sym (find-class sym)) + :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) ;;; Self-upgrade functions @@ -7144,8 +7163,9 @@ (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache - #:do-asdf-cache #:normalize-namestring - #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) + #:do-asdf-cache #:normalize-namestring + #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache* + #:clear-configuration-and-retry #:retry)) (in-package :asdf/cache) ;;; This stamp cache is useful for: @@ -7181,8 +7201,17 @@ (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) (if (and *asdf-cache* (not override)) (funcall fun) - (let ((*asdf-cache* (make-hash-table :test 'equal))) - (funcall fun))))) + (loop + (restart-case + (let ((*asdf-cache* (make-hash-table :test 'equal))) + (return (funcall fun))) + (retry () + :report (lambda (s) + (format s (compatfmt "~@")))) + (clear-configuration-and-retry () + :report (lambda (s) + (format s (compatfmt "~@"))) + (clear-configuration))))))) (defmacro with-asdf-cache ((&key key override) &body body) `(call-with-asdf-cache #'(lambda () , at body) :override ,override :key ,key)) @@ -7309,8 +7338,8 @@ (defun clear-defined-systems () ;; Invalidate all systems but ASDF itself, if registered. (loop :for name :being :the :hash-keys :of *defined-systems* - :unless (equal name "asdf") - :do (clear-defined-system name))) + :unless (equal name "asdf") + :do (clear-defined-system name))) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) @@ -7563,82 +7592,73 @@ Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME FOUNDP is true when a system was found, either a new unregistered one or a previously registered one. -FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is -PATHNAME when not null is a path from where to load the system, +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed. +PATHNAME when not null is a path from which to load the system, either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." - (with-asdf-cache (:key `(locate-system ,name)) - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (cond - (previous (setf found nil pathname nil)) - (t - (setf found (sysdef-preloaded-system-search "asdf")) - (assert (typep found 'system)) - (setf found-system found pathname nil)))) - (values foundp found-system pathname previous previous-time)))) + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (setf found (sysdef-preloaded-system-search "asdf")) + (assert (typep found 'system)) + (setf found-system found pathname nil)))) + (values foundp found-system pathname previous previous-time))) (defmethod find-system ((name string) &optional (error-p t)) (with-asdf-cache (:key `(find-system ,name)) (let ((primary-name (primary-system-name name))) (unless (equal name primary-name) (find-system primary-name nil))) - (loop - (restart-case - (multiple-value-bind (foundp found-system pathname previous previous-time) - (locate-system name) - (when (and found-system (eq found-system previous) - (or (first (gethash `(find-system ,name) *asdf-cache*)) - (and *immutable-systems* (gethash name *immutable-systems*)))) - (return found-system)) - (assert (eq foundp (and (or found-system pathname previous) t))) - (let ((previous-pathname (and previous (system-source-file previous))) - (system (or previous found-system))) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and system pathname) - (setf (system-source-file system) pathname)) - (when (and pathname - (let ((stamp (get-file-stamp pathname))) - (and stamp - (not (and previous - (or (pathname-equal pathname previous-pathname) - (and pathname previous-pathname - (pathname-equal - (physicalize-pathname pathname) - (physicalize-pathname previous-pathname)))) - (stamp<= stamp previous-time)))))) - ;; only load when it's a pathname that is different or has newer content, and not an old asdf - (load-asd pathname :name name))) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed - (return - (cond - (in-memory - (when pathname - (setf (car in-memory) (get-file-stamp pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name)))))) - (reinitialize-source-registry-and-retry () - :report (lambda (s) - (format s (compatfmt "~@") name)) - (unset-asdf-cache-entry `(locate-system ,name)) - (initialize-source-registry))))))) - + (or (and *immutable-systems* (gethash name *immutable-systems*) + (cdr (system-registered-p name))) + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (assert (eq foundp (and (or found-system pathname previous) t))) + (let ((previous-pathname (and previous (system-source-file previous))) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (when (and pathname + (let ((stamp (get-file-stamp pathname))) + (and stamp + (not (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) + (stamp<= stamp previous-time)))))) + ;; only load when it's a pathname that is different or has newer content, and not an old asdf + (load-asd pathname :name name))) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (cond + (in-memory + (when pathname + (setf (car in-memory) (get-file-stamp pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)) + (t ;; not found: don't keep negative cache, see lp#1335323 + (unset-asdf-cache-entry `(locate-system ,name)) + (return-from find-system nil))))))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -7748,10 +7768,10 @@ (and (typep c 'missing-dependency) (eq (missing-required-by c) component) (equal (missing-requires c) name)))) - (unless (component-parent component) - (let ((name (coerce-name name))) - (unset-asdf-cache-entry `(find-system ,name)) - (unset-asdf-cache-entry `(locate-system ,name)))))))) + (unless (component-parent component) + (let ((name (coerce-name name))) + (unset-asdf-cache-entry `(find-system ,name)) + (unset-asdf-cache-entry `(locate-system ,name)))))))) (defun resolve-dependency-spec (component dep-spec) @@ -9049,7 +9069,8 @@ component-directed strategy for how to load or compile systems.") (defmethod component-depends-on ((o prepare-op) (s system)) - `((,*load-system-operation* ,@(component-sideway-dependencies s)))) + (loop :for (o . cs) :in (call-next-method) + :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs))) (defclass build-op (non-propagating-operation) () (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, @@ -9060,7 +9081,8 @@ if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION* that will load the system in the current image, and its typically LOAD-OP.")) (defmethod component-depends-on ((o build-op) (c component)) - `((,(or (component-build-operation c) *load-system-operation*) ,c))) + `((,(or (component-build-operation c) *load-system-operation*) ,c) + ,@(call-next-method))) (defun make (system &rest keys) "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). @@ -11223,11 +11245,13 @@ #:package-inferred-system-missing-package-error #:operation-definition-warning #:operation-definition-error - #:try-recompiling + #:try-recompiling ; restarts #:retry - #:accept ; restarts + #:accept #:coerce-entry-to-directory #:remove-entry-from-registry + #:clear-configuration-and-retry + #:*encoding-detection-hook* #:*encoding-external-format-hook* @@ -11263,7 +11287,8 @@ #:user-source-registry #:system-source-registry #:user-source-registry-directory - #:system-source-registry-directory)) + #:system-source-registry-directory + )) ;;;; --------------------------------------------------------------------------- ;;;; ASDF-USER, where the action happens.