June 2025 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][master] 2 commits: Fix #417: Allow repeated lambda var in defmethod aux variables
by Raymond Toy (＠rtoy) 30 Jun '25

30 Jun '25

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6dba253c by Raymond Toy at 2025-06-30T08:36:53-07:00 Fix #417: Allow repeated lambda var in defmethod aux variables - - - - - 4e2e7fec by Raymond Toy at 2025-06-30T08:36:53-07:00 Merge branch 'issue-417-defmethod-check-aux-vars' into 'master' Fix #417: Allow repeated lambda var in defmethod aux variables Closes #417 See merge request cmucl/cmucl!306 - - - - - 2 changed files: - src/pcl/low.lisp - tests/pcl/defmethod.lisp Changes: ===================================== src/pcl/low.lisp ===================================== @@ -357,15 +357,20 @@ the compiler as completely as possible. Currently this means that (when morep (simple-program-error "~@<~s not allowed here~@:>" 'c:&more)) (collect ((vars)) - (labels ((check-var (var) - (cond ((not (symbolp var)) - (simple-program-error - "~@<Invalid lambda variable: ~s~@:>" var)) - ((memq var (vars)) - (simple-program-error - "~@<Repeated lambda variable: ~s~@:>" var)) - (t - (vars var)))) + (labels ((check-lambda-variable (var) + (unless (symbolp var) + (simple-program-error + "~@<Invalid lambda variable: ~s~@:>" var))) + (check-var (var) + (check-lambda-variable var) + (if (memq var (vars)) + (simple-program-error + "~@<Repeated lambda variable: ~s~@:>" var) + (vars var))) + (check-aux (var) + (if (consp var) + (check-lambda-variable (car var)) + (check-lambda-variable var))) (check-required (var) (if (and (consp var) specialized-p) (check-var (car var)) @@ -385,7 +390,7 @@ the compiler as completely as possible. Currently this means that (mapc #'check-optional optional) (mapc #'check-optional keys) (when restp (check-var rest)) - (mapc #'check-optional aux) + (mapc #'check-aux aux) (values required optional restp rest keyp keys allow-other-keys-p aux))))) ===================================== tests/pcl/defmethod.lisp ===================================== @@ -74,7 +74,10 @@ (define-defmethod-test-1 defmethod.20 dm2 nil (x)) (define-defmethod-test-1 defmethod.21 dm2 nil (x &optional y z)) (define-defmethod-test-1 defmethod.22 dm2 nil (x &key y)) - +(define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux (x x) (y y))) +(define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux z)) +(define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux z z)) +(define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux z (z z))) ;;; ;;; A forward-referenced class used as specializer signaled an ;;; error at some point. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/32b155380ff18245c64664… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/32b155380ff18245c64664… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #415: Add support for package-local-nicknames
by Raymond Toy (＠rtoy) 30 Jun '25

30 Jun '25

