Commit 4902b9de authored by Marius Gerbershagen's avatar Marius Gerbershagen

Merge branch 'defstruct-redefinition' into 'develop'

defstruct redefinition

Closes #457

See merge request !134
parents 21909743 a361055a
Pipeline #46761913 passed with stage
......@@ -26,14 +26,6 @@
:one-liner t)
T)
(defun package-locked-p (package &aux (package (si:coerce-to-package package)))
"Returns T when PACKAGE is locked, NIL otherwise. Signals an error
if PACKAGE doesn't designate a valid package."
(ffi:c-inline (package) (:object) :object
"(#0)->pack.locked ? ECL_T : ECL_NIL"
:side-effects nil
:one-liner t))
(defmacro without-package-locks (&body body)
"Ignores all runtime package lock violations during the execution of
body. Body can begin with declarations."
......
......@@ -563,7 +563,7 @@ void
cl_export2(cl_object s, cl_object p)
{
int intern_flag, error;
cl_object other_p, name = ecl_symbol_name(s);
cl_object other_p = ECL_NIL, name = ecl_symbol_name(s);
p = si_coerce_to_package(p);
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
......@@ -966,6 +966,13 @@ si_package_lock(cl_object p, cl_object t)
@(return (previous? ECL_T : ECL_NIL));
}
cl_object
si_package_locked_p (cl_object p)
{
p = si_coerce_to_package(p);
@return (p->pack.locked ? ECL_T : ECL_NIL);
}
/* --- local nicknames ---------------------------------------------------- */
cl_object
si_package_local_nicknames(cl_object p)
......
......@@ -1207,9 +1207,9 @@ cl_symbols[] = {
/* package extensions */
{SYS_ "*IGNORE-PACKAGE-LOCKS*", SI_SPECIAL, NULL, -1, ECL_NIL},
{EXT_ "PACKAGE-LOCK", EXT_ORDINARY, si_package_lock, 2, OBJNULL},
{EXT_ "PACKAGE-LOCKED-P", EXT_ORDINARY, si_package_locked_p, 1, OBJNULL},
{SYS_ "LOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "UNLOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "PACKAGE-LOCKED-P", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "WITHOUT-PACKAGE-LOCKS", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "WITH-UNLOCKED-PACKAGES", EXT_ORDINARY, NULL, 1, OBJNULL},
{EXT_ "PACKAGE-LOCAL-NICKNAMES", EXT_ORDINARY, si_package_local_nicknames, 1, OBJNULL},
......@@ -1637,6 +1637,7 @@ cl_symbols[] = {
{MP_ "ATOMIC-INCF-INSTANCE", MP_ORDINARY, IF_MP(mp_atomic_incf_instance), 3, OBJNULL},
{MP_ "DEFINE-CAS-EXPANDER", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "DEFCAS", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "REMCAS", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "GET-CAS-EXPANSION", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "COMPARE-AND-SWAP", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "ATOMIC-UPDATE", MP_CONSTANT, NULL, -1, OBJNULL},
......
......@@ -1207,9 +1207,9 @@ cl_symbols[] = {
/* package extensions */
{SYS_ "*IGNORE-PACKAGE-LOCKS*",NULL},
{EXT_ "PACKAGE-LOCK","si_package_lock"},
{EXT_ "PACKAGE-LOCKED-P","si_package_locked_p"},
{SYS_ "LOCK-PACKAGE",NULL},
{SYS_ "UNLOCK-PACKAGE",NULL},
{SYS_ "PACKAGE-LOCKED-P",NULL},
{SYS_ "WITHOUT-PACKAGE-LOCKS",NULL},
{SYS_ "WITH-UNLOCKED-PACKAGES",NULL},
{EXT_ "PACKAGE-LOCAL-NICKNAMES","si_package_local_nicknames"},
......@@ -1637,6 +1637,7 @@ cl_symbols[] = {
{MP_ "ATOMIC-INCF-INSTANCE",IF_MP("mp_atomic_incf_instance")},
{MP_ "DEFINE-CAS-EXPANDER",NULL},
{MP_ "DEFCAS",NULL},
{MP_ "REMCAS",NULL},
{MP_ "GET-CAS-EXPANSION",NULL},
{MP_ "COMPARE-AND-SWAP",NULL},
{MP_ "ATOMIC-UPDATE",NULL},
......
......@@ -453,6 +453,7 @@
(proclamation si:package-hash-tables (package-designator)
(values hash-table hash-table list) :reader)
(proclamation ext:package-lock (package-designator gen-bool) package)
(proclamation ext:package-locked-p (package-designator) boolean :no-side-effects)
(proclamation ext:package-local-nicknames
(package-designator) list :no-side-effects)
(proclamation ext:package-locally-nicknamed-by-list
......@@ -777,6 +778,7 @@
#+threads (proclamation mp:atomic-incf-car (cons fixnum) fixnum)
#+threads (proclamation mp:compare-and-swap-cdr (cons t t) t)
#+threads (proclamation mp:atomic-incf-cdr (cons fixnum) fixnum)
#+threads (proclamation mp:remcas (symbol) boolean)
;;;
;;; 15. ARRAYS
......
......@@ -2295,6 +2295,14 @@ built-in packages:
system system internal symbols. Has nicknames SYS and SI.
compiler system internal symbols for the ECL compiler.")
(docfun ext:package-lock function
(package-designator lock) "
Sets package's lock to LOCK. Returns previous lock value.")
(docfun ext:package-locked-p function
(package-designator) "
Returns T when PACKAGE is locked, NIL otherwise.")
(docfun ext:package-local-nicknames function
(package-designator) "
Returns an alist of (LOCAL-NICKNAME . ACTUAL-PACKAGE)
......
......@@ -227,6 +227,13 @@ Note that it is up to the user of this macro to ensure atomicity for
the resulting compare-and-swap expansions.
@end defmac
@lspindex mp:remcas
@defun mp:remcas symbol
Remove a compare-and-swap expansion. It is an equivalent of
@code{fmakeunbound (setf symbol)} for cas expansions.
@end defun
@lspindex mp:get-cas-expansion
@defun mp:get-cas-expansion place &optional environment
......
@node Structures
@section Structures
@subsection Redefining a defstruct structure
@ansi{} says that consequences of redefining a @code{defstruct} are
undefined. @ecl{} defines this behavior to siganal an error if the new
structure is not compatible. Structures are incompatible when:
@table @asis
@item They have a different number of slots
This is particularily important for other structures which could have
included the current one and for already defined instances.
@item Slot name, type or offset is different
Binary compatibility between old and new instances.
@end table
@subsection C Reference
@subsubsection ANSI Dictionary
......
......@@ -1313,6 +1313,7 @@ extern ECL_API cl_object si_remove_package_local_nickname(cl_object n, cl_object
extern ECL_API cl_object cl_list_all_packages(void);
extern ECL_API cl_object si_package_hash_tables(cl_object p);
extern ECL_API cl_object si_package_lock(cl_object p, cl_object t);
extern ECL_API cl_object si_package_locked_p(cl_object p);
extern ECL_API cl_object cl_delete_package(cl_object p);
extern ECL_API cl_object cl_make_package _ECL_ARGS((cl_narg narg, cl_object pack_name, ...));
extern ECL_API cl_object cl_intern _ECL_ARGS((cl_narg narg, cl_object strng, ...));
......
This diff is collapsed.
......@@ -204,6 +204,15 @@ the resulting COMPARE-AND-SWAP expansions."
(setq lambda-list (cons env lambda-list))
(push `(declare (ignore ,env)) body))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((package (symbol-package ',accessor)))
(when (and package
(ext:package-locked-p package)
(null si:*ignore-package-locks*))
(si:signal-simple-error 'package-error
"Ignore lock and proceed."
"Attempt to define CAS accessor ~S in locked package."
'(,accessor)
:package package)))
(si:put-sysprop ',accessor 'CAS-EXPANDER #'(ext::lambda-block ,accessor ,lambda-list ,@body))
',accessor))
......@@ -223,6 +232,21 @@ the resulting COMPARE-AND-SWAP expansions."
`(,',cas-fun ,@args ,old ,new)
`(,',accessor ,@args)))))
#+threads
(defun remcas (symbol)
"Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of
(FMAKUNBOUND (SETF SYMBOL))"
(let ((package (symbol-package symbol)))
(when (and package
(ext:package-locked-p package)
(null si:*ignore-package-locks*))
(si:signal-simple-error 'package-error
"Ignore lock and proceed."
"Attempt to define CAS accessor ~S in locked package."
(list symbol)
:package package)))
(si:rem-sysprop symbol 'cas-expander))
#+threads
(defun get-cas-expansion (place &optional environment &aux f)
"Returns the COMPARE-AND-SWAP expansion forms and variables as defined
......
......@@ -46,6 +46,57 @@
(is-true (typep 3 '(nest (2) 3)))))
;;; 8. Structures
(ext:with-clean-symbols
(my-struct make-my-struct my-struct-2 make-my-struct-2 my-struct-compatible-type)
(test ansi.8.redefine-compatible
(let (foo-1 foo-2 foo-3 foo-4)
(defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2)
(setq foo-1 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 nil)
(slot-2 t)))
(setq foo-2 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 3)
(slot-2 4)))
(setq foo-3 (make-my-struct))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 8 :type t :read-only nil)
(slot-2 8 :type t :read-only nil)))
(setq foo-4 (make-my-struct :slot-1 3 :slot-2 4))
(is (equalp foo-1 foo-2))
(is (equalp foo-2 foo-3))
(is (equalp foo-3 foo-4)))
(deftype my-struct-compatible-type () `(integer 0 10))
(defstruct (my-struct-2 (:constructor make-my-struct-2))
(slot-1 nil :type my-struct-compatible-type :read-only t))
(finishes
(defstruct my-struct-2
(slot-1 nil :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only nil)))))
(ext:with-clean-symbols (my-struct make-my-struct)
(test ansi.8.redefine-incompatible
(defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2)
;; different slot type
(signals error (defstruct (my-struct (:constructor make-my-struct))
(slot-1 nil :type integer)
(slot-2 t)))
;; too many slots
(signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2 slot-3))
;; too few slots
(signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1))
;; incompatible names
(signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1x slot-2x))
(finishes (make-my-struct))))
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 12.2.* Numbers tests ;;
......
......@@ -704,3 +704,34 @@ creating stray processes."
(is (svref vector 1) 0)
(is *x* 0)
(is (slot-value object 'slot1) 0)))))
;;; Date: 2019-02-05
;;; From: Daniel Kochmański
;;; Description:
;;;
;;; Verifies that CAS expansion may be removed.
;;;
(ext:with-clean-symbols (*obj* foo)
(test defcas/remcas
(mp:defcas foo (lambda (object old new)
(assert (consp object))
(setf (car object) old
(cdr object) new)))
(defparameter *obj* (cons nil nil))
(eval `(mp:compare-and-swap (foo *obj*) :car :cdr))
(is (eql (car *obj*) :car))
(is (eql (cdr *obj*) :cdr))
(mp:remcas 'foo)
(signals error (eval `(mp:compare-and-swap (foo *obj*) :car :cdr)))))
;;; Date: 2019-02-07
;;; From: Daniel Kochmański
;;; Description:
;;;
;;; Verifies that CAS modifications honor the package locks.
;;;
(test cas-locked-package
(signals package-error (mp:defcas cl:car (lambda (obj old new) nil)))
(signals package-error (mp:remcas 'cl:car))
(finishes (mp:defcas cor (lambda (obj old new) nil)))
(finishes (mp:remcas 'cor)))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment