diff options
| author | Johan Bockgård | 2016-10-18 22:28:17 +0200 |
|---|---|---|
| committer | Johan Bockgård | 2016-10-19 00:32:12 +0200 |
| commit | eb610f270ea919107b10bb8ece200a87abac6e0e (patch) | |
| tree | 8ff0daf370bb76364e84b049f3b4e12802c40de8 | |
| parent | f52892fe01fec19860c198036fea1251b05ce18e (diff) | |
| download | emacs-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.el | 13 |
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))) |