procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

cl-defstruct: Fix debug spec and check of slot options

Browse source 
* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Improve checking of slot
option syntax.  Fix debug spec.  (Bug#24700)
This commit is contained in:
Johan Bockgård 2016-10-18 22:28:17 +02:00
parent f52892fe01
commit eb610f270e
1 changed files with 7 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

13
lisp/emacs-lisp/cl-macs.el
View file

@ -2590,8 +2590,7 @@ non-nil value, that slot cannot be set via `setf'.
[":initial-offset" natnump])])]
[&optional stringp]
;; All the above is for the following def-form.
&rest &or symbolp (symbolp def-form
&optional ":read-only" sexp))))
&rest &or symbolp (symbolp &optional def-form &rest sexp))))
(let* ((name (if (consp struct) (car struct) struct))
(opts (cdr-safe struct))
(slots nil)
@ -2655,7 +2654,7 @@ non-nil value, that slot cannot be set via `setf'.
(setq descs (nconc (make-list (car args) '(cl-skip-slot))
descs)))
(t
(error "Slot option %s unrecognized" opt)))))
(error "Structure option %s unrecognized" opt)))))
(unless (or include-name type)
(setq include-name cl--struct-default-parent))
(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'.
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
(slot (car desc)))
(slot (pop desc)))
(if (memq slot '(cl-tag-slot cl-skip-slot))
(progn
(push nil slots)
@ -2721,7 +2720,7 @@ non-nil value, that slot cannot be set via `setf'.
(error "Duplicate slots named %s in %s" slot name))
(let ((accessor (intern (format "%s%s" conc-name slot))))
(push slot slots)
(push (nth 1 desc) defaults)
(push (pop desc) defaults)
;; The arg "cl-x" is referenced by name in eg pred-form
;; and pred-check, so changing it is not straightforward.
(push `(cl-defsubst ,accessor (cl-x)
@ -2736,7 +2735,9 @@ non-nil value, that slot cannot be set via `setf'.
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x))))
forms)
(if (cadr (memq :read-only (cddr desc)))
(when (cl-oddp (length desc))
(error "Invalid options for slot %s in %s" slot name))
(if (plist-get desc ':read-only)
(push `(gv-define-expander ,accessor
(lambda (_cl-do _cl-x)
(error "%s is a read-only slot" ',accessor)))