Raymond Toy pushed to branch master at cmucl / cmucl Commits: aeab122e by Raymond Toy at 2025-06-30T07:18:34-07:00 Fix #415: Add support for package-local-nicknames - - - - - 32b15538 by Raymond Toy at 2025-06-30T07:18:34-07:00 Merge branch 'issue-415-add-package-local-nicknames' into 'master' Fix #415: Add support for package-local-nicknames Closes #415 See merge request cmucl/cmucl!305 - - - - - 7 changed files: - bin/run-unit-tests.sh - src/bootfiles/21e/boot-2024-08.lisp - src/code/exports.lisp - src/code/package.lisp - src/code/print.lisp - src/contrib/asdf/asdf.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== bin/run-unit-tests.sh ===================================== @@ -76,3 +76,24 @@ else $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))" fi +## Now run tests for trivial-package-local-nicknames +REPO=trivial-package-local-nicknames-mirror +BRANCH=cmucl-updates + +set -x +if [ -d ../$REPO ]; then + (cd ../$REPO || exit 1; git stash; git checkout $BRANCH; git pull --rebase) +else + (cd ..; git clone https://gitlab.common-lisp.net/cmucl/trivial-package-local-nicknames-mirror…) +fi + +LISP=$PWD/$LISP +cd ../$REPO || exit 1 +git checkout $BRANCH + +# Run the tests. Exits with a non-zero code if there's a failure. +$LISP -noinit -nositeinit -batch <<'EOF' +(require :asdf) +(push (default-directory) asdf:*central-registry*) +(asdf:test-system :trivial-package-local-nicknames) +EOF ===================================== src/bootfiles/21e/boot-2024-08.lisp ===================================== @@ -8,3 +8,125 @@ (declare (ignore c)) (invoke-restart 'continue)))) (defconstant +ef-max+ 14)) + +;;; Bootstrap for adding %local-nicknames to package structure. +(in-package :lisp) + +(intern "PACKAGE-LOCAL-NICKNAMES" "LISP") +(intern "ADD-PACKAGE-LOCAL-NICKNAME" "LISP") +(intern "REMOVE-PACKAGE-LOCAL-NICKNAME" "LISP") +(intern "PACKAGE-LOCALLY-NICKNAMED-BY-LIST" "LISP") + +;; Make sure we don't accidentally load fasls from somewhere. +(setf (ext:search-list "target:") + '("src/")) + +;; Ensure all packages have been set up, since package definition is broken +;; once this file has been loaded: +(load "target:code/exports-errno" :if-does-not-exist nil) +(load "target:code/exports") + +(setf *enable-package-locked-errors* nil) + +;;; +;;; Like DEFSTRUCT, but silently clobber old definitions. +;;; +(defmacro defstruct! (name &rest stuff) + `(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::clobber-it)))) + (defstruct ,name ,@stuff))) + + +(defstruct! (package + (:constructor internal-make-package) + (:predicate packagep) + (:print-function %print-package) + (:make-load-form-fun + (lambda (package) + (values `(package-or-lose ',(package-name package)) + nil)))) + (tables (list nil)) ; A list of all the hashtables for inherited symbols. + (%name nil :type (or simple-string null)) + (%nicknames () :type list) + (%use-list () :type list) + (%used-by-list () :type list) + (internal-symbols (required-argument) :type package-hashtable) + (external-symbols (required-argument) :type package-hashtable) + (%shadowing-symbols () :type list) + (lock nil :type boolean) + (definition-lock nil :type boolean) + (%local-nicknames () :type list) + (doc-string nil :type (or simple-string null))) + +;; Need to define this with the extra arg because compiling pcl uses +;; defpackage and we need this defined. This isn't the actual +;; implementation; we just added the extra arg. +(defun %defpackage (name nicknames size shadows shadowing-imports + use imports interns exports doc-string &optional local-nicknames) + (declare (type simple-base-string name) + (type list nicknames local-nicknames shadows shadowing-imports + imports interns exports) + (type (or list (member :default)) use) + (type (or simple-base-string null) doc-string)) + (let ((package (or (find-package name) + (progn + (when (eq use :default) + (setf use *default-package-use-list*)) + (make-package name + :use nil + :internal-symbols (or size 10) + :external-symbols (length exports)))))) + (unless (string= (the string (package-name package)) name) + (error 'simple-package-error + :package name + :format-control (intl:gettext "~A is a nick-name for the package ~A") + :format-arguments (list name (package-name name)))) + (enter-new-nicknames package nicknames) + ;; Shadows and Shadowing-imports. + (let ((old-shadows (package-%shadowing-symbols package))) + (shadow shadows package) + (dolist (sym-name shadows) + (setf old-shadows (remove (find-symbol sym-name package) old-shadows))) + (dolist (simports-from shadowing-imports) + (let ((other-package (package-or-lose (car simports-from)))) + (dolist (sym-name (cdr simports-from)) + (let ((sym (find-or-make-symbol sym-name other-package))) + (shadowing-import sym package) + (setf old-shadows (remove sym old-shadows)))))) + (when old-shadows + (warn (intl:gettext "~A also shadows the following symbols:~% ~S") + name old-shadows))) + ;; Use + (unless (eq use :default) + (let ((old-use-list (package-use-list package)) + (new-use-list (mapcar #'package-or-lose use))) + (use-package (set-difference new-use-list old-use-list) package) + (let ((laterize (set-difference old-use-list new-use-list))) + (when laterize + (unuse-package laterize package) + (warn (intl:gettext "~A previously used the following packages:~% ~S") + name + laterize))))) + ;; Import and Intern. + (dolist (sym-name interns) + (intern sym-name package)) + (dolist (imports-from imports) + (let ((other-package (package-or-lose (car imports-from)))) + (dolist (sym-name (cdr imports-from)) + (import (list (find-or-make-symbol sym-name other-package)) + package)))) + ;; Exports. + (let ((old-exports nil) + (exports (mapcar #'(lambda (sym-name) (intern sym-name package)) + exports))) + (do-external-symbols (sym package) + (push sym old-exports)) + (export exports package) + (let ((diff (set-difference old-exports exports))) + (when diff + (warn (intl:gettext "~A also exports the following symbols:~% ~S") + name diff)))) + ;; Documentation + (setf (package-doc-string package) doc-string) + package)) ===================================== src/code/exports.lisp ===================================== @@ -1857,6 +1857,11 @@ (:import-from "KERNEL" "*ANSI-DEFSTRUCT-OPTIONS-P*") (:import-from "SYSTEM" "MAKE-INDENTING-STREAM" "INDENTING-STREAM-P" "BINARY-TEXT-STREAM") + (:import-from "LISP" + "PACKAGE-LOCAL-NICKNAMES" + "ADD-PACKAGE-LOCAL-NICKNAME" + "REMOVE-PACKAGE-LOCAL-NICKNAME" + "PACKAGE-LOCALLY-NICKNAMED-BY-LIST") #+double-double (:import-from "KERNEL" "DOUBLE-DOUBLE-FLOAT" "DD-PI") (:export "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*" @@ -2109,7 +2114,12 @@ "DESCRIBE-EXTERNAL-FORMAT" "LIST-ALL-EXTERNAL-FORMATS" "STRING-ENCODE" "STRING-DECODE" - "SET-SYSTEM-EXTERNAL-FORMAT")) + "SET-SYSTEM-EXTERNAL-FORMAT") + ;; Package-local-nicknames + (:export "PACKAGE-LOCAL-NICKNAMES" + "ADD-PACKAGE-LOCAL-NICKNAME" + "REMOVE-PACKAGE-LOCAL-NICKNAME" + "PACKAGE-LOCALLY-NICKNAMED-BY-LIST")) (defpackage "STREAM" (:import-from "SYSTEM" "LISP-STREAM") ===================================== src/code/package.lisp ===================================== @@ -41,6 +41,8 @@ #+relative-package-names (sys:register-lisp-feature :relative-package-names) +(sys:register-lisp-feature :package-local-nicknames) + (defvar *default-package-use-list* '("COMMON-LISP") "The list of packages to use by default of no :USE argument is supplied to MAKE-PACKAGE or other package creation forms.") @@ -91,6 +93,9 @@ (lock nil :type boolean) (definition-lock nil :type boolean) + ;; Package local nicknames + (%local-nicknames () :type list) + ;; Documentation string for this package (doc-string nil :type (or simple-string null))) @@ -397,6 +402,12 @@ (setq package tmp)) (relative-to package name)))))))) +(defun local-nickname-to-package (name) + ;; Skip all of this if we're doing package-init! + (unless *in-package-init* + (cdr (assoc name (package-%local-nicknames *package*) + :test #'string=)))) + ;;; find-package -- Public ;;; ;;; @@ -405,7 +416,8 @@ (if (packagep name) name (let ((name (package-namify name))) - (or (package-name-to-package name) + (or (local-nickname-to-package name) + (package-name-to-package name) #+relative-package-names (relative-package-name-to-package name))))) @@ -420,7 +432,8 @@ thing) (t (let ((thing (package-namify thing))) - (cond ((package-name-to-package thing)) + (cond ((local-nickname-to-package thing)) + ((package-name-to-package thing)) (t ;; ANSI spec's type-error where this is called. But, ;; but the resulting message is somewhat unclear. @@ -923,8 +936,10 @@ (:EXPORT {symbol-name}*) (:INTERN {symbol-name}*) (:SIZE <integer>) + (:LOCAL-NICKNAMES {({nickname package}*)}) All options except :SIZE and :DOCUMENTATION can be used multiple times." (let ((nicknames nil) + (local-nicknames nil) (size nil) (shadows nil) (shadowing-imports nil) @@ -940,6 +955,11 @@ (case (car option) (:nicknames (setf nicknames (stringify-names (cdr option) "package"))) + (:local-nicknames + (setf local-nicknames + (mapcar #'(lambda (o) + (stringify-names o "package")) + (cdr option)))) (:size (cond (size (simple-program-error (intl:gettext "Can't specify :SIZE twice."))) @@ -994,9 +1014,9 @@ `(:shadowing-import-from ,@(apply #'append (mapcar #'rest shadowing-imports)))) `(eval-when (compile load eval) - (%defpackage ,(stringify-name package "package") ',nicknames ',size - ',shadows ',shadowing-imports ',(if use-p use :default) - ',imports ',interns ',exports ',doc)))) + (%defpackage ,(stringify-name package "package") ',nicknames + ',size ',shadows ',shadowing-imports ',(if use-p use :default) + ',imports ',interns ',exports ',doc ',local-nicknames)))) (defun check-disjoint (&rest args) ;; Check whether all given arguments specify disjoint sets of symbols. @@ -1014,9 +1034,9 @@ key1 key2 common)))) (defun %defpackage (name nicknames size shadows shadowing-imports - use imports interns exports doc-string) + use imports interns exports doc-string &optional local-nicknames) (declare (type simple-base-string name) - (type list nicknames shadows shadowing-imports + (type list nicknames local-nicknames shadows shadowing-imports imports interns exports) (type (or list (member :default)) use) (type (or simple-base-string null) doc-string)) @@ -1034,6 +1054,7 @@ :format-control (intl:gettext "~A is a nick-name for the package ~A") :format-arguments (list name (package-name name)))) (enter-new-nicknames package nicknames) + (enter-new-local-nicknames package local-nicknames) ;; Shadows and Shadowing-imports. (let ((old-shadows (package-%shadowing-symbols package))) (shadow shadows package) @@ -1128,6 +1149,12 @@ (setf (gethash n *package-names*) package) (push n (package-%nicknames package))))))) +(defun enter-new-local-nicknames (package local-nicknames) + (dolist (entry local-nicknames) + (destructuring-bind (nick actual) + entry + (add-package-local-nickname nick actual package)))) + ;;; Make-Package -- Public ;;; @@ -1225,6 +1252,14 @@ (enter-new-nicknames package new-nicknames) package)) +;; Given a package designator, convert it to the corresponding package +;; object. +(declaim (inline designator-package)) +(defun designator-package (designator) + (if (packagep designator) + designator + (package-name-to-package (package-namify designator)))) + ;;; Delete-Package -- Public ;;; (defun delete-package (package-or-name) @@ -1254,6 +1289,13 @@ (mapcar #'package-name use-list)))) (dolist (p use-list) (unuse-package package p)))) + ;; Find all the packages that have a local nickname to this + ;; package and remove the local nickname entry. + (dolist (pkg (package-locally-nicknamed-by-list package)) + (setf (package-%local-nicknames pkg) + (delete package + (package-%local-nicknames pkg) + :key #'cdr))) (dolist (used (package-use-list package)) (unuse-package used package)) (do-symbols (sym package) @@ -1928,7 +1970,128 @@ (result symbol)) string package) (result))) - + +;;;; Support for package local nicknames + +;;; PACKAGE-LOCAL-NICKNAMES -- public. +;;; +(defun package-local-nicknames (package) + "Returns an alist of (local-nickname . actual-package) describing the + nicknames local to Package." + ;; Should we return a new list? + (copy-list (package-%local-nicknames (designator-package package)))) + +;;; ADD-PACKAGE-LOCAL-NICKNAME -- public. +;;; +(defun add-package-local-nickname (local-nickname actual-package &optional (package *package*)) + "For the designated package Package (defaulting to *PACKAGE*), add + Local-Nickname as a package local nickname to the package + Actual-Package. Actual-Package and Package must be an package + designator. Local-Nickname should be a string designator. + + Returns the designated package. + + Signals a continuable error if any of the following are true: + - Local-Nickname is already a local nickname for a different package + - Local-Nickname is one of \"CL\", \"COMMON-LISP\", or \"KEYWORD\" + - Local-Nickname is a global name or nickname for designated package" + + (let* ((pkg (designator-package package)) + (actual-pkg (designator-package actual-package)) + (nicks (package-%local-nicknames pkg)) + (local-nickname (package-namify local-nickname))) + (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD") + :test #'string=) + (cerror "Add nickname anyway" + 'simple-package-error + :package pkg + :format-control (intl:gettext "Local nickname cannot be \"CL\", \"COMMON-LISP\" or \"KEYWORD\"") + :format-arguments (list local-nickname))) + (let ((found-it (find-if #'(lambda (nick) + (string= nick local-nickname)) + nicks :key #'car))) + (when found-it + ;; If the local nickname alread exists and it's the same + ;; package, there's nothing to do. + (when (eq (cdr found-it) actual-pkg) + (return-from add-package-local-nickname pkg)) + ;; Otherwise, signal an error that the packages don't match. + (restart-case + (error 'simple-package-error + :package pkg + :format-control (intl:gettext "~A is already a local nickname for the package ~A in ~A") + :format-arguments (list local-nickname actual-pkg pkg)) + (keep-old-nickname () + :report (lambda (stream) + (format stream "Keep ~A as a local nickname for ~A~%" + local-nickname (cdr found-it))) + (return-from add-package-local-nickname (cdr found-it))) + (use-new-nickname () + :report (lambda (stream) + (format stream "Use ~A as a local nickname for ~A instead~%" + local-nickname actual-pkg)) + (setf (cdr found-it) actual-pkg) + (return-from add-package-local-nickname actual-pkg))))) + + ;; The new LOCAL-NICKNAME can't be the same as PACKAGE. + (when (string= local-nickname (package-name pkg)) + (cerror "Add nickname anyway" + 'simple-package-error + :package pkg + :format-control (intl:gettext "~A cannot be a package local nickname for the global package~_ ~A with the same name") + :format-arguments (list local-nickname pkg))) + + ;; Can't be a local nickname for any of the nicknames + (let ((found-it (find local-nickname + (package-nicknames pkg) + :test #'string=))) + (when found-it + (cerror "Use it as a local nickname anyway" + 'simple-package-error + :format-control (intl:gettext "~A cannot be a package local nickname for the global package~_ ~A with nickname ~A") + :format-arguments (list local-nickname pkg found-it)))) + + (setf (package-%local-nicknames pkg) + (push (cons local-nickname + (designator-package actual-package)) + nicks)) + pkg)) + +;;; REMOVE-PACKAGE-LOCAL-NICKNAME -- public. +;;; +(defun remove-package-local-nickname (old-nickname &optional (package *package*)) + "If Package has Old-Nickname as a local nickname, it is removed. + Returns true if the nickname existed and was removed. Otherwise + returns NIL." + (let* ((old-nick (if (packagep old-nickname) + (package-namestring old-nickname) + (package-namify old-nickname))) + (pkg (designator-package package)) + (nicks (package-%local-nicknames pkg)) + deletedp) + (setf (package-%local-nicknames pkg) + (delete-if #'(lambda (local-nick) + (when (string= local-nick old-nick) + (setf deletedp t))) + nicks :key #'car)) + deletedp)) + +;;; PACKAGE-LOCALLY-NICKNAMED-BY-LIST -- public +;;; +;;; FIXME: This is pretty inefficient because we have list all the +;;; packages and look throught the %local-nicknames to find the +;;; packages. We could probably make it faster if we added a new slot +;;; to the package structure similar to how we have %use-list and +;;; %used-by-list. +(defun package-locally-nicknamed-by-list (package) + "Returns a list of packages which have a local nickname for Package." + (let ((pkg (designator-package package))) + (loop for p in (list-all-packages) + when (find pkg + (package-%local-nicknames p) + :key #'cdr + :test #'eq) + collect p))) ;;; Initialization. ===================================== src/code/print.lisp ===================================== @@ -696,7 +696,15 @@ ;; qualified. This can happen if the symbol has been inherited ;; from a package other than its home package. (unless (and accessible (eq symbol object)) - (output-symbol-name (package-name package) stream) + ;; If the actual symbol package has a local nickname in + ;; *package*, use that as the package name instead of the + ;; actual symbol package name. + (let ((local-nicks (package-%local-nicknames *package*)) + (pkg-name (package-name package))) + (when local-nicks + (setf pkg-name (or (car (rassoc package local-nicks)) + pkg-name))) + (output-symbol-name pkg-name stream)) (multiple-value-bind (symbol externalp) (find-external-symbol name package) (declare (ignore symbol)) ===================================== src/contrib/asdf/asdf.lisp ===================================== @@ -138,7 +138,7 @@ #+(or clasp abcl ecl cmu) #:ext #+ccl #:ccl #+lispworks #:hcl - #-(or allegro sbcl clasp abcl ccl lispworks ecl) + #-(or allegro sbcl clasp abcl ccl lispworks ecl cmu) (error "Don't know from which package this lisp supplies the local-package-nicknames API.") #:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname) (:export ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8208,6 +8208,7 @@ msgid "" " (:EXPORT {symbol-name}*)\n" " (:INTERN {symbol-name}*)\n" " (:SIZE <integer>)\n" +" (:LOCAL-NICKNAMES {({nickname package}*)})\n" " All options except :SIZE and :DOCUMENTATION can be used multiple times." msgstr "" @@ -8551,6 +8552,58 @@ msgid "" " found instead of describing them." msgstr "" +#: src/code/package.lisp +msgid "" +"Returns an alist of (local-nickname . actual-package) describing the\n" +" nicknames local to Package." +msgstr "" + +#: src/code/package.lisp +msgid "" +"For the designated package Package (defaulting to *PACKAGE*), add\n" +" Local-Nickname as a package local nickname to the package\n" +" Actual-Package. Actual-Package and Package must be an package\n" +" designator. Local-Nickname should be a string designator.\n" +"\n" +" Returns the designated package.\n" +"\n" +" Signals a continuable error if any of the following are true:\n" +" - Local-Nickname is already a local nickname for a different package\n" +" - Local-Nickname is one of \"CL\", \"COMMON-LISP\", or \"KEYWORD\"\n" +" - Local-Nickname is a global name or nickname for designated package" +msgstr "" + +#: src/code/package.lisp +msgid "Local nickname cannot be \"CL\", \"COMMON-LISP\" or \"KEYWORD\"" +msgstr "" + +#: src/code/package.lisp +msgid "~A is already a local nickname for the package ~A in ~A" +msgstr "" + +#: src/code/package.lisp +msgid "" +"~A cannot be a package local nickname for the global package~_ ~A with the " +"same name" +msgstr "" + +#: src/code/package.lisp +msgid "" +"~A cannot be a package local nickname for the global package~_ ~A with " +"nickname ~A" +msgstr "" + +#: src/code/package.lisp +msgid "" +"If Package has Old-Nickname as a local nickname, it is removed.\n" +" Returns true if the nickname existed and was removed. Otherwise\n" +" returns NIL." +msgstr "" + +#: src/code/package.lisp +msgid "Returns a list of packages which have a local nickname for Package." +msgstr "" + #: src/code/reader.lisp msgid "Float format for 1.0E1" msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9e6d1350be52233897d702… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9e6d1350be52233897d702… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-417-defmethod-check-aux-vars] Add suggested tests for &aux variables
by Raymond Toy (＠rtoy) 30 Jun '25

