Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

5 changed files:

Changes:

  • src/code/defstruct.lisp
    ... ... @@ -452,25 +452,11 @@
    452 452 
     			 name-and-options)))
    453 453 
     	 (name (dd-name defstruct))
    454 454 
     	 (pkg (symbol-package name)))
    455 
    -    (when (and lisp::*enable-package-locked-errors*
    456 
    -	       pkg
    455 
    +    (when (and pkg
    457 456 
     	       (ext:package-definition-lock pkg))
    458 
    -      (restart-case
    459 
    -	  (error 'lisp::package-locked-error
    460 
    -		 :package pkg
    461 
    -		 :format-control (intl:gettext "defining structure ~A")
    462 
    -		 :format-arguments (list name))
    463 
    -	(continue ()
    464 
    -	  :report (lambda (stream)
    465 
    -		    (write-string (intl:gettext "Ignore the lock and continue") stream)))
    466 
    -	(unlock-package ()
    467 
    -	  :report (lambda (stream)
    468 
    -		    (write-string (intl:gettext "Disable package's definition lock then continue") stream))
    469 
    -	  (setf (ext:package-definition-lock pkg) nil))
    470 
    -        (unlock-all ()
    471 
    -          :report (lambda (stream)
    472 
    -		    (write-string (intl:gettext "Unlock all packages, then continue") stream))
    473 
    -          (lisp::unlock-all-packages))))
    457 
    +      (lisp::signal-package-locked-error pkg :definition
    458 
    +					 (intl:gettext "defining structure ~A")
    459 
    +					 name))
    474 460 
         (when (info declaration recognized name)
    475 461 
           (error (intl:gettext "Defstruct already names a declaration: ~S.") name))
    476 462 
         (when (stringp (car slot-descriptions))

  • src/code/macros.lisp
    ... ... @@ -221,6 +221,13 @@
    221 221 
       "Syntax like DEFMACRO, but defines a new type."
    222 222 
       (unless (symbolp name)
    223 223 
         (simple-program-error (intl:gettext "~S -- Type name not a symbol.") name))
    224 
    +  (let ((pkg (symbol-package name)))
    225 
    +    (when (and pkg (ext:package-definition-lock pkg))
    226 
    +      (signal-package-locked-error pkg :definition
    227 
    +				   (intl:gettext "defining type ~A")
    228 
    +				   name)))
    229 
    +
    230 
    +  #+nil
    224 231 
       (and lisp::*enable-package-locked-errors*
    225 232 
            (symbol-package name)
    226 233 
            (ext:package-definition-lock (symbol-package name))

  • src/code/package.lisp
    ... ... @@ -189,8 +189,46 @@
    189 189 
            (ext:compiler-let ((*enable-package-locked-errors* nil))
    190 190 
     	 ,@body))))
    191 191
    192 
    -
    193 
    -;; trap attempts to redefine a function in a locked package, and
    192 
    +;;; SIGNAL-PACKAGE-LOCKED-ERROR -- Internal
    193 
    +;;;
    194 
    +;;;   This encapsulates signaling of package locked errors.  LOCK-KIND
    195 
    +;;; should be one of the following which will clear the corresponding
    196 
    +;;; lock when the UNLOCK-PACKAGE restart is selected.
    197 
    +;;;
    198 
    +;;;   :definition - resets package-definition-lock
    199 
    +;;;   :namespace  - resets package-lock
    200 
    +;;;
    201 
    +;;; Error is signaled only if *ENABLE-PACKAGE-LOCKED-ERRORS* is non-NIL.
    202 
    +(defun signal-package-locked-error (package lock-kind message-control &rest message-args)
    203 
    +  (declare (type (member :definition :namespace) lock-kind))
    204 
    +  ;; During bootstrap, *ENABLE-PACKAGE-LOCKED-ERRORS* may not be
    205 
    +  ;; bound.  Treat that is if it were NIL, so nothing is signaled.
    206 
    +  (when (and (boundp '*enable-package-locked-errors*)
    207 
    +	     *enable-package-locked-errors*)
    208 
    +    (restart-case
    209 
    +          (error 'lisp::package-locked-error
    210 
    +                 :package package
    211 
    +                 :format-control message-control
    212 
    +                 :format-arguments message-args)
    213 
    +        (continue ()
    214 
    +          :report (lambda (stream)
    215 
    +		    (write-string (intl:gettext "Ignore the lock and continue")
    216 
    +				  stream)))
    217 
    +        (unlock-package ()
    218 
    +          :report (lambda (stream)
    219 
    +		    (write-string (intl:gettext "Disable the package's definition-lock then continue")
    220 
    +				  stream))
    221 
    +	  (ecase lock-kind
    222 
    +	    (:definition
    223 
    +             (setf (ext:package-definition-lock package) nil))
    224 
    +	    (:namespace
    225 
    +	     (setf (ext:package-lock package) nil))))
    226 
    +        (unlock-all ()
    227 
    +          :report (lambda (stream)
    228 
    +		    (write-string (intl:gettext "Unlock all packages, then continue") stream))
    229 
    +          (unlock-all-packages)))))
    230 
    +
    231 
    +;; Trap attempts to redefine a function in a locked package, and
    194 232 
     ;; signal a continuable error.
    195 233 
     (defun redefining-function (function replacement)
    196 234 
       (declare (ignore replacement))
    ... ... @@ -201,30 +239,16 @@
    201 239 
           (let ((package (symbol-package block-name)))
    202 240 
             (when package
    203 241 
               (when (package-definition-lock package)
    204 
    -            (when (and (consp function)
    205 
    -                       (member (first function)
    206 
    -                               '(pcl::slot-accessor
    207 
    -                                 pcl::method
    208 
    -                                 pcl::fast-method
    209 
    -                                 pcl::effective-method
    210 
    -                                 pcl::ctor)))
    211 
    -              (return-from redefining-function nil))
    212 
    -            (restart-case
    213 
    -                (error 'package-locked-error
    214 
    -                       :package package
    215 
    -                       :format-control (intl:gettext "redefining function ~A")
    216 
    -                       :format-arguments (list function))
    217 
    -              (continue ()
    218 
    -                :report (lambda (stream)
    219 
    -			  (write-string (intl:gettext "Ignore the lock and continue") stream)))
    220 
    -              (unlock-package ()
    221 
    -                :report (lambda (stream)
    222 
    -			  (write-string (intl:gettext "Disable package's definition-lock, then continue") stream))
    223 
    -                (setf (ext:package-definition-lock package) nil))
    224 
    -              (unlock-all ()
    225 
    -                :report (lambda (stream)
    226 
    -			  (write-string (intl:gettext "Disable all package locks, then continue") stream))
    227 
    -                (unlock-all-packages)))))))))
    242 
    +            (unless (and (consp function)
    243 
    +			 (member (first function)
    244 
    +				 '(pcl::slot-accessor
    245 
    +                                   pcl::method
    246 
    +                                   pcl::fast-method
    247 
    +                                   pcl::effective-method
    248 
    +                                   pcl::ctor)))
    249 
    +	      (signal-package-locked-error package :definition
    250 
    +					   (intl:gettext "redefining function ~A")
    251 
    +					   function))))))))
    228 252
    229 253
    230 254 
     ;;; This magical variable is T during initialization so Use-Package's of packages
    ... ... @@ -1438,24 +1462,10 @@
    1438 1462 
     	 (name (symbol-name symbol))
    1439 1463 
     	 (shadowing-symbols (package-%shadowing-symbols package)))
    1440 1464 
         (declare (list shadowing-symbols) (simple-string name))
    1441 
    -    (when *enable-package-locked-errors*
    1442 
    -      (when (ext:package-lock package)
    1443 
    -        (restart-case
    1444 
    -            (error 'package-locked-error
    1445 
    -                   :package package
    1446 
    -                   :format-control (intl:gettext "uninterning symbol ~A")
    1447 
    -                   :format-arguments (list name))
    1448 
    -          (continue ()
    1449 
    -            :report (lambda (stream)
    1450 
    -		      (write-string (intl:gettext "Ignore the lock and continue") stream)))
    1451 
    -          (unlock-package ()
    1452 
    -            :report (lambda (stream)
    1453 
    -		      (write-string (intl:gettext "Disable package's lock then continue") stream))
    1454 
    -            (setf (ext:package-lock package) nil))
    1455 
    -          (unlock-all ()
    1456 
    -            :report (lambda (stream)
    1457 
    -		      (write-string (intl:gettext "Unlock all packages, then continue") stream))
    1458 
    -            (unlock-all-packages)))))
    1465 
    +    (when (ext:package-lock package)
    1466 
    +      (signal-package-locked-error package :namespace
    1467 
    +				 (intl:gettext "uninterning symbol ~A")
    1468 
    +				 name))
    1459 1469 
         ;;
    1460 1470 
         ;; If a name conflict is revealed, give use a chance to shadowing-import
    1461 1471 
         ;; one of the accessible symbols.
    ... ... @@ -1620,24 +1630,11 @@
    1620 1630 
       "Makes SYMBOLS no longer exported from PACKAGE."
    1621 1631 
       (let ((package (package-or-lose package))
    1622 1632 
     	(syms ()))
    1623 
    -    (when *enable-package-locked-errors*
    1624 
    -      (when (ext:package-lock package)
    1625 
    -        (restart-case
    1626 
    -            (error 'package-locked-error
    1627 
    -                   :package package
    1628 
    -                   :format-control (intl:gettext "unexporting symbols ~A")
    1629 
    -                   :format-arguments (list symbols))
    1630 
    -          (continue ()
    1631 
    -            :report (lambda (stream)
    1632 
    -		      (write-string (intl:gettext "Ignore the lock and continue") stream)))
    1633 
    -          (unlock-package ()
    1634 
    -            :report (lambda (stream)
    1635 
    -		      (write-string (intl:gettext "Disable package's lock then continue") stream))
    1636 
    -            (setf (ext:package-lock package) nil))
    1637 
    -          (unlock-all ()
    1638 
    -            :report (lambda (stream)
    1639 
    -		      (write-string (intl:gettext "Unlock all packages, then continue") stream))
    1640 
    -            (unlock-all-packages)))))
    1633 
    +    (when (ext:package-lock package)
    1634 
    +      (signal-package-locked-error package :namespace
    1635 
    +				   (intl:gettext "unexporting symbols ~A")
    1636 
    +				   symbols))
    1637 
    +
    1641 1638 
         (dolist (sym (symbol-listify symbols))
    1642 1639 
           (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
    1643 1640 
     	(cond ((or (not w) (not (eq s sym)))

  • src/i18n/locale/cmucl.pot
    No preview for this file type
  • tests/package-lock.lisp
    1 
    +;;; Regression tests for package-locked-error signaling.
    2 
    +;;;
    3 
    +;;; These tests exist as a baseline before refactoring the
    4 
    +;;; package-lock checks into a shared helper.  They verify that
    5 
    +;;; package-locked-error is signaled at each call site we expect to
    6 
    +;;; check the lock; restart behavior is tested separately.
    7 
    +
    8 
    +(defpackage :package-lock-tests
    9 
    +  (:use :cl :lisp-unit))
    10 
    +
    11 
    +(in-package "PACKAGE-LOCK-TESTS")
    12 
    +
    13 
    +(defpackage :test-locked-package
    14 
    +  (:use :cl))
    15 
    +
    16 
    +(defmacro with-definition-locked ((package) &body body)
    17 
    +  "Run BODY with PACKAGE's definition-lock enabled and namespace-lock
    18 
    +   disabled, so failures from BODY can be attributed unambiguously to
    19 
    +   the definition lock."
    20 
    +  `(let ((p ,package))
    21 
    +     (setf (ext:package-definition-lock p) t
    22 
    +           (ext:package-lock p) nil)
    23 
    +     (assert-true (ext:package-definition-lock p))
    24 
    +     (assert-false (ext:package-lock p))
    25 
    +     (unwind-protect (progn ,@body)
    26 
    +       (setf (ext:package-definition-lock p) nil
    27 
    +             (ext:package-lock p) nil))))
    28 
    +
    29 
    +(defmacro with-namespace-locked ((package) &body body)
    30 
    +  "Run BODY with PACKAGE's namespace-lock enabled and definition-lock
    31 
    +   disabled, so failures from BODY can be attributed unambiguously to
    32 
    +   the namespace lock."
    33 
    +  `(let ((p ,package))
    34 
    +     (setf (ext:package-definition-lock p) nil
    35 
    +           (ext:package-lock p) t)
    36 
    +     (assert-false (ext:package-definition-lock p))
    37 
    +     (assert-true (ext:package-lock p))
    38 
    +     (unwind-protect (progn ,@body)
    39 
    +       (setf (ext:package-definition-lock p) nil
    40 
    +             (ext:package-lock p) nil))))
    41 
    +
    42 
    +
    43 
    +;;; ---- Definition-lock tests ----
    44 
    +
    45 
    +(define-test package-locked.defmacro
    46 
    +  (:tag :issues)
    47 
    +  (with-definition-locked ((find-package :test-locked-package))
    48 
    +    (assert-error 'lisp::package-locked-error
    49 
    +                  (eval '(defmacro test-locked-package::a-macro (x)
    50 
    +                          `(list ,x))))))
    51 
    +
    52 
    +(define-test package-locked.defun
    53 
    +  (:tag :issues)
    54 
    +  (with-definition-locked ((find-package :test-locked-package))
    55 
    +    (assert-error 'lisp::package-locked-error
    56 
    +                  (eval '(defun test-locked-package::a-fn (x) x)))))
    57 
    +
    58 
    +(define-test package-locked.deftype
    59 
    +  (:tag :issues)
    60 
    +  (with-definition-locked ((find-package :test-locked-package))
    61 
    +    (assert-error 'lisp::package-locked-error
    62 
    +                  (eval '(deftype test-locked-package::a-type ()
    63 
    +                          'integer)))))
    64 
    +
    65 
    +(define-test package-locked.defstruct
    66 
    +  (:tag :issues)
    67 
    +  (with-definition-locked ((find-package :test-locked-package))
    68 
    +    (assert-error 'lisp::package-locked-error
    69 
    +                  (eval '(defstruct test-locked-package::a-struct
    70 
    +                          slot-1 slot-2)))))
    71 
    +
    72 
    +
    73 
    +;;; ---- Namespace-lock tests ----
    74 
    +
    75 
    +(define-test package-locked.unintern
    76 
    +  (:tag :issues)
    77 
    +  (let ((sym (intern "TO-BE-UNINTERNED"
    78 
    +                     (find-package :test-locked-package))))
    79 
    +    (with-namespace-locked ((find-package :test-locked-package))
    80 
    +      (assert-error 'lisp::package-locked-error
    81 
    +                    (unintern sym (find-package :test-locked-package))))))
    82 
    +
    83 
    +(define-test package-locked.unexport
    84 
    +  (:tag :issues)
    85 
    +  (let* ((p (find-package :test-locked-package))
    86 
    +         (sym (intern "TO-BE-UNEXPORTED" p)))
    87 
    +    (export sym p)
    88 
    +    (with-namespace-locked (p)
    89 
    +      (assert-error 'lisp::package-locked-error
    90 
    +                    (unexport sym p)))))
    91 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help Notification message regarding https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5926490b13936966d04811eb304449291873564c...9b6135db7475bbf23557e5bdf63ac57af60d8f8d at 1782514672