Commit 6bf61df8 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

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

* 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.
parent e59feb3c
2015-02-16 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl-macs.el (cl-defstruct): Keep type=nil by default.
* emacs-lisp/cl-preloaded.el (cl-struct-define): Add sanity checks
about relationship between `type', `named', and `slots'.
* emacs-lisp/cl-generic.el (cl--generic-struct-tagcode): Adjust to new
value of `cl-struct-type' property.
2015-02-15 Jérémy Compostella <jeremy.compostella@gmail.com>
 
* net/tramp-sh.el (tramp-remote-process-environment): Disable paging
......@@ -5,8 +13,8 @@
 
2015-02-14 Artur Malabarba <bruce.connor.am@gmail.com>
 
* emacs-lisp/package.el (package-read-all-archive-contents): Don't
build the compatibility table.
* emacs-lisp/package.el (package-read-all-archive-contents):
Don't build the compatibility table.
(package-refresh-contents, package-initialize): Do build the
compatibility table.
(package--build-compatibility-table): New function.
......
......@@ -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))))
......
......@@ -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".
......
......@@ -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
......
......@@ -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)))
......
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