mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-02-02 20:16:25 +00:00
Code Issues Releases Activity

defstruct introspection

Browse Source
This commit is contained in:
Daniel Colascione 2014-04-19 19:34:22 -07:00
parent 6dfa19c50f
commit 89a2e783c2
7 changed files with 192 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
doc/misc/cl.texi
View File

@ -4247,6 +4247,46 @@ of the included type and the first new slot.
Except as noted, the @code{cl-defstruct} facility of this package is
entirely compatible with that of Common Lisp.
The @code{cl-defstruct} package also provides a few structure
introspection functions.
@defun cl-struct-sequence-type struct-type
This function returns the underlying data structure for
@code{struct-type}, which is a symbol. It returns @code{vector} or
@code{list}, or @code{nil} if @code{struct-type} is not actually a
structure.
@defun cl-struct-slot-info struct-type
This function returns a list of slot descriptors for structure
@code{struct-type}. Each entry in the list is @code{(name . opts)},
where @code{name} is the name of the slot and @code{opts} is the list
of slot options given to @code{defstruct}. Dummy entries represent
the slots used for the struct name and that are skipped to implement
@code{:initial-offset}.
@defun cl-struct-slot-offset struct-type slot-name
Return the offset of slot @code{slot-name} in @code{struct-type}. The
returned zero-based slot index is relative to the start of the
structure data type and is adjusted for any structure name and
:initial-offset slots. Signal error if struct @code{struct-type} does
not contain @code{slot-name}.
@defun cl-struct-slot-value struct-type slot-name inst
Return the value of slot @code{slot-name} in @code{inst} of
@code{struct-type}. @code{struct} and @code{slot-name} are symbols.
@code{inst} is a structure instance. This routine is also a
@code{setf} place. @code{cl-struct-slot-value} uses
@code{cl-struct-slot-offset} internally and can signal the same
errors.
@defun cl-struct-set-slot-value struct-type slot-name inst value
Set the value of slot @code{slot-name} in @code{inst} of
@code{struct-type}. @code{struct} and @code{slot-name} are symbols.
@code{inst} is a structure instance. @code{value} is the value to
which to set the given slot. Return @code{value}.
@code{cl-struct-slot-value} uses @code{cl-struct-set-slot-offset}
internally and can signal the same errors.
@node Assertions
@chapter Assertions and Errors

4
etc/ChangeLog
View File

@ -1,3 +1,7 @@
2014-04-20 Daniel Colascione <dancol@dancol.org>
* NEWS: Mention new struct functions.
2014-04-17 Daniel Colascione <dancol@dancol.org>
* NEWS: Mention bracketed paste support.

3
etc/NEWS
View File