30 Jun '25

Raymond Toy pushed to branch issue-417-defmethod-check-aux-vars at cmucl / cmucl Commits: 47cca507 by Raymond Toy at 2025-06-30T07:14:32-07:00 Add suggested tests for &aux variables Tests suggested by @cshapiro in the MR review. - - - - - 1 changed file: - tests/pcl/defmethod.lisp Changes: ===================================== tests/pcl/defmethod.lisp ===================================== @@ -75,7 +75,9 @@ (define-defmethod-test-1 defmethod.21 dm2 nil (x &optional y z)) (define-defmethod-test-1 defmethod.22 dm2 nil (x &key y)) (define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux (x x) (y y))) - +(define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux z)) +(define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux z z)) +(define-defmethod-test-1 defmethod.23 dm2 nil (x y &aux z (z z))) ;;; ;;; A forward-referenced class used as specializer signaled an ;;; error at some point. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/47cca5074fba48e985445e1… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/47cca5074fba48e985445e1… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-408-get-user-name-and-homedir] Add some more comments and update some others
by Raymond Toy (＠rtoy) 27 Jun '25

27 Jun '25

Raymond Toy pushed to branch issue-408-get-user-name-and-homedir at cmucl / cmucl Commits: 8dd89bb8 by Raymond Toy at 2025-06-27T13:56:04-07:00 Add some more comments and update some others Add comment that the caller must free the space for the string that is returned. Add some comments for get_homedir_from_uid. - - - - - 1 changed file: - src/lisp/os-common.c Changes: ===================================== src/lisp/os-common.c ===================================== @@ -788,7 +788,8 @@ again: /* * Given the UID, return the user name. If the uid does not exist, - * returns NULL. + * returns NULL. The caller must call free on the string that is + * returned. */ char * os_get_username(uid_t uid) @@ -970,6 +971,13 @@ get_homedir_from_name(const char* name, int *status) return NULL; } +/* + * Return the home directory for the given UID. If the home directory + * does not exist, NULL is returned. STATUS is set to 0 if the home + * directory could be found. Otherwise, it is the errno. + * + * The caller must free the memory returned. + */ static char * get_homedir_from_uid(uid_t uid, int *status) { @@ -991,6 +999,8 @@ get_homedir_from_uid(uid_t uid, int *status) * home directory cannot be determined for any reason. The parameter * STATUS is 0 if the home directory could be determined. Otherwise * it is the errno value. + * + * The caller must free the memory returned for the result. */ char * os_get_user_homedir(const char* name, int *status) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8dd89bb8f8a52075ac5b4ec… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8dd89bb8f8a52075ac5b4ec… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-415-add-package-local-nicknames] Update pot file because string changed
by Raymond Toy (＠rtoy) 27 Jun '25

