aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJohan Bockgård2016-10-18 22:28:17 +0200
committerJohan Bockgård2016-10-19 00:32:12 +0200
commiteb610f270ea919107b10bb8ece200a87abac6e0e (patch)
tree8ff0daf370bb76364e84b049f3b4e12802c40de8
parentf52892fe01fec19860c198036fea1251b05ce18e (diff)
downloademacs-eb610f270ea919107b10bb8ece200a87abac6e0e.tar.gz
emacs-eb610f270ea919107b10bb8ece200a87abac6e0e.zip
cl-defstruct: Fix debug spec and check of slot options
* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Improve checking of slot option syntax. Fix debug spec. (Bug#24700)
-rw-r--r--lisp/emacs-lisp/cl-macs.el13
1 files changed, 7 insertions, 6 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index f5b7b826431..0096e0aab3e 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2590,8 +2590,7 @@ non-nil value, that slot cannot be set via `setf'.
2590 [":initial-offset" natnump])])] 2590 [":initial-offset" natnump])])]
2591 [&optional stringp] 2591 [&optional stringp]
2592 ;; All the above is for the following def-form. 2592 ;; All the above is for the following def-form.
2593 &rest &or symbolp (symbolp def-form 2593 &rest &or symbolp (symbolp &optional def-form &rest sexp))))
2594 &optional ":read-only" sexp))))
2595 (let* ((name (if (consp struct) (car struct) struct)) 2594 (let* ((name (if (consp struct) (car struct) struct))
2596 (opts (cdr-safe struct)) 2595 (opts (cdr-safe struct))
2597 (slots nil) 2596 (slots nil)
@@ -2655,7 +2654,7 @@ non-nil value, that slot cannot be set via `setf'.
2655 (setq descs (nconc (make-list (car args) '(cl-skip-slot)) 2654 (setq descs (nconc (make-list (car args) '(cl-skip-slot))
2656 descs))) 2655 descs)))
2657 (t 2656 (t
2658 (error "Slot option %s unrecognized" opt))))) 2657 (error "Structure option %s unrecognized" opt)))))
2659 (unless (or include-name type) 2658 (unless (or include-name type)
2660 (setq include-name cl--struct-default-parent)) 2659 (setq include-name cl--struct-default-parent))
2661 (when include-name (setq include (cl--struct-get-class include-name))) 2660 (when include-name (setq include (cl--struct-get-class include-name)))
@@ -2711,7 +2710,7 @@ non-nil value, that slot cannot be set via `setf'.
2711 (let ((pos 0) (descp descs)) 2710 (let ((pos 0) (descp descs))
2712 (while descp 2711 (while descp
2713 (let* ((desc (pop descp)) 2712 (let* ((desc (pop descp))
2714 (slot (car desc))) 2713 (slot (pop desc)))
2715 (if (memq slot '(cl-tag-slot cl-skip-slot)) 2714 (if (memq slot '(cl-tag-slot cl-skip-slot))
2716 (progn 2715 (progn
2717 (push nil slots) 2716 (push nil slots)
@@ -2721,7 +2720,7 @@ non-nil value, that slot cannot be set via `setf'.
2721 (error "Duplicate slots named %s in %s" slot name)) 2720 (error "Duplicate slots named %s in %s" slot name))
2722 (let ((accessor (intern (format "%s%s" conc-name slot)))) 2721 (let ((accessor (intern (format "%s%s" conc-name slot))))
2723 (push slot slots) 2722 (push slot slots)
2724 (push (nth 1 desc) defaults) 2723 (push (pop desc) defaults)
2725 ;; The arg "cl-x" is referenced by name in eg pred-form 2724 ;; The arg "cl-x" is referenced by name in eg pred-form
2726 ;; and pred-check, so changing it is not straightforward. 2725 ;; and pred-check, so changing it is not straightforward.
2727 (push `(cl-defsubst ,accessor (cl-x) 2726 (push `(cl-defsubst ,accessor (cl-x)
@@ -2736,7 +2735,9 @@ non-nil value, that slot cannot be set via `setf'.
2736 (if (= pos 0) '(car cl-x) 2735 (if (= pos 0) '(car cl-x)
2737 `(nth ,pos cl-x)))) 2736 `(nth ,pos cl-x))))
2738 forms) 2737 forms)
2739 (if (cadr (memq :read-only (cddr desc))) 2738 (when (cl-oddp (length desc))
2739 (error "Invalid options for slot %s in %s" slot name))
2740 (if (plist-get desc ':read-only)
2740 (push `(gv-define-expander ,accessor 2741 (push `(gv-define-expander ,accessor
2741 (lambda (_cl-do _cl-x) 2742 (lambda (_cl-do _cl-x)
2742 (error "%s is a read-only slot" ',accessor))) 2743 (error "%s is a read-only slot" ',accessor)))