mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-12 17:10:43 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Keep type=nil by default.

Browse source 
* lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Add sanity checks
about relationship between `type', `named', and `slots'.
* lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tagcode): Adjust to new
value of `cl-struct-type' property.
This commit is contained in:
Stefan Monnier 2015-02-16 01:37:57 -05:00
parent e59feb3c15
commit 6bf61df8ab
5 changed files with 27 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

14
lisp/emacs-lisp/bytecomp.el
View file

@ -1353,13 +1353,13 @@ extra args."
(let ((keyword-args (cdr (cdr (cdr (cdr form)))))
(name (cadr form)))
(or (not (eq (car-safe name) 'quote))
(and (eq (car form) 'custom-declare-group)
(equal name ''emacs))
(plist-get keyword-args :group)
(not (and (consp name) (eq (car name) 'quote)))
(byte-compile-warn
"%s for `%s' fails to specify containing group"
(cdr (assq (car form)
(and (eq (car form) 'custom-declare-group)
(equal name ''emacs))
(plist-get keyword-args :group)
(not (and (consp name) (eq (car name) 'quote)))
(byte-compile-warn
"%s for `%s' fails to specify containing group"
(cdr (assq (car form)
'((custom-declare-group . defgroup)
(custom-declare-face . defface)
(custom-declare-variable . defcustom))))

4
lisp/emacs-lisp/cl-generic.el
View file

@ -731,7 +731,7 @@ Can only be used from within the lexical body of a primary or around method."
(defun cl--generic-struct-tagcode (type name)
(and (symbolp type)
(get type 'cl-struct-type)
(or (eq 'vector (car (get type 'cl-struct-type)))
(or (null (car (get type 'cl-struct-type)))
(error "Can't dispatch on cl-struct %S: type is %S"
type (car (get type 'cl-struct-type))))
(or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
@ -761,7 +761,7 @@ Can only be used from within the lexical body of a primary or around method."
(let ((types (list (intern (substring (symbol-name tag) 10)))))
(while (get (car types) 'cl-struct-include)
(push (get (car types) 'cl-struct-include) types))
(push 'cl-struct types) ;The "parent type" of all cl-structs.
(push 'cl-structure-object types) ;The "parent type" of all cl-structs.
(nreverse types))))
;;; Dispatch on "system types".

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

@ -2494,7 +2494,7 @@ non-nil value, that slot cannot be set via `setf'.
(or (memq type '(vector list))
(error "Invalid :type specifier: %s" type))
(if named (setq tag name)))
(setq type 'vector named 'true)))
(setq named 'true)))
(or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
(when (and (null predicate) named)
(setq predicate (intern (format "cl--struct-%s-p" name))))
@ -2503,7 +2503,7 @@ non-nil value, that slot cannot be set via `setf'.
(length (memq (assq 'cl-tag-slot descs)
descs)))))
(cond
((eq type 'vector)
((memq type '(nil vector))
`(and (vectorp cl-x)
(>= (length cl-x) ,(length descs))
(memq (aref cl-x ,pos) ,tag-symbol)))
@ -2535,7 +2535,7 @@ non-nil value, that slot cannot be set via `setf'.
(list `(or ,pred-check
(error "%s accessing a non-%s"
',accessor ',name))))
,(if (eq type 'vector) `(aref cl-x ,pos)
,(if (memq type '(nil vector)) `(aref cl-x ,pos)
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x))))
forms)
@ -2593,7 +2593,7 @@ non-nil value, that slot cannot be set via `setf'.
(&cl-defs '(nil ,@descs) ,@args)
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
(,type ,@make))
(,(or type #'vector) ,@make))
forms)))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
;; Don't bother adding to cl-custom-print-functions since it's not used

4
lisp/emacs-lisp/cl-preloaded.el
View file

@ -28,8 +28,12 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
(defun cl-struct-define (name docstring parent type named slots children-sym
tag print-auto)
(cl-assert (or type (equal '(cl-tag-slot) (car slots))))
(cl-assert (or type (not named)))
(if (boundp children-sym)
(add-to-list children-sym tag)
(set children-sym (list tag)))