Commit 872481d9 authored by Stefan Monnier's avatar Stefan Monnier

Add classes as run-time descriptors of cl-structs.

* lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class): New function.
(cl--make-slot-desc): New constructor.
(cl--plist-remove, cl--struct-register-child): New functions.
(cl-struct-define): Rewrite.
(cl-structure-class, cl-structure-object, cl-slot-descriptor)
(cl--class): New structs.
(cl--struct-default-parent): Initialize it here.
* lisp/emacs-lisp/cl-macs.el (cl--find-class): New macro.
(cl-defsubst, cl--defsubst-expand, cl--sublis): Move before first use.
(cl--struct-default-parent): New var.
(cl-defstruct): Adjust to new representation of classes; add
default parent.  In accessors, signal `wrong-type-argument' rather than
a generic error.
(cl-struct-sequence-type, cl-struct-slot-info)
(cl-struct-slot-offset): Rewrite.
* lisp/emacs-lisp/cl-generic.el (cl--generic-struct-specializers)
(cl-generic-generalizers): Rewrite.
* src/alloc.c (purecopy): Handle hash-tables.

* lisp/emacs-lisp/debug.el (debug--implement-debug-on-entry):
Bind inhibit-debug-on-entry here...
(debug): Instead of here.

* lisp/emacs-lisp/macroexp.el (macroexp--debug-eager): New var.
(internal-macroexpand-for-load): Use it.

* lwlib/xlwmenu.c (pop_up_menu): Remove debugging code.
parent fd93edbb
2015-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
Add classes as run-time descriptors of cl-structs.
* emacs-lisp/cl-preloaded.el (cl--struct-get-class): New function.
(cl--make-slot-desc): New constructor.
(cl--plist-remove, cl--struct-register-child): New functions.
(cl-struct-define): Rewrite.
(cl-structure-class, cl-structure-object, cl-slot-descriptor)
(cl--class): New structs.
(cl--struct-default-parent): Initialize it here.
* emacs-lisp/cl-macs.el (cl--find-class): New macro.
(cl-defsubst, cl--defsubst-expand, cl--sublis): Move before first use.
(cl--struct-default-parent): New var.
(cl-defstruct): Adjust to new representation of classes; add
default parent. In accessors, signal `wrong-type-argument' rather than
a generic error.
(cl-struct-sequence-type, cl-struct-slot-info)
(cl-struct-slot-offset): Rewrite.
* emacs-lisp/cl-generic.el (cl--generic-struct-specializers)
(cl-generic-generalizers): Rewrite.
* emacs-lisp/macroexp.el (macroexp--debug-eager): New var.
(internal-macroexpand-for-load): Use it.
* emacs-lisp/debug.el (debug--implement-debug-on-entry):
Bind inhibit-debug-on-entry here...
(debug): Instead of here.
2015-03-18 Dima Kogan <dima@secretsauce.net>
Have gud-display-line not display source buffer in gud window.
......@@ -6,13 +34,13 @@
2015-03-17 Tassilo Horn <tsdh@gnu.org>
* emacs-lisp/byte-run.el (macro-declarations-alist): New
declaration no-font-lock-keyword.
* emacs-lisp/byte-run.el (macro-declarations-alist):
New declaration no-font-lock-keyword.
(defmacro): Flush font-lock in existing elisp buffers.
* emacs-lisp/lisp-mode.el (lisp--el-update-after-load)
(lisp--el-update-macro-regexp, lisp--el-macro-regexp): Delete
functions and defconst.
(lisp--el-update-macro-regexp, lisp--el-macro-regexp):
Delete functions and defconst.
(lisp--el-match-keyword): Rename from lisp--el-match-macro.
(lisp--el-font-lock-flush-elisp-buffers): New function.
(lisp-mode-variables): Remove code for updating
......@@ -21,23 +49,17 @@
2015-03-17 Simen Heggestøyl <simenheg@gmail.com>
* textmodes/css-mode.el (css--font-lock-keywords): Discriminate
between pseudo-classes and pseudo-elements.
* textmodes/css-mode.el (css--font-lock-keywords):
Discriminate between pseudo-classes and pseudo-elements.
(css-pseudo-ids): Remove.
(css-pseudo-class-ids): New variable.
(css-pseudo-element-ids): New variable.
(css--complete-property): New function for completing CSS
properties.
(css--complete-pseudo-element-or-class): New function for
(css-pseudo-class-ids, css-pseudo-element-ids): New variables.
(css--complete-property): New function for completing CSS properties.
(css--complete-pseudo-element-or-class): New function
completing CSS pseudo-elements and pseudo-classes.
(css--complete-at-rule): New function for completing CSS at-rules.
(css-completion-at-point): New function providing completion for
`css-mode'.
(css-completion-at-point): New function.
(css-mode): Add support for completion.
(css-extract-keyword-list): Remove function in favor of manual
extraction.
(css-extract-parse-val-grammar): Remove function in favor of
manual extraction.
(css-extract-keyword-list, css-extract-parse-val-grammar)
(css-extract-props-and-vals): Remove function in favor of manual
extraction.
(css-at-ids): Update list of CSS at-rule ids.
......@@ -163,7 +185,7 @@
* progmodes/sql.el: Version 3.5
(sql-starts-with-prompt-re, sql-ends-with-prompt-re): Match password prompts.
(sql-interactive-remove-continuation-prompt): Fixed regression. (Bug#6686)
(sql-interactive-remove-continuation-prompt): Fix regression. (Bug#6686)
2015-03-14 Daniel Colascione <dancol@dancol.org>
......@@ -178,8 +200,8 @@
info-look fixes for Texinfo 5
* info-look.el (c-mode, bison-mode, makefile-mode)
(makefile-automake-mode, texinfo-mode, autoconf-mode, awk-mode)
(latex-mode, emacs-lisp-mode, sh-mode, cfengine-mode): Match
`foo' and 'foo' and ‘foo’ for @item and similar.
(latex-mode, emacs-lisp-mode, sh-mode, cfengine-mode):
Match `foo' and 'foo' and ‘foo’ for @item and similar.
(latex-mode): Match multi-arg \frac{num}{den} or \sqrt[root]{n} in
suffix regexp.
......
......@@ -857,6 +857,18 @@ Can only be used from within the lexical body of a primary or around method."
;;; Support for cl-defstructs specializers.
(defun cl--generic-struct-tag (name)
;; 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)))
......@@ -864,14 +876,18 @@ Can only be used from within the lexical body of a primary or around method."
tag))))
(defun cl--generic-struct-specializers (tag)
(and (symbolp tag)
;; A method call shouldn't itself mess with the match-data.
(string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
(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-structure-object types) ;The "parent type" of all cl-structs.
(nreverse types))))
(and (symbolp tag) (boundp tag)
(let ((class (symbol-value tag)))
(when (cl-typep class 'cl-structure-class)
(let ((types ())
(classes (list class)))
;; BFS precedence.
(while (let ((class (pop classes)))
(push (cl--class-name class) types)
(setq classes
(append classes
(cl--class-parents class)))))
(nreverse types))))))
(defconst cl--generic-struct-generalizer
(cl-generic-make-generalizer
......@@ -881,27 +897,17 @@ Can only be used from within the lexical body of a primary or around method."
(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
"Support for dispatch on cl-struct types."
(or
(and (symbolp type)
(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)))
(error "Can't dispatch on cl-struct %S: no tag in slot 0"
type))
;; 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))
(list cl--generic-struct-generalizer))
(when (symbolp type)
;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
;; take place without requiring cl-lib.
(let ((class (cl--find-class type)))
(and (cl-typep class 'cl-structure-class)
(when (cl--struct-class-type class)
(error "Can't dispatch on cl-struct %S: type is %S"
type (cl--struct-class-type class)))
(progn (cl-assert (null (cl--struct-class-named class))) t)
(list cl--generic-struct-generalizer))))
(cl-call-next-method)))
;;; Dispatch on "system types".
......
......@@ -2434,8 +2434,79 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first.
(if (symbolp func) (cons func rargs)
`(funcall #',func ,@rargs))))))))
;;;###autoload
(defmacro cl-defsubst (name args &rest body)
"Define NAME as a function.
Like `defun', except the function is automatically declared `inline' and
the arguments are immutable.
ARGLIST allows full Common Lisp conventions, and BODY is implicitly
surrounded by (cl-block NAME ...).
The function's arguments should be treated as immutable.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug cl-defun) (indent 2))
(let* ((argns (cl--arglist-args args))
(p argns)
;; (pbody (cons 'progn body))
)
(while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p))
`(progn
,(if p nil ; give up if defaults refer to earlier args
`(cl-define-compiler-macro ,name
,(if (memq '&key args)
`(&whole cl-whole &cl-quote ,@args)
(cons '&cl-quote args))
(cl--defsubst-expand
',argns '(cl-block ,name ,@body)
;; We used to pass `simple' as
;; (not (or unsafe (cl-expr-access-order pbody argns)))
;; But this is much too simplistic since it
;; does not pay attention to the argvs (and
;; cl-expr-access-order itself is also too naive).
nil
,(and (memq '&key args) 'cl-whole) nil ,@argns)))
(cl-defun ,name ,args ,@body))))
(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
(if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
(if (cl--simple-exprs-p argvs) (setq simple t))
(let* ((substs ())
(lets (delq nil
(cl-mapcar (lambda (argn argv)
(if (or simple (macroexp-const-p argv))
(progn (push (cons argn argv) substs)
nil)
(list argn argv)))
argns argvs))))
;; FIXME: `sublis/subst' will happily substitute the symbol
;; `argn' in places where it's not used as a reference
;; to a variable.
;; FIXME: `sublis/subst' will happily copy `argv' to a different
;; scope, leading to name capture.
(setq body (cond ((null substs) body)
((null (cdr substs))
(cl-subst (cdar substs) (caar substs) body))
(t (cl--sublis substs body))))
(if lets `(let ,lets ,body) body))))
(defun cl--sublis (alist tree)
"Perform substitutions indicated by ALIST in TREE (non-destructively)."
(let ((x (assq tree alist)))
(cond
(x (cdr x))
((consp tree)
(cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree))))
(t tree))))
;;; Structures.
(defmacro cl--find-class (type)
`(get ,type 'cl--class))
;; Rather than hard code cl-structure-object, we indirect through this variable
;; for bootstrapping reasons.
(defvar cl--struct-default-parent nil)
;;;###autoload
(defmacro cl-defstruct (struct &rest descs)
"Define a struct type.
......@@ -2491,6 +2562,7 @@ non-nil value, that slot cannot be set via `setf'.
(tag (intern (format "cl-struct-%s" name)))
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
(include-descs nil)
(include-name nil)
(type nil)
(named nil)
(forms nil)
......@@ -2520,12 +2592,14 @@ non-nil value, that slot cannot be set via `setf'.
((eq opt :predicate)
(if args (setq predicate (car args))))
((eq opt :include)
(when include (error "Can't :include more than once"))
(setq include (car args)
include-descs (mapcar (function
(lambda (x)
(if (consp x) x (list x))))
(cdr args))))
;; FIXME: Actually, we can include more than once as long as
;; we include EIEIO classes rather than cl-structs!
(when include-name (error "Can't :include more than once"))
(setq include-name (car args))
(setq include-descs (mapcar (function
(lambda (x)
(if (consp x) x (list x))))
(cdr args))))
((eq opt :print-function)
(setq print-func (car args)))
((eq opt :type)
......@@ -2537,19 +2611,21 @@ non-nil value, that slot cannot be set via `setf'.
descs)))
(t
(error "Slot 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)))
(if print-func
(setq print-func
`(progn (funcall #',print-func cl-x cl-s cl-n) t))
(or type (and include (not (get include 'cl-struct-print)))
(or type (and include (not (cl--struct-class-print include)))
(setq print-auto t
print-func (and (or (not (or include type)) (null print-func))
`(progn
(princ ,(format "#S(%s" name) cl-s))))))
(if include
(let ((inc-type (get include 'cl-struct-type))
(old-descs (get include 'cl-struct-slots)))
(or inc-type (error "%s is not a struct name" include))
(and type (not (eq (car inc-type) type))
(let* ((inc-type (cl--struct-class-type include))
(old-descs (cl-struct-slot-info include)))
(and type (not (eq inc-type type))
(error ":type disagrees with :include for %s" name))
(while include-descs
(setcar (memq (or (assq (caar include-descs) old-descs)
......@@ -2558,9 +2634,9 @@ non-nil value, that slot cannot be set via `setf'.
old-descs)
(pop include-descs)))
(setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
type (car inc-type)
named (assq 'cl-tag-slot descs))
(if (cadr inc-type) (setq tag name named t)))
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))
......@@ -2605,8 +2681,8 @@ non-nil value, that slot cannot be set via `setf'.
(declare (side-effect-free t))
,@(and pred-check
(list `(or ,pred-check
(error "%s accessing a non-%s"
',accessor ',name))))
(signal 'wrong-type-argument
(list ',name cl-x)))))
,(if (memq type '(nil vector)) `(aref cl-x ,pos)
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x))))
......@@ -2682,8 +2758,11 @@ non-nil value, that slot cannot be set via `setf'.
`(progn
(defvar ,tag-symbol)
,@(nreverse forms)
;; Call cl-struct-define during compilation as well, so that
;; a subsequent cl-defstruct in the same file can correctly include this
;; struct as a parent.
(eval-and-compile
(cl-struct-define ',name ,docstring ',include
(cl-struct-define ',name ,docstring ',include-name
',type ,(eq named t) ',descs ',tag-symbol ',tag
',print-auto))
',name)))
......@@ -2693,7 +2772,7 @@ non-nil value, that slot cannot be set via `setf'.
STRUCT-TYPE is a symbol naming a struct type. Return 'vector or
'list, or nil if STRUCT-TYPE is not a struct type. "
(declare (side-effect-free t) (pure t))
(car (get struct-type 'cl-struct-type)))
(cl--struct-class-type (cl--struct-get-class struct-type)))
(defun cl-struct-slot-info (struct-type)
"Return a list of slot names of struct STRUCT-TYPE.
......@@ -2702,7 +2781,19 @@ slot name symbol and OPTS is a list of slot options given to
`cl-defstruct'. Dummy slots that represent the struct name and
slots skipped by :initial-offset may appear in the list."
(declare (side-effect-free t) (pure t))
(get struct-type 'cl-struct-slots))
(let* ((class (cl--struct-get-class struct-type))
(slots (cl--struct-class-slots class))
(type (cl--struct-class-type class))
(descs (if type () (list '(cl-tag-slot)))))
(dotimes (i (length slots))
(let ((slot (aref slots i)))
(push `(,(cl--slot-descriptor-name slot)
,(cl--slot-descriptor-initform slot)
,@(if (not (eq (cl--slot-descriptor-type slot) t))
`(:type ,(cl--slot-descriptor-type slot)))
,@(cl--slot-descriptor-props slot))
descs)))
(nreverse descs)))
(defun cl-struct-slot-offset (struct-type slot-name)
"Return the offset of slot SLOT-NAME in STRUCT-TYPE.
......@@ -2711,9 +2802,8 @@ the structure data type and is adjusted for any structure name
and :initial-offset slots. Signal error if struct STRUCT-TYPE
does not contain SLOT-NAME."
(declare (side-effect-free t) (pure t))
(or (cl-position slot-name
(cl-struct-slot-info struct-type)
:key #'car :test #'eq)
(or (gethash slot-name
(cl--class-index-table (cl--struct-get-class struct-type)))
(error "struct %s has no slot %s" struct-type slot-name)))
(defvar byte-compile-function-environment)
......@@ -2898,70 +2988,6 @@ macro that returns its `&whole' argument."
(if cl-found (setcdr cl-found t)))
`(throw ,cl-tag ,cl-value))
;;;###autoload
(defmacro cl-defsubst (name args &rest body)
"Define NAME as a function.
Like `defun', except the function is automatically declared `inline' and
the arguments are immutable.
ARGLIST allows full Common Lisp conventions, and BODY is implicitly
surrounded by (cl-block NAME ...).
The function's arguments should be treated as immutable.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug cl-defun) (indent 2))
(let* ((argns (cl--arglist-args args))
(p argns)
;; (pbody (cons 'progn body))
)
(while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p))
`(progn
,(if p nil ; give up if defaults refer to earlier args
`(cl-define-compiler-macro ,name
,(if (memq '&key args)
`(&whole cl-whole &cl-quote ,@args)
(cons '&cl-quote args))
(cl--defsubst-expand
',argns '(cl-block ,name ,@body)
;; We used to pass `simple' as
;; (not (or unsafe (cl-expr-access-order pbody argns)))
;; But this is much too simplistic since it
;; does not pay attention to the argvs (and
;; cl-expr-access-order itself is also too naive).
nil
,(and (memq '&key args) 'cl-whole) nil ,@argns)))
(cl-defun ,name ,args ,@body))))
(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
(if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
(if (cl--simple-exprs-p argvs) (setq simple t))
(let* ((substs ())
(lets (delq nil
(cl-mapcar (lambda (argn argv)
(if (or simple (macroexp-const-p argv))
(progn (push (cons argn argv) substs)
nil)
(list argn argv)))
argns argvs))))
;; FIXME: `sublis/subst' will happily substitute the symbol
;; `argn' in places where it's not used as a reference
;; to a variable.
;; FIXME: `sublis/subst' will happily copy `argv' to a different
;; scope, leading to name capture.
(setq body (cond ((null substs) body)
((null (cdr substs))
(cl-subst (cdar substs) (caar substs) body))
(t (cl--sublis substs body))))
(if lets `(let ,lets ,body) body))))
(defun cl--sublis (alist tree)
"Perform substitutions indicated by ALIST in TREE (non-destructively)."
(let ((x (assq tree alist)))
(cond
(x (cdr x))
((consp tree)
(cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree))))
(t tree))))
;; Compile-time optimizations for some functions defined in this package.
(defun cl--compiler-macro-member (form a list &rest keys)
......
......@@ -21,36 +21,22 @@
;;; Commentary:
;; The expectation is that structs defined with cl-defstruct do not
;; need cl-lib at run-time, but we'd like to hide the details of the
;; cl-struct metadata behind the cl-struct-define function, so we put
;; it in this pre-loaded file.
;; The cl-defstruct macro is full of circularities, since it uses the
;; cl-structure-class type (and its accessors) which is defined with itself,
;; and it setups a default parent (cl-structure-object) which is also defined
;; with cl-defstruct, and to make things more interesting, the class of
;; cl-structure-object is of course an object of type cl-structure-class while
;; cl-structure-class's parent is cl-structure-object.
;; Furthermore, the code generated by cl-defstruct generally assumes that the
;; parent will be loaded when the child is loaded. But at the same time, the
;; expectation is that structs defined with cl-defstruct do not need cl-lib at
;; run-time, which means that the `cl-structure-object' parent can't be in
;; cl-lib but should be preloaded. So here's this preloaded circular setup.
;;; 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)))
(let* ((parent-class parent))
(while parent-class
(add-to-list (intern (format "cl-struct-%s-tags" parent-class)) tag)
(setq parent-class (get parent-class 'cl-struct-include))))
;; If the cl-generic support, we need to be able to check
;; if a vector is a cl-struct object, without knowing its particular type.
;; So we use the (otherwise) unused function slots of the tag symbol
;; to put a special witness value, to make the check easy and reliable.
(unless named (fset tag :quick-object-witness-check))
(put name 'cl-struct-slots slots)
(put name 'cl-struct-type (list type named))
(if parent (put name 'cl-struct-include parent))
(if print-auto (put name 'cl-struct-print print-auto))
(if docstring (put name 'structure-documentation docstring)))
(eval-when-compile (require 'cl-macs)) ;For cl--struct-class.
;; The `assert' macro from the cl package signals
;; `cl-assertion-failed' at runtime so always define it.
......@@ -63,6 +49,199 @@
(apply #'error string (append sargs args))
(signal 'cl-assertion-failed `(,form ,@sargs)))))
;; When we load this (compiled) file during pre-loading, the cl--struct-class
;; code below will need to access the `cl-struct' info, since it's considered
;; already as its parent (because `cl-struct' was defined while the file was
;; compiled). So let's temporarily setup a fake.
(defvar cl-struct-cl-structure-object-tags nil)
(unless (cl--find-class 'cl-structure-object)
(setf (cl--find-class 'cl-structure-object) 'dummy))
(fset 'cl--make-slot-desc
;; To break circularity, we pre-define the slot constructor by hand.
;; It's redefined a bit further down as part of the cl-defstruct of
;; 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
name initform type props)))
(defun cl--struct-get-class (name)
(or (if (not (symbolp name)) name)
(cl--find-class name)
(if (not (get name 'cl-struct-type))
;; FIXME: Add a conversion for `eieio--class' so we can
;; create a cl-defstruct that inherits from an eieio class?
(error "%S is not a struct name" name)
;; Backward compatibility with a defstruct compiled with a version
;; cl-defstruct from Emacs<25. Convert to new format.
(let ((tag (intern (format "cl-struct-%s" name)))
(type-and-named (get name 'cl-struct-type))
(descs (get name 'cl-struct-slots)))
(cl-struct-define name nil (get name 'cl-struct-include)
(unless (and (eq (car type-and-named) 'vector)
(null (cadr type-and-named))
(assq 'cl-tag-slot descs))
(car type-and-named))
(cadr type-and-named)
descs
(intern (format "cl-struct-%s-tags" name))
tag
(get name 'cl-struct-print))
(cl--find-class name)))))
(defun cl--plist-remove (plist member)
(cond
((null plist) nil)
((null member) plist)
((eq plist member) (cddr plist))
(t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member)))))
(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)
(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.
(setq parent (car (cl--struct-class-parents parent)))))
;;;###autoload
(defun cl-struct-define (name docstring parent type named slots children-sym
tag print)
(cl-assert (or type (not named)))
(if (boundp children-sym)
(add-to-list children-sym tag)
(set children-sym (list tag)))
(and (null type) (eq (caar slots) 'cl-tag-slot)
;; Hide the tag slot from "standard" (i.e. non-`type'd) structs.
(setq slots (cdr slots)))
(let* ((parent-class (when parent (cl--struct-get-class parent)))
(n (length slots))
(index-table (make-hash-table :test 'eq :size n))
(vslots (let ((v (make-vector n nil))
(i 0)
(offset (if type 0 1)))
(dolist (slot slots)
(let* ((props (cddr slot))
(typep (plist-member props :type))
(type (if typep (cadr typep) t)))
(aset v i (cl--make-slot-desc
(car slot) (nth 1 slot)
type (cl--plist-remove props typep))))
(puthash (car slot) (+ i offset) index-table)
(cl-incf i))
v))
(class (cl--struct-new-class
name docstring
(unless (symbolp parent-class) (list parent-class))
type named vslots index-table children-sym tag print)))
(unless (symbolp parent-class)
(let ((pslots (cl--struct-class-slots parent-class)))
(or (>= n (length pslots))
(let ((ok t))
(dotimes (i (length pslots))
(unless (eq (cl--slot-descriptor-name (aref pslots i))
(cl--slot-descriptor-name (aref vslots i)))
(setq ok nil)))
ok)
(error "Included struct %S has changed since compilation of %S"
parent name))))
(cl--struct-register-child parent-class tag)
(unless (eq named t)
(eval `(defconst ,tag ',class) t)
;; In the cl-generic support, we need to be able to check
;; if a vector is a cl-struct object, without knowing its particular type.
;; So we use the (otherwise) unused function slots of the tag symbol
;; to put a special witness value, to make the check easy and reliable.
(fset tag :quick-object-witness-check))
(setf (cl--find-class name) class)))
(cl-defstruct (cl-structure-class
(:conc-name cl--struct-class-)
(:predicate cl--struct-class-p)
(:constructor nil)
(:constructor cl--struct-new-class
(name docstring parents type named slots index-table