Raymond Toy pushed to branch issue-500-common-package-error-restart-function at cmucl / cmucl

Commits:

3 changed files:

Changes:

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

  • src/code/package.lisp
    ... ... @@ -191,10 +191,20 @@
    191 191
    192 192 
     ;;; SIGNAL-PACKAGE-LOCKED-ERROR -- Internal
    193 193 
     ;;;
    194 
    -;;;   This encapsulates signaling of package locked errors.
    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.
    195 202 
     (defun signal-package-locked-error (package lock-kind message-control &rest message-args)
    196 
    -  (when (and (boundp 'lisp::*enable-package-locked-errors*)
    197 
    -	     lisp::*enable-package-locked-errors*)
    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*)
    198 208 
         (restart-case
    199 209 
               (error 'lisp::package-locked-error
    200 210 
                      :package package
    ... ... @@ -218,43 +228,8 @@
    218 228 
     		    (write-string (intl:gettext "Unlock all packages, then continue") stream))
    219 229 
               (unlock-all-packages)))))
    220 230
    221 
    -;; trap attempts to redefine a function in a locked package, and
    231 
    +;; Trap attempts to redefine a function in a locked package, and
    222 232 
     ;; signal a continuable error.
    223 
    -#+nil
    224 
    -(defun redefining-function (function replacement)
    225 
    -  (declare (ignore replacement))
    226 
    -  (when *enable-package-locked-errors*
    227 
    -    (multiple-value-bind (valid block-name)
    228 
    -        (ext:valid-function-name-p function)
    229 
    -      (declare (ignore valid))
    230 
    -      (let ((package (symbol-package block-name)))
    231 
    -        (when package
    232 
    -          (when (package-definition-lock package)
    233 
    -            (when (and (consp function)
    234 
    -                       (member (first function)
    235 
    -                               '(pcl::slot-accessor
    236 
    -                                 pcl::method
    237 
    -                                 pcl::fast-method
    238 
    -                                 pcl::effective-method
    239 
    -                                 pcl::ctor)))
    240 
    -              (return-from redefining-function nil))
    241 
    -            (restart-case
    242 
    -                (error 'package-locked-error
    243 
    -                       :package package
    244 
    -                       :format-control (intl:gettext "redefining function ~A")
    245 
    -                       :format-arguments (list function))
    246 
    -              (continue ()
    247 
    -                :report (lambda (stream)
    248 
    -			  (write-string (intl:gettext "Ignore the lock and continue") stream)))
    249 
    -              (unlock-package ()
    250 
    -                :report (lambda (stream)
    251 
    -			  (write-string (intl:gettext "Disable package's definition-lock, then continue") stream))
    252 
    -                (setf (ext:package-definition-lock package) nil))
    253 
    -              (unlock-all ()
    254 
    -                :report (lambda (stream)
    255 
    -			  (write-string (intl:gettext "Disable all package locks, then continue") stream))
    256 
    -                (unlock-all-packages)))))))))
    257 
    -
    258 233 
     (defun redefining-function (function replacement)
    259 234 
       (declare (ignore replacement))
    260 235 
       (when *enable-package-locked-errors*
    ... ... @@ -1491,25 +1466,6 @@
    1491 1466 
           (signal-package-locked-error package :namespace
    1492 1467 
     				 (intl:gettext "uninterning symbol ~A")
    1493 1468 
     				 name))
    1494 
    -    #+nil
    1495 
    -    (when *enable-package-locked-errors*
    1496 
    -      (when (ext:package-lock package)
    1497 
    -        (restart-case
    1498 
    -            (error 'package-locked-error
    1499 
    -                   :package package
    1500 
    -                   :format-control (intl:gettext "uninterning symbol ~A")
    1501 
    -                   :format-arguments (list name))
    1502 
    -          (continue ()
    1503 
    -            :report (lambda (stream)
    1504 
    -		      (write-string (intl:gettext "Ignore the lock and continue") stream)))
    1505 
    -          (unlock-package ()
    1506 
    -            :report (lambda (stream)
    1507 
    -		      (write-string (intl:gettext "Disable package's lock then continue") stream))
    1508 
    -            (setf (ext:package-lock package) nil))
    1509 
    -          (unlock-all ()
    1510 
    -            :report (lambda (stream)
    1511 
    -		      (write-string (intl:gettext "Unlock all packages, then continue") stream))
    1512 
    -            (unlock-all-packages)))))
    1513 1469 
         ;;
    1514 1470 
         ;; If a name conflict is revealed, give use a chance to shadowing-import
    1515 1471 
         ;; one of the accessible symbols.
    ... ... @@ -1678,25 +1634,7 @@
    1678 1634 
           (signal-package-locked-error package :namespace
    1679 1635 
     				   (intl:gettext "unexporting symbols ~A")
    1680 1636 
     				   symbols))
    1681 
    -    #+nil
    1682 
    -    (when *enable-package-locked-errors*
    1683 
    -      (when (ext:package-lock package)
    1684 
    -        (restart-case
    1685 
    -            (error 'package-locked-error
    1686 
    -                   :package package
    1687 
    -                   :format-control (intl:gettext "unexporting symbols ~A")
    1688 
    -                   :format-arguments (list symbols))
    1689 
    -          (continue ()
    1690 
    -            :report (lambda (stream)
    1691 
    -		      (write-string (intl:gettext "Ignore the lock and continue") stream)))
    1692 
    -          (unlock-package ()
    1693 
    -            :report (lambda (stream)
    1694 
    -		      (write-string (intl:gettext "Disable package's lock then continue") stream))
    1695 
    -            (setf (ext:package-lock package) nil))
    1696 
    -          (unlock-all ()
    1697 
    -            :report (lambda (stream)
    1698 
    -		      (write-string (intl:gettext "Unlock all packages, then continue") stream))
    1699 
    -            (unlock-all-packages)))))
    1637 
    +
    1700 1638 
         (dolist (sym (symbol-listify symbols))
    1701 1639 
           (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
    1702 1640 
     	(cond ((or (not w) (not (eq s sym)))

  • src/code/type.lisp
    ... ... @@ -2950,6 +2950,7 @@
    2950 2950 
     ;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union
    2951 2951 
     ;;; type, and the member/union interaction is handled by the union type
    2952 2952 
     ;;; method.
    2953 
    +#+nil
    2953 2954 
     (define-type-method (member :simple-union) (type1 type2)
    2954 2955 
       (let ((mem1 (member-type-members type1))
    2955 2956 
     	(mem2 (member-type-members type2)))
    ... ... @@ -2958,6 +2959,16 @@
    2958 2959 
     	  (t
    2959 2960 
     	   (make-member-type :members (union mem1 mem2))))))
    2960 2961
    2962 
    +(define-type-method (member :simple-union) (type1 type2)
    2963 
    +  (let ((mem1 (member-type-members type1))
    2964 
    +        (mem2 (member-type-members type2)))
    2965 
    +    (cond ((subsetp mem1 mem2) type2)
    2966 
    +          ((subsetp mem2 mem1) type1)
    2967 
    +          ;; NEW: refuse to merge across character/non-character domains
    2968 
    +          ((and (some #'characterp mem1) (notevery #'characterp mem2)) nil)
    2969 
    +          ((and (some #'characterp mem2) (notevery #'characterp mem1)) nil)
    2970 
    +          (t (make-member-type :members (union mem1 mem2))))))
    2971 
    +
    2961 2972 
     (define-type-method (member :simple-=) (type1 type2)
    2962 2973 
       (let ((mem1 (member-type-members type1))
    2963 2974 
     	(mem2 (member-type-members type2)))

    • —
    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/-/commit/e7c711a7ef9ccad3cfdbf5a3f3d01602f633d7ed at 1777770175