27 Jun '25

Raymond Toy pushed to branch issue-415-add-package-local-nicknames at cmucl / cmucl Commits: ff03bdda by Raymond Toy at 2025-06-27T07:33:03-07:00 Update pot file because string changed Typo in string. [skip-ci] - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8578,7 +8578,7 @@ msgid "Local nickname cannot be \"CL\", \"COMMON-LISP\" or \"KEYWORD\"" msgstr "" #: src/code/package.lisp -msgid "~A as already a local nickname for the package ~A in ~A" +msgid "~A is already a local nickname for the package ~A in ~A" msgstr "" #: src/code/package.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ff03bdda91960043d37dc5a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ff03bdda91960043d37dc5a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-417-defmethod-check-aux-vars] Apply 1 suggestion(s) to 1 file(s)
by Raymond Toy (＠rtoy) 25 Jun '25

25 Jun '25

Raymond Toy pushed to branch issue-417-defmethod-check-aux-vars at cmucl / cmucl Commits: 81257d6b by Raymond Toy at 2025-06-25T06:32:25-07:00 Apply 1 suggestion(s) to 1 file(s) Co-authored-by: Carl Shapiro <cshapiro(a)panix.com> - - - - - 1 changed file: - src/pcl/low.lisp Changes: ===================================== src/pcl/low.lisp ===================================== @@ -357,41 +357,40 @@ the compiler as completely as possible. Currently this means that (when morep (simple-program-error "~@<~s not allowed here~@:>" 'c:&more)) (collect ((vars)) - (labels ((check-var (var &optional allow-repeated-lambda-vars) - (cond ((not (symbolp var)) - (simple-program-error - "~@<Invalid lambda variable: ~s~@:>" var)) - ((and (not allow-repeated-lambda-vars) - (memq var (vars))) - (simple-program-error - "~@<Repeated lambda variable: ~s~@:>" var)) - (t - (vars var)))) + (labels ((check-lambda-variable (var) + (unless (symbolp var) + (simple-program-error + "~@<Invalid lambda variable: ~s~@:>" var))) + (check-var (var) + (check-lambda-variable var) + (if (memq var (vars)) + (simple-program-error + "~@<Repeated lambda variable: ~s~@:>" var) + (vars var))) + (check-aux (var) + (if (consp var) + (check-lambda-variable (car var)) + (check-lambda-variable var))) (check-required (var) (if (and (consp var) specialized-p) (check-var (car var)) (check-var var))) - (check-optional (var &optional allow-repeated-lambda-vars) + (check-optional (var) (if (consp var) (destructuring-bind (var &optional value supplied-p) var (declare (ignore value)) (if (consp var) - (check-var (cadr var) allow-repeated-lambda-vars) - (check-var var allow-repeated-lambda-vars)) + (check-var (cadr var)) + (check-var var)) (when supplied-p - (check-var supplied-p allow-repeated-lambda-vars))) + (check-var supplied-p))) (check-var var)))) (mapc #'check-required required) (mapc #'check-optional optional) (mapc #'check-optional keys) (when restp (check-var rest)) - (mapc #'(lambda (v) - ;; Aux variables in DEFMETHODs can, of course, have - ;; repeated lambda vars, just like DEFUN allows - ;; them. - (check-optional v t)) - aux) + (mapc #'check-aux aux) (values required optional restp rest keyp keys allow-other-keys-p aux))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/81257d6bb6b23e04c83ece4… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/81257d6bb6b23e04c83ece4… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-415-add-package-local-nicknames] Fix a few typos in comments and strings.
by Raymond Toy (＠rtoy) 24 Jun '25

24 Jun '25

Raymond Toy pushed to branch issue-415-add-package-local-nicknames at cmucl / cmucl Commits: 7494d5bd by Raymond Toy at 2025-06-24T06:26:02-07:00 Fix a few typos in comments and strings. - - - - - 2 changed files: - src/code/package.lisp - src/code/print.lisp Changes: ===================================== src/code/package.lisp ===================================== @@ -2019,7 +2019,7 @@ (restart-case (error 'simple-package-error :package pkg - :format-control (intl:gettext "~A as already a local nickname for the package ~A in ~A") + :format-control (intl:gettext "~A is already a local nickname for the package ~A in ~A") :format-arguments (list local-nickname actual-pkg pkg)) (keep-old-nickname () :report (lambda (stream) ===================================== src/code/print.lisp ===================================== @@ -697,7 +697,7 @@ ;; from a package other than its home package. (unless (and accessible (eq symbol object)) ;; If the actual symbol package has a local nickname in - ;; *package*, use that as the symbol name instead of the + ;; *package*, use that as the package name instead of the ;; actual symbol package name. (let ((local-nicks (package-%local-nicknames *package*)) (pkg-name (package-name package))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7494d5bd07c9253c2464aa0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7494d5bd07c9253c2464aa0… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-417-defmethod-check-aux-vars
by Raymond Toy (＠rtoy) 23 Jun '25

23 Jun '25

Raymond Toy pushed new branch issue-417-defmethod-check-aux-vars at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-417-defmethod-check… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-415-add-package-local-nicknames] 7 commits: Remove extra closing parenthesis
by Raymond Toy (＠rtoy) 23 Jun '25

23 Jun '25

Raymond Toy pushed to branch issue-415-add-package-local-nicknames at cmucl / cmucl Commits: d6faeaef by Raymond Toy at 2025-06-09T08:51:48-07:00 Remove extra closing parenthesis There was an extra closing parenthesis at the end of `precompile-ef-slot`. Remove it. [skip-ci] - - - - - 4e6e1afe by Raymond Toy at 2025-06-09T10:39:52-07:00 Update with new resolved issues Add #404 and #405 to the list of fixed issues. - - - - - 852aaef6 by Raymond Toy at 2025-06-10T08:06:34-07:00 Fix typo in docstring for with-string-{glyph,codepoint}-iterator "prodcucing" -> "producing" Update pot file too of course. - - - - - d6a6c40d by Raymond Toy at 2025-06-10T18:21:12-07:00 Update and correct some comments The paths mentioned in the script are wrong so update them. Some the the examples are out-of-date so correct those too. Finally, mention that "bin/build.sh -?" gives help. - - - - - 46bd7cff by Raymond Toy at 2025-06-23T08:45:54-07:00 Fix 418: Update asdf to 3.3.7.4 - - - - - 9e6d1350 by Raymond Toy at 2025-06-23T08:45:54-07:00 Merge branch 'issue-418-update-asdf-to-3.3.7.4' into 'master' Fix 418: Update asdf to 3.3.7.4 See merge request cmucl/cmucl!307 - - - - - c1e52c69 by Raymond Toy at 2025-06-23T10:16:33-07:00 Merge branch 'master' into issue-415-add-package-local-nicknames - - - - - 9 changed files: - bin/build.sh - src/code/extfmts.lisp - src/code/string.lisp - src/contrib/asdf/asdf.lisp - src/contrib/asdf/doc/asdf.html - src/contrib/asdf/doc/asdf.info - src/contrib/asdf/doc/asdf.pdf - src/general-info/release-21f.md - src/i18n/locale/cmucl.pot Changes: ===================================== bin/build.sh ===================================== @@ -1,26 +1,25 @@ #!/bin/sh # Build CMUCL from source. The intent of this script is to make it a -# little easier invoke the other scripts and build CMUCL. In the +# little easier to invoke the other scripts and build CMUCL. In the # simplest case where your lisp is named cmulisp and no special # bootfiles are needed, you would build CMUCL using: # -# src/tools/build.sh -C "" +# bin/build.sh -b build -C "" -o cmulisp # # This will create a set of directories named build-2, build-3, and # build-4 and CMUCL will be built 3 consecutive times, using the # version of CMUCL from the previous build. # -# # You can control which of the builds are done by using the -1, -2, -3 # options, but it is up to you to make sure the previous builds exist. # # A more realistic example would be # -# src/tools/build.sh -v "My build" -B boot-19b.lisp -o "my-lisp -noinit" +# bin/build.sh -C "linux" -B boot-19b.lisp -o "my-lisp" # # where you need to load the bootfile boot-19b.lisp and your lisp is -# not named cmulisp, but my-lisp. +# not named lisp, but my-lisp. # # For more complicated builds, you will need to run create-target.sh # manually, and adjust the bootstrap or setenv files by hand. Once @@ -30,7 +29,7 @@ # Cross compiling is not supported with this script. You will have to # do that by hand. # -# For more information see src/BUILDING. +# For more information run "bin/build.sh -?". Also see BUILDING.md. # # $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/build.sh,v 1.38 2010/11/10 19:17:55 rtoy Exp $ # ===================================== src/code/extfmts.lisp ===================================== @@ -1299,7 +1299,7 @@ character and illegal outputs are replaced by a question mark.") (#.+ef-oc+ (%ef-octet-count ef)))) `(setf (aref (ef-cache (find-external-format ,(ef-name ef))) ,slot) ,(subst (ef-name ef) ef - (function-lambda-expression (aref (ef-cache ef) slot))))))) + (function-lambda-expression (aref (ef-cache ef) slot)))))) ;;; Builtin external formats. ===================================== src/code/string.lisp ===================================== @@ -90,7 +90,7 @@ (defmacro with-string-codepoint-iterator ((next string) &body body) _N"WITH-STRING-CODEPOINT-ITERATOR ((next string) &body body) provides a method of looping through a string from the beginning to - the end of the string prodcucing successive codepoints from the + the end of the string producing successive codepoints from the string. NEXT is bound to a generator macro that, within the scope of the invocation, returns one or two values. The first value tells whether any objects remain in the string. When the first value is @@ -989,7 +989,7 @@ (defmacro with-string-glyph-iterator ((next string) &body body) _N"WITH-STRING-GLYPH-ITERATOR ((next string) &body body) provides a method of looping through a string from the beginning to - the end of the string prodcucing successive glyphs from the string. + the end of the string producing successive glyphs from the string. NEXT is bound to a generator macro that, within the scope of the invocation, returns one or three values. The first value tells whether any objects remain in the string. When the first value is ===================================== src/contrib/asdf/asdf.lisp ===================================== @@ -1,5 +1,5 @@ ;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*- -;;; This is ASDF 3.3.7: Another System Definition Facility. +;;; This is ASDF 3.3.7.4: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -1165,7 +1165,7 @@ Return a string made of the parts not omitted or emitted by FROB." (defmacro compatfmt (format) #+(or gcl genera) - (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>"))) + (frob-substrings format `("~3i~_" "~@<" "~@;" "~@:>" "~:>")) #-(or gcl genera) format)) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF @@ -1848,7 +1848,7 @@ form suitable for testing with #+." (in-package :uiop/version) (with-upgradability () - (defparameter *uiop-version* "3.3.7") + (defparameter *uiop-version* "3.3.7.4") (defun unparse-version (version-list) "From a parsed version (a list of natural numbers), compute the version string" @@ -2064,7 +2064,7 @@ keywords explicitly." (defun os-unix-p () "Is the underlying operating system some Unix variant?" - (or (featurep '(:or :unix :cygwin :haiku)) (os-macosx-p))) + (or (featurep '(:or :unix :cygwin :haiku :linux)) (os-macosx-p))) (defun os-windows-p () "Is the underlying operating system Microsoft Windows?" @@ -2376,7 +2376,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (error "Could not set current directory to ~A" x)) #+ecl (ext:chdir x) #+clasp (ext:chdir x t) - #+gcl (system:chdir x) + #+gcl (system::chdir x) #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) @@ -2811,6 +2811,7 @@ actually-existing directory." ;;; Parsing filenames (with-upgradability () + #-gcl (declaim (ftype function ensure-pathname)) ; forward reference (defun split-unix-namestring-directory-components @@ -3339,20 +3340,6 @@ or the original (parsed) pathname if it is false (the default)." (when p #+allegro (probe-file p :follow-symlinks truename) - #+gcl - (if truename - (truename* p) - (let ((kind (car (si::stat p)))) - (when (eq kind :link) - (setf kind (ignore-errors (car (si::stat (truename* p)))))) - (ecase kind - ((nil) nil) - ((:file :link) - (cond - ((file-pathname-p p) p) - ((directory-pathname-p p) - (subpathname p (car (last (pathname-directory p))))))) - (:directory (ensure-directory-pathname p))))) #+clisp #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) (pp (find-symbol* '#:probe-pathname :ext nil))) @@ -3367,7 +3354,7 @@ or the original (parsed) pathname if it is false (the default)." (t '(or (and (truename* p) p) (if-let (d (ensure-directory-pathname p)) (and (truename* d) d))))))) - #-(or allegro clisp gcl) + #-(or allegro clisp) (if truename (probe-file p) (and @@ -6304,13 +6291,13 @@ MAKE-INSTANCE. Primarily, it is being made available to enable type-checking.")) (not-implemented-error 'process-info-pid))) (defun %process-status (process-info) + #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl) + (not-implemented-error '%process-status) (if-let (exit-code (slot-value process-info 'exit-code)) (return-from %process-status (if-let (signal-code (slot-value process-info 'signal-code)) (values :signaled signal-code) (values :exited exit-code)))) - #-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl) - (not-implemented-error '%process-status) (if-let (process (slot-value process-info 'process)) (multiple-value-bind (status code) (progn @@ -6322,13 +6309,13 @@ MAKE-INSTANCE. Primarily, it is being made available to enable type-checking.")) (symbol-call :ext '#:external-process-status process) (not-implemented-error '%process-status)) #+clozure (ccl:external-process-status process) - #+(or cmucl scl) (let ((status (ext:process-status process))) - (if (member status '(:exited :signaled)) - ;; Calling ext:process-exit-code on - ;; processes that are still alive - ;; yields an undefined result - (values status (ext:process-exit-code process)) - status)) + #+cmucl (let ((status (ext:process-status process))) + (if (member status '(:exited :signaled :stopped)) + ;; ext:process-exit-code can also be called + ;; for stopped processes to determine the + ;; signal that stopped them + (values status (ext:process-exit-code process)) + status)) #+ecl (ext:external-process-status process) #+lispworks ;; a signal is only returned on LispWorks 7+ @@ -6353,7 +6340,14 @@ MAKE-INSTANCE. Primarily, it is being made available to enable type-checking.")) ;; sb-ext:process-exit-code can also be ;; called for stopped processes to determine ;; the signal that stopped them - (values status (sb-ext:process-exit-code process))))) + (values status (sb-ext:process-exit-code process)))) + #+scl (let ((status (ext:process-status process))) + (if (member status '(:exited :signaled)) + ;; Calling ext:process-exit-code on + ;; processes that are still alive + ;; yields an undefined result + (values status (ext:process-exit-code process)) + status))) (case status (:exited (setf (slot-value process-info 'exit-code) code)) (:signaled (let ((%code (%signal-to-exit-code code))) @@ -6663,7 +6657,7 @@ could block because its output buffers are full." (not-implemented-error 'launch-program)) #+clozure 'ccl:run-program #+(or cmucl ecl scl) 'ext:run-program - + #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed #+mkcl 'mk-ext:run-program #+sbcl 'sb-ext:run-program @@ -6751,7 +6745,6 @@ could block because its output buffers are full." ;; returns (io err pid) of which we keep io. (t (prop 'process io-or-pid))))) process-info))) - ;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. @@ -7966,7 +7959,7 @@ previously-loaded version of ASDF." ;; "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.3.7") + (asdf-version "3.3.7.4") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -14111,7 +14104,8 @@ system or its dependencies if it has already been loaded." (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) #+(and allegro allegro-v10.1) ;; check for patch needed for upgradeability - (unless (assoc "ma040" (cdr (assoc :lisp sys:*patches*)) :test 'equal) + (when (and (not (member :developer excl::.build-mode. :test #'eq)) + (not (assoc "ma040" (cdr (assoc :lisp sys:*patches*)) :test 'equal))) (warn 'asdf-install-warning :format-control "On Allegro Common Lisp 10.1, patch pma040 is ~ needed for correct ASDF upgrading. Please update your Allegro image ~ ===================================== src/contrib/asdf/doc/asdf.html ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.info ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.pdf ===================================== Binary files a/src/contrib/asdf/doc/asdf.pdf and b/src/contrib/asdf/doc/asdf.pdf differ ===================================== src/general-info/release-21f.md ===================================== @@ -23,7 +23,7 @@ public domain. * Add support for Gray streams implementation of file-length via `ext:stream-file-length` generic function. * Changes: - * Update to ASDF 3.3.7 + * Update to ASDF 3.3.7.4 * The RNG has changed from an old version of xoroshiro128+ to xoroshiro128**. This means sequences of random numbers will be different from before. See ~~#276~~. @@ -131,6 +131,8 @@ public domain. * #398 Update mk:defsystem to v3.9.2 * #400 `unix-resolve-links` no longer breaks on some lengths * #401 `file-position` now returns the correct value + * #404 Use `realpath(3)` to implement `unix::unix-resolve-links` + * #405 `unix::unix-resolve-links` has been removed. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3716,7 +3716,7 @@ msgstr "" msgid "" "WITH-STRING-CODEPOINT-ITERATOR ((next string) &body body)\n" " provides a method of looping through a string from the beginning to\n" -" the end of the string prodcucing successive codepoints from the\n" +" the end of the string producing successive codepoints from the\n" " string. NEXT is bound to a generator macro that, within the scope\n" " of the invocation, returns one or two values. The first value tells\n" " whether any objects remain in the string. When the first value is\n" @@ -3985,7 +3985,7 @@ msgstr "" msgid "" "WITH-STRING-GLYPH-ITERATOR ((next string) &body body)\n" " provides a method of looping through a string from the beginning to\n" -" the end of the string prodcucing successive glyphs from the string.\n" +" the end of the string producing successive glyphs from the string.\n" " NEXT is bound to a generator macro that, within the scope of the\n" " invocation, returns one or three values. The first value tells\n" " whether any objects remain in the string. When the first value is\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/66c4a529989259ef3596a9… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/66c4a529989259ef3596a9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix 418: Update asdf to 3.3.7.4
by Raymond Toy (＠rtoy) 23 Jun '25

23 Jun '25

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 46bd7cff by Raymond Toy at 2025-06-23T08:45:54-07:00 Fix 418: Update asdf to 3.3.7.4 - - - - - 9e6d1350 by Raymond Toy at 2025-06-23T08:45:54-07:00 Merge branch 'issue-418-update-asdf-to-3.3.7.4' into 'master' Fix 418: Update asdf to 3.3.7.4 See merge request cmucl/cmucl!307 - - - - - 5 changed files: - src/contrib/asdf/asdf.lisp - src/contrib/asdf/doc/asdf.html - src/contrib/asdf/doc/asdf.info - src/contrib/asdf/doc/asdf.pdf - src/general-info/release-21f.md Changes: ===================================== src/contrib/asdf/asdf.lisp ===================================== @@ -1,5 +1,5 @@ ;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*- -;;; This is ASDF 3.3.7: Another System Definition Facility. +;;; This is ASDF 3.3.7.4: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -135,7 +135,7 @@ (:import-from #+allegro #:excl #+sbcl #:sb-ext - #+(or clasp abcl ecl) #:ext + #+(or clasp abcl ecl cmu) #:ext #+ccl #:ccl #+lispworks #:hcl #-(or allegro sbcl clasp abcl ccl lispworks ecl) @@ -1165,7 +1165,7 @@ Return a string made of the parts not omitted or emitted by FROB." (defmacro compatfmt (format) #+(or gcl genera) - (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>"))) + (frob-substrings format `("~3i~_" "~@<" "~@;" "~@:>" "~:>")) #-(or gcl genera) format)) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF @@ -1848,7 +1848,7 @@ form suitable for testing with #+." (in-package :uiop/version) (with-upgradability () - (defparameter *uiop-version* "3.3.7") + (defparameter *uiop-version* "3.3.7.4") (defun unparse-version (version-list) "From a parsed version (a list of natural numbers), compute the version string" @@ -2064,7 +2064,7 @@ keywords explicitly." (defun os-unix-p () "Is the underlying operating system some Unix variant?" - (or (featurep '(:or :unix :cygwin :haiku)) (os-macosx-p))) + (or (featurep '(:or :unix :cygwin :haiku :linux)) (os-macosx-p))) (defun os-windows-p () "Is the underlying operating system Microsoft Windows?" @@ -2376,7 +2376,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (error "Could not set current directory to ~A" x)) #+ecl (ext:chdir x) #+clasp (ext:chdir x t) - #+gcl (system:chdir x) + #+gcl (system::chdir x) #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) @@ -2811,6 +2811,7 @@ actually-existing directory." ;;; Parsing filenames (with-upgradability () + #-gcl (declaim (ftype function ensure-pathname)) ; forward reference (defun split-unix-namestring-directory-components @@ -3339,20 +3340,6 @@ or the original (parsed) pathname if it is false (the default)." (when p #+allegro (probe-file p :follow-symlinks truename) - #+gcl - (if truename - (truename* p) - (let ((kind (car (si::stat p)))) - (when (eq kind :link) - (setf kind (ignore-errors (car (si::stat (truename* p)))))) - (ecase kind - ((nil) nil) - ((:file :link) - (cond - ((file-pathname-p p) p) - ((directory-pathname-p p) - (subpathname p (car (last (pathname-directory p))))))) - (:directory (ensure-directory-pathname p))))) #+clisp #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) (pp (find-symbol* '#:probe-pathname :ext nil))) @@ -3367,7 +3354,7 @@ or the original (parsed) pathname if it is false (the default)." (t '(or (and (truename* p) p) (if-let (d (ensure-directory-pathname p)) (and (truename* d) d))))))) - #-(or allegro clisp gcl) + #-(or allegro clisp) (if truename (probe-file p) (and @@ -6304,13 +6291,13 @@ MAKE-INSTANCE. Primarily, it is being made available to enable type-checking.")) (not-implemented-error 'process-info-pid))) (defun %process-status (process-info) + #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl) + (not-implemented-error '%process-status) (if-let (exit-code (slot-value process-info 'exit-code)) (return-from %process-status (if-let (signal-code (slot-value process-info 'signal-code)) (values :signaled signal-code) (values :exited exit-code)))) - #-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl) - (not-implemented-error '%process-status) (if-let (process (slot-value process-info 'process)) (multiple-value-bind (status code) (progn @@ -6322,13 +6309,13 @@ MAKE-INSTANCE. Primarily, it is being made available to enable type-checking.")) (symbol-call :ext '#:external-process-status process) (not-implemented-error '%process-status)) #+clozure (ccl:external-process-status process) - #+(or cmucl scl) (let ((status (ext:process-status process))) - (if (member status '(:exited :signaled)) - ;; Calling ext:process-exit-code on - ;; processes that are still alive - ;; yields an undefined result - (values status (ext:process-exit-code process)) - status)) + #+cmucl (let ((status (ext:process-status process))) + (if (member status '(:exited :signaled :stopped)) + ;; ext:process-exit-code can also be called + ;; for stopped processes to determine the + ;; signal that stopped them + (values status (ext:process-exit-code process)) + status)) #+ecl (ext:external-process-status process) #+lispworks ;; a signal is only returned on LispWorks 7+ @@ -6353,7 +6340,14 @@ MAKE-INSTANCE. Primarily, it is being made available to enable type-checking.")) ;; sb-ext:process-exit-code can also be ;; called for stopped processes to determine ;; the signal that stopped them - (values status (sb-ext:process-exit-code process))))) + (values status (sb-ext:process-exit-code process)))) + #+scl (let ((status (ext:process-status process))) + (if (member status '(:exited :signaled)) + ;; Calling ext:process-exit-code on + ;; processes that are still alive + ;; yields an undefined result + (values status (ext:process-exit-code process)) + status))) (case status (:exited (setf (slot-value process-info 'exit-code) code)) (:signaled (let ((%code (%signal-to-exit-code code))) @@ -6663,7 +6657,7 @@ could block because its output buffers are full." (not-implemented-error 'launch-program)) #+clozure 'ccl:run-program #+(or cmucl ecl scl) 'ext:run-program - + #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed #+mkcl 'mk-ext:run-program #+sbcl 'sb-ext:run-program @@ -6751,7 +6745,6 @@ could block because its output buffers are full." ;; returns (io err pid) of which we keep io. (t (prop 'process io-or-pid))))) process-info))) - ;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. @@ -7966,7 +7959,7 @@ previously-loaded version of ASDF." ;; "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.3.7") + (asdf-version "3.3.7.4") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -14111,7 +14104,8 @@ system or its dependencies if it has already been loaded." (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) #+(and allegro allegro-v10.1) ;; check for patch needed for upgradeability - (unless (assoc "ma040" (cdr (assoc :lisp sys:*patches*)) :test 'equal) + (when (and (not (member :developer excl::.build-mode. :test #'eq)) + (not (assoc "ma040" (cdr (assoc :lisp sys:*patches*)) :test 'equal))) (warn 'asdf-install-warning :format-control "On Allegro Common Lisp 10.1, patch pma040 is ~ needed for correct ASDF upgrading. Please update your Allegro image ~ ===================================== src/contrib/asdf/doc/asdf.html ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.info ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.pdf ===================================== Binary files a/src/contrib/asdf/doc/asdf.pdf and b/src/contrib/asdf/doc/asdf.pdf differ ===================================== src/general-info/release-21f.md ===================================== @@ -23,7 +23,7 @@ public domain. * Add support for Gray streams implementation of file-length via `ext:stream-file-length` generic function. * Changes: - * Update to ASDF 3.3.7 + * Update to ASDF 3.3.7.4 * The RNG has changed from an old version of xoroshiro128+ to xoroshiro128**. This means sequences of random numbers will be different from before. See ~~#276~~. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d6a6c40dca0e3e42d82ffa… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d6a6c40dca0e3e42d82ffa… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0