From 89a2e783c2f22b4932dd77c16a0e357c5c17a4bf Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Sat, 19 Apr 2014 19:34:22 -0700 Subject: [PATCH] defstruct introspection --- doc/misc/cl.texi | 40 +++++++++++++ etc/ChangeLog | 4 ++ etc/NEWS | 3 + lisp/ChangeLog | 13 ++++ lisp/emacs-lisp/cl-macs.el | 119 +++++++++++++++++++++++++++++++++---- test/ChangeLog | 4 ++ test/automated/cl-lib.el | 19 ++++++ 7 files changed, 192 insertions(+), 10 deletions(-) diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index f0ac289aca..1c20296188 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -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 diff --git a/etc/ChangeLog b/etc/ChangeLog index 1672b0f06a..de57d81a68 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2014-04-20 Daniel Colascione + + * NEWS: Mention new struct functions. + 2014-04-17 Daniel Colascione * NEWS: Mention bracketed paste support. diff --git a/etc/NEWS b/etc/NEWS index d2019c72bf..c3b2e502f0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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 diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 648e5f3869..a1da41a569 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,16 @@ +2014-04-20 Daniel Colascione + + * 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 * progmodes/sh-script.el (sh-smie--sh-keyword-p): Handle variable diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index cd2d52a4b2..b0a5c442d4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -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)))) diff --git a/test/ChangeLog b/test/ChangeLog index 338a825f51..940ed0b0b9 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2014-04-20 Daniel Colascione + + * automated/cl-lib.el (cl-lib-struct-accessors,cl-the): New tests. + 2014-04-19 Michael Albinus * automated/tramp-tests.el (tramp--test-check-files): Extend test. diff --git a/test/automated/cl-lib.el b/test/automated/cl-lib.el index f7f4314e1c..a0df07e54e 100644 --- a/test/automated/cl-lib.el +++ b/test/automated/cl-lib.el @@ -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 -- 2.20.1