From: Lars Brinkhoff <lars@nocrew.org>
To: emacs-devel@gnu.org
Subject: Re: User-defined record types, v2
Date: Sat, 18 Mar 2017 18:13:08 +0100 [thread overview]
Message-ID: <86k27mtsnv.fsf@molnjunk.nocrew.org> (raw)
In-Reply-To: 86tw6qtt01.fsf@molnjunk.nocrew.org
Update cl-defstruct to use records.
* lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tag): Use type-of.
(cl--generic-struct-specializers): Adjust to new tag.
* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Use type=nil as before.
Use the type symbol as the tag. Use copy-record to copy structs.
(cl--defstruct-predicate): New function.
(cl--pcase-mutually-exclusive-p): Use it.
(cl-struct-sequence-type): Can now return `record'.
* lisp/emacs-lisp/cl-preloaded.el (cl--make-slot-desc): Adjust ad-hoc
code to new format.
(cl--struct-register-child): Work with records.
(cl-struct-define): Don't touch the tag's symbol-value and
symbol-function slots when we use the type as tag.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8c6d3d5..e15c942 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1082,24 +1082,8 @@ cl--generic-eql-used
;;; Support for cl-defstructs specializers.
(defun cl--generic-struct-tag (name &rest _)
- ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
- ;; but that would suffer from some problems:
- ;; - the vector may have size 0.
- ;; - when called on an actual vector (rather than an object), we'd
- ;; end up returning an arbitrary value, possibly colliding with
- ;; other tagcode's values.
- ;; - it can also result in returning all kinds of irrelevant
- ;; values which would end up filling up the method-cache with
- ;; lots of irrelevant/redundant entries.
- ;; FIXME: We could speed this up by introducing a dedicated
- ;; vector type at the C level, so we could do something like
- ;; (and (vector-objectp ,name) (aref ,name 0))
- `(and (vectorp ,name)
- (> (length ,name) 0)
- (let ((tag (aref ,name 0)))
- (and (symbolp tag)
- (eq (symbol-function tag) :quick-object-witness-check)
- tag))))
+ ;; Use exactly the same code as for `typeof'.
+ `(if ,name (type-of ,name) 'null))
(defun cl--generic-class-parents (class)
(let ((parents ())
@@ -1113,8 +1097,8 @@ cl--generic-class-parents
(nreverse parents)))
(defun cl--generic-struct-specializers (tag &rest _)
- (and (symbolp tag) (boundp tag)
- (let ((class (symbol-value tag)))
+ (and (symbolp tag)
+ (let ((class (get tag 'cl--class)))
(when (cl-typep class 'cl-structure-class)
(cl--generic-class-parents class)))))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 40342f3..7e08ca2 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2604,11 +2604,24 @@ cl-defstruct
(print-func nil) (print-auto nil)
(safety (if (cl--compiling-file) cl--optimize-safety 3))
(include nil)
- (tag (intern (format "cl-struct-%s" name)))
+ ;; There are 4 types of structs:
+ ;; - `vector' type: means we should use a vector, which can come
+ ;; with or without a tag `name', which is usually in slot 0
+ ;; but obeys :initial-offset.
+ ;; - `list' type: same as `vector' but using lists.
+ ;; - `record' type: means we should use a record, which necessarily
+ ;; comes tagged in slot 0. Currently we'll use the `name' as
+ ;; the tag, but we may want to change it so that the class object
+ ;; is used as the tag.
+ ;; - nil type: this is the "pre-record default", which uses a vector
+ ;; with a tag in slot 0 which is a symbol of the form
+ ;; `cl-struct-NAME'. We need to still support this for backward
+ ;; compatibility with old .elc files.
+ (tag name)
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
(include-descs nil)
(include-name nil)
- (type nil)
+ (type nil) ;nil here means not specified explicitly.
(named nil)
(forms nil)
(docstring (if (stringp (car descs)) (pop descs)))
@@ -2648,7 +2661,9 @@ cl-defstruct
((eq opt :print-function)
(setq print-func (car args)))
((eq opt :type)
- (setq type (car args)))
+ (setq type (car args))
+ (unless (memq type '(vector list))
+ (error "Invalid :type specifier: %s" type)))
((eq opt :named)
(setq named t))
((eq opt :initial-offset)
@@ -2680,13 +2695,11 @@ cl-defstruct
(pop include-descs)))
(setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
type inc-type
- named (if type (assq 'cl-tag-slot descs) 'true))
- (if (cl--struct-class-named include) (setq tag name named t)))
- (if type
- (progn
- (or (memq type '(vector list))
- (error "Invalid :type specifier: %s" type))
- (if named (setq tag name)))
+ named (if (memq type '(vector list))
+ (assq 'cl-tag-slot descs)
+ 'true))
+ (if (cl--struct-class-named include) (setq named t)))
+ (unless type
(setq named 'true)))
(or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
(when (and (null predicate) named)
@@ -2696,7 +2709,9 @@ cl-defstruct
(length (memq (assq 'cl-tag-slot descs)
descs)))))
(cond
- ((memq type '(nil vector))
+ ((null type) ;Record type.
+ `(memq (type-of cl-x) ,tag-symbol))
+ ((eq type 'vector)
`(and (vectorp cl-x)
(>= (length cl-x) ,(length descs))
(memq (aref cl-x ,pos) ,tag-symbol)))
@@ -2793,7 +2808,9 @@ cl-defstruct
(setq slots (nreverse slots)
defaults (nreverse defaults))
(and copier
- (push `(defalias ',copier #'copy-sequence) forms))
+ (push `(defalias ',copier
+ ,(if (null type) '#'copy-record '#'copy-sequence))
+ forms))
(if constructor
(push (list constructor
(cons '&key (delq nil (copy-sequence slots))))
@@ -2808,7 +2825,7 @@ cl-defstruct
(format "Constructor for objects of type `%s'." name))
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
- (,(or type #'vector) ,@make))
+ (,(or type #'record) ,@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
@@ -2866,6 +2883,15 @@ cl--struct-all-parents
,pat)))
fields)))
+(defun cl--defstruct-predicate (type)
+ (let ((cons (assq (cl-struct-sequence-type type)
+ `((list . consp)
+ (vector . vectorp)
+ (nil . recordp)))))
+ (if cons
+ (cdr cons)
+ 'recordp)))
+
(defun cl--pcase-mutually-exclusive-p (orig pred1 pred2)
"Extra special cases for `cl-typep' predicates."
(let* ((x1 pred1) (x2 pred2)
@@ -2888,14 +2914,12 @@ cl--pcase-mutually-exclusive-p
(memq c2 (cl--struct-all-parents c1)))))))
(let ((c1 (and (symbolp t1) (cl--find-class t1))))
(and c1 (cl--struct-class-p c1)
- (funcall orig (if (eq 'list (cl-struct-sequence-type t1))
- 'consp 'vectorp)
+ (funcall orig (cl--defstruct-predicate t1)
pred2)))
(let ((c2 (and (symbolp t2) (cl--find-class t2))))
(and c2 (cl--struct-class-p c2)
(funcall orig pred1
- (if (eq 'list (cl-struct-sequence-type t2))
- 'consp 'vectorp))))
+ (cl--defstruct-predicate t2))))
(funcall orig pred1 pred2))))
(advice-add 'pcase--mutually-exclusive-p
:around #'cl--pcase-mutually-exclusive-p)
@@ -2903,8 +2927,8 @@ cl--pcase-mutually-exclusive-p
(defun cl-struct-sequence-type (struct-type)
"Return the sequence used to build STRUCT-TYPE.
-STRUCT-TYPE is a symbol naming a struct type. Return `vector' or
-`list', or nil if STRUCT-TYPE is not a struct type. "
+STRUCT-TYPE is a symbol naming a struct type. Return `record',
+`vector`, or `list' if STRUCT-TYPE is a struct type, nil otherwise."
(declare (side-effect-free t) (pure t))
(cl--struct-class-type (cl--struct-get-class struct-type)))
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index bba7b83..bd77654 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -64,7 +64,7 @@ cl-struct-cl-structure-object-tags
;; cl--slot-descriptor.
;; BEWARE: Obviously, it's important to keep the two in sync!
(lambda (name &optional initform type props)
- (vector 'cl-struct-cl-slot-descriptor
+ (record 'cl-slot-descriptor
name initform type props)))
(defun cl--struct-get-class (name)
@@ -101,7 +101,7 @@ cl--plist-remove
(defun cl--struct-register-child (parent tag)
;; Can't use (cl-typep parent 'cl-structure-class) at this stage
;; because `cl-structure-class' is defined later.
- (while (vectorp parent)
+ (while (recordp parent)
(add-to-list (cl--struct-class-children-sym parent) tag)
;; Only register ourselves as a child of the leftmost parent since structs
;; can only only have one parent.
@@ -150,7 +150,7 @@ cl-struct-define
parent name))))
(add-to-list 'current-load-list `(define-type . ,name))
(cl--struct-register-child parent-class tag)
- (unless (eq named t)
+ (unless (or (eq named t) (eq tag name))
;; We used to use `defconst' instead of `set' but that
;; has a side-effect of purecopying during the dump, so that the
;; class object stored in the tag ends up being a *copy* of the
next prev parent reply other threads:[~2017-03-18 17:13 UTC|newest]
Thread overview: 31+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-03-18 17:04 User-defined record types, v2 Lars Brinkhoff
2017-03-18 17:05 ` Lars Brinkhoff
2017-03-18 17:13 ` Lars Brinkhoff [this message]
2017-03-18 17:17 ` Lars Brinkhoff
2017-03-18 17:21 ` Lars Brinkhoff
2017-03-18 17:35 ` Eli Zaretskii
2017-03-18 19:33 ` Lars Brinkhoff
2017-03-18 22:24 ` Stefan Monnier
2017-03-19 9:17 ` Lars Brinkhoff
2017-03-19 12:50 ` Stefan Monnier
2017-03-19 14:51 ` Eli Zaretskii
2017-03-18 17:29 ` Eli Zaretskii
2017-03-19 10:28 ` Lars Brinkhoff
2017-03-19 12:51 ` Stefan Monnier
2017-03-21 9:55 ` Lars Brinkhoff
2017-03-21 11:53 ` Stefan Monnier
2017-03-22 21:15 ` Stefan Monnier
2017-03-23 6:53 ` Lars Brinkhoff
2017-03-23 7:02 ` Lars Brinkhoff
2017-03-23 7:34 ` Lars Brinkhoff
2017-03-23 19:47 ` Stefan Monnier
2017-03-24 10:15 ` Lars Brinkhoff
2017-03-24 18:17 ` Stefan Monnier
2017-03-24 20:38 ` Lars Brinkhoff
2017-03-29 12:46 ` Lars Brinkhoff
2017-03-30 12:59 ` Stefan Monnier
2017-03-30 14:57 ` Lars Brinkhoff
2017-03-30 15:07 ` Stefan Monnier
2017-03-30 18:10 ` Eli Zaretskii
2017-03-22 7:58 ` Lars Brinkhoff
2017-03-22 8:46 ` Andreas Schwab
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=86k27mtsnv.fsf@molnjunk.nocrew.org \
--to=lars@nocrew.org \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.