@ -97,6 +97,9 @@ active region handling.
** You can specify a function's interactive-only property via `declare'.
However you specify it, the property affects `describe-function' output.
** You can access the slots of structures using `cl-struct-slot-value'
and `cl-struct-set-slot-value'.
* Changes in Emacs 24.5 on Non-Free Operating Systems

13
lisp/ChangeLog
View File

@ -1,3 +1,16 @@
2014-04-20 Daniel Colascione <dancol@dancol.org>
* emacs-lisp/cl-macs.el (cl-the): Make `cl-the' assert its type
argument.
(cl--const-expr-val): cl--const-expr-val should macroexpand its
argument in case we're inside a symbol-macrolet.
(cl--do-arglist, cl--compiler-macro-typep)
(cl--compiler-macro-member, cl--compiler-macro-assoc): Pass macro
environment to `cl--const-expr-val'.
(cl-struct-sequence-type,cl-struct-slot-info)
(cl-struct-slot-offset, cl-struct-slot-value)
(cl-struct-set-slot-value): New functions.
2014-04-19 Stefan Monnier <monnier@iro.umontreal.ca>
* progmodes/sh-script.el (sh-smie--sh-keyword-p): Handle variable

119
lisp/emacs-lisp/cl-macs.el
View File

@ -134,8 +134,15 @@
((symbolp x) (and (memq x '(nil t)) t))
(t t)))
(defun cl--const-expr-val (x)
(and (macroexp-const-p x) (if (consp x) (nth 1 x) x)))
(defun cl--const-expr-val (x &optional environment default)
"Return the value of X known at compile-time.
If X is not known at compile time, return DEFAULT. Before
testing whether X is known at compile time, macroexpand it in
ENVIRONMENT."
(let ((x (macroexpand-all x environment)))
(if (macroexp-const-p x)
(if (consp x) (nth 1 x) x)
default)))
(defun cl--expr-contains (x y)
"Count number of times X refers to Y. Return nil for 0 times."
@ -519,7 +526,8 @@ its argument list allows full Common Lisp conventions."
look
`(or ,look
,(if (eq (cl--const-expr-p def) t)
`'(nil ,(cl--const-expr-val def))
`'(nil ,(cl--const-expr-val
def macroexpand-all-environment))
`(list nil ,def))))))))
(push karg keys)))))
(setq keys (nreverse keys))
@ -2057,10 +2065,21 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(declare (debug t))
(cons 'progn body))
;;;###autoload
(defmacro cl-the (_type form)
"At present this ignores TYPE and is simply equivalent to FORM."
(defmacro cl-the (type form)
"Return FORM. If type-checking is enabled, assert that it is of TYPE."
(declare (indent 1) (debug (cl-type-spec form)))
form)
(if (not (or (not (cl--compiling-file))
(< cl--optimize-speed 3)
(= cl--optimize-safety 3)))
form
(let* ((temp (if (cl--simple-expr-p form 3)
form (make-symbol "--cl-var--")))
(body `(progn (unless ,(cl--make-type-test temp type)
(signal 'wrong-type-argument
(list ',type ,temp ',form)))
,temp)))
(if (eq temp form) body
`(let ((,temp ,form)) ,body)))))
(defvar cl--proclaim-history t) ; for future compilers
(defvar cl--declare-stack t) ; for future compilers
@ -2577,6 +2596,83 @@ non-nil value, that slot cannot be set via `setf'.
forms)
`(progn ,@(nreverse (cons `',name forms)))))
(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. "
(car (get struct-type 'cl-struct-type)))
(put 'cl-struct-sequence-type 'side-effect-free t)
(defun cl-struct-slot-info (struct-type)
"Return a list of slot names of struct STRUCT-TYPE.
Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a
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."
(get struct-type 'cl-struct-slots))
(put 'cl-struct-slot-info 'side-effect-free t)
(defun cl-struct-slot-offset (struct-type slot-name)
"Return the offset of slot SLOT-NAME in STRUCT-TYPE.
The returned zero-based slot index is relative to the start of
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."
(or (cl-position slot-name
(cl-struct-slot-info struct-type)
:key #'car :test #'eq)
(error "struct %s has no slot %s" struct-type slot-name)))
(put 'cl-struct-slot-offset 'side-effect-free t)
(defun cl-struct-slot-value (struct-type slot-name inst)
"Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.
STRUCT and SLOT-NAME are symbols. INST is a structure instance."
(unless (cl-typep inst struct-type)
(signal 'wrong-type-argument (list struct-type inst)))
(elt inst (cl-struct-slot-offset struct-type slot-name)))
(put 'cl-struct-slot-value 'side-effect-free t)
(defun cl-struct-set-slot-value (struct-type slot-name inst value)
"Set the value of slot SLOT-NAME in INST of STRUCT-TYPE.
STRUCT and SLOT-NAME are symbols. INST is a structure instance.
VALUE is the value to which to set the given slot. Return
VALUE."
(unless (cl-typep inst struct-type)
(signal 'wrong-type-argument (list struct-type inst)))
(setf (elt inst (cl-struct-slot-offset struct-type slot-name)) value))
(defsetf cl-struct-slot-value cl-struct-set-slot-value)
(cl-define-compiler-macro cl-struct-slot-value
(&whole orig struct-type slot-name inst)
(or (let* ((macenv macroexpand-all-environment)
(struct-type (cl--const-expr-val struct-type macenv))
(slot-name (cl--const-expr-val slot-name macenv)))
(and struct-type (symbolp struct-type)
slot-name (symbolp slot-name)
(assq slot-name (cl-struct-slot-info struct-type))
(let ((idx (cl-struct-slot-offset struct-type slot-name)))
(cl-ecase (cl-struct-sequence-type struct-type)
(vector `(aref (cl-the ,struct-type ,inst) ,idx))
(list `(nth ,idx (cl-the ,struct-type ,inst)))))))
orig))
(cl-define-compiler-macro cl-struct-set-slot-value
(&whole orig struct-type slot-name inst value)
(or (let* ((macenv macroexpand-all-environment)
(struct-type (cl--const-expr-val struct-type macenv))
(slot-name (cl--const-expr-val slot-name macenv)))
(and struct-type (symbolp struct-type)
slot-name (symbolp slot-name)
(assq slot-name (cl-struct-slot-info struct-type))
(let ((idx (cl-struct-slot-offset struct-type slot-name)))
(cl-ecase (cl-struct-sequence-type struct-type)
(vector `(setf (aref (cl-the ,struct-type ,inst) ,idx)
,value))
(list `(setf (nth ,idx (cl-the ,struct-type ,inst))
,value))))))
orig))
;;; Types and assertions.
;;;###autoload
@ -2653,7 +2749,8 @@ TYPE is a Common Lisp-style type specifier."
(defun cl--compiler-macro-typep (form val type)
(if (macroexp-const-p type)
(macroexp-let2 macroexp-copyable-p temp val
(cl--make-type-test temp (cl--const-expr-val type)))
(cl--make-type-test temp (cl--const-expr-val
type macroexpand-all-environment)))
form))
;;;###autoload
@ -2829,7 +2926,8 @@ The function's arguments should be treated as immutable.
(defun cl--compiler-macro-member (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl--const-expr-val (nth 1 keys)))))
(cl--const-expr-val (nth 1 keys)
macroexpand-all-environment))))
(cond ((eq test 'eq) `(memq ,a ,list))
((eq test 'equal) `(member ,a ,list))
((or (null keys) (eq test 'eql)) `(memql ,a ,list))
@ -2837,11 +2935,12 @@ The function's arguments should be treated as immutable.
(defun cl--compiler-macro-assoc (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl--const-expr-val (nth 1 keys)))))
(cl--const-expr-val (nth 1 keys)
macroexpand-all-environment))))
(cond ((eq test 'eq) `(assq ,a ,list))
((eq test 'equal) `(assoc ,a ,list))
((and (macroexp-const-p a) (or (null keys) (eq test 'eql)))
(if (floatp (cl--const-expr-val a))
(if (floatp (cl--const-expr-val a macroexpand-all-environment))
`(assoc ,a ,list) `(assq ,a ,list)))
(t form))))

4
test/ChangeLog
View File

@ -1,3 +1,7 @@
2014-04-20 Daniel Colascione <dancol@dancol.org>
* automated/cl-lib.el (cl-lib-struct-accessors,cl-the): New tests.
2014-04-19 Michael Albinus <michael.albinus@gmx.de>
* automated/tramp-tests.el (tramp--test-check-files): Extend test.

19
test/automated/cl-lib.el
View File

@ -201,4 +201,23 @@
:b :a :a 42)
'(42 :a))))
(ert-deftest cl-lib-struct-accessors ()
(cl-defstruct mystruct (abc :readonly t) def)
(let ((x (make-mystruct :abc 1 :def 2)))
(should (eql (cl-struct-slot-value 'mystruct 'abc x) 1))
(should (eql (cl-struct-slot-value 'mystruct 'def x) 2))
(cl-struct-set-slot-value 'mystruct 'def x -1)
(should (eql (cl-struct-slot-value 'mystruct 'def x) -1))
(should (eql (cl-struct-slot-offset 'mystruct 'abc) 1))
(should-error (cl-struct-slot-offset 'mystruct 'marypoppins))
(should (equal (cl-struct-slot-info 'mystruct)
'((cl-tag-slot) (abc :readonly t) (def))))))
(ert-deftest cl-the ()
(should (eql (the integer 42) 42))
(should-error (the integer "abc"))
(let ((sideffect 0))
(should (= (the integer (incf sideffect)) 1))
(should (= sideffect 1))))
;;; cl-lib.el ends here