mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-04 11:40:22 +00:00
Code Issues Releases Activity

Add record objects with user-defined types.

Browse Source 
* src/alloc.c (allocate_record): New function.
(Fmake_record, Frecord, Fcopy_record): New functions.
(syms_of_alloc): defsubr them.
(purecopy): Work with records.

* src/data.c (Ftype_of): Return slot 0 for record objects, or type
name if record's type holds class.
(Frecordp): New function.
(syms_of_data): defsubr it.  Define `Qrecordp'.
(Faref, Faset): Work with records.

* src/fns.c (Flength): Work with records.

* src/lisp.h (prec_type): Add PVEC_RECORD.
(RECORDP, CHECK_RECORD, CHECK_RECORD_TYPE): New functions.

* src/lread.c (read1): Add syntax for records.

* src/print.c (PRINT_CIRCLE_CANDIDATE_P): Add RECORDP.
(print_object): Add syntax for records.

* test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-2):
New test.

* test/src/alloc-tests.el (record-1, record-2, record-3):
New tests.

* doc/lispref/elisp.texi, doc/lispref/objects.texi,
doc/lispref/records.texi: Add documentation for records.
This commit is contained in:
Lars Brinkhoff 2013-01-06 14:27:44 +01:00
parent 19b92cdfb0
commit a2c3343029
11 changed files with 333 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
doc/lispref/elisp.texi
View File

@ -180,6 +180,7 @@ To view this manual in other formats, click
* Sequences Arrays Vectors:: Lists, strings and vectors are called sequences.
Certain functions act on any kind of sequence.
The description of vectors is here as well.
* Records:: Compound objects with programmer-defined types.
* Hash Tables:: Very fast lookup-tables.
* Symbols:: Symbols represent names, uniquely.
@ -314,6 +315,7 @@ Programming Types
expression, more fundamental but less pretty.
* Primitive Function Type:: A function written in C, callable from Lisp.
* Byte-Code Type:: A function written in Lisp, then compiled.
* Record Type:: Compound objects with programmer-defined types.
* Autoload Type:: A type used for automatically loading seldom-used
functions.
* Finalizer Type:: Runs code when no longer reachable.
@ -418,6 +420,10 @@ Sequences, Arrays, and Vectors
* Bool-Vectors:: How to work with bool-vectors.
* Rings:: Managing a fixed-size ring of objects.
Records
* Record Functions:: Functions for records.
Hash Tables
* Creating Hash:: Functions to create hash tables.
@ -1594,6 +1600,7 @@ Object Internals
@include lists.texi
@include sequences.texi
@include records.texi
@include hash.texi
@include symbols.texi
@include eval.texi

24
doc/lispref/objects.texi
View File

@ -25,9 +25,10 @@ but not for @emph{the} type of an object.
which all other types are constructed, are called @dfn{primitive types}.
Each object belongs to one and only one primitive type. These types
include @dfn{integer}, @dfn{float}, @dfn{cons}, @dfn{symbol},
@dfn{string}, @dfn{vector}, @dfn{hash-table}, @dfn{subr}, and
@dfn{byte-code function}, plus several special types, such as
@dfn{buffer}, that are related to editing. (@xref{Editing Types}.)
@dfn{string}, @dfn{vector}, @dfn{hash-table}, @dfn{subr},
@dfn{byte-code function}, and @dfn{record}, plus several special
types, such as @dfn{buffer}, that are related to editing.
(@xref{Editing Types}.)
Each primitive type has a corresponding Lisp function that checks
whether an object is a member of that type.
@ -154,6 +155,7 @@ latter are unique to Emacs Lisp.
expression, more fundamental but less pretty.
* Primitive Function Type:: A function written in C, callable from Lisp.
* Byte-Code Type:: A function written in Lisp, then compiled.
* Record Type:: Compound objects with programmer-defined types.
* Autoload Type:: A type used for automatically loading seldom-used
functions.
* Finalizer Type:: Runs code when no longer reachable.
@ -1347,6 +1349,16 @@ The printed representation and read syntax for a byte-code function
object is like that for a vector, with an additional @samp{#} before the
opening @samp{[}.
@node Record Type
@subsection Record Type
A @dfn{record} is much like a @code{vector}. However, the first
element is used to hold its type as returned by @code{type-of}. The
purpose of records is to allow programmers to create objects with new
types that are not built into Emacs.
@xref{Records}, for functions that work with records.
@node Autoload Type
@subsection Autoload Type
@ -1959,6 +1971,9 @@ with references to further information.
@item processp
@xref{Processes, processp}.
@item recordp
@xref{Record Type, recordp}.
@item sequencep
@xref{Sequence Functions, sequencep}.
@ -2022,6 +2037,7 @@ This function returns a symbol naming the primitive type of
@code{marker}, @code{mutex}, @code{overlay}, @code{process},
@code{string}, @code{subr}, @code{symbol}, @code{thread},
@code{vector}, @code{window}, or @code{window-configuration}.
However, if @var{object} is a record, its first slot is returned.
@example
(type-of 1)
@ -2033,6 +2049,8 @@ This function returns a symbol naming the primitive type of
@result{} symbol
(type-of '(x))
@result{} cons
(type-of (record 'foo))
@result{} foo
@end group
@end example
@end defun

98
doc/lispref/records.texi Normal file
View File

@ -0,0 +1,98 @@
@c -*-texinfo-*-
@c This is part of the GNU Emacs Lisp Reference Manual.
@c Copyright (C) 2017 Free Software
@c Foundation, Inc.
@c See the file elisp.texi for copying conditions.
@node Records
@chapter Records
@cindex record
The purpose of records is to allow programmers to create objects
with new types that are not built into Emacs.
Internally, a record object is much like a vector; its slots can be
accessed using @code{aref}. However, the first slot is used to hold
its type as returned by @code{type-of}. Like arrays, records use
zero-origin indexing: the first slot has index 0.
The printed representation of records is @samp{#s} followed by a
list specifying the contents. The first list element must be the
record type. The following elements are the record slots.
A record is considered a constant for evaluation: the result of
evaluating it is the same record. This does not evaluate or even
examine the slots. @xref{Self-Evaluating Forms}.
@menu
* Record Functions:: Functions for records.
@end menu
@node Record Functions
@section Record Functions
@defun recordp object
This function returns @code{t} if @var{object} is a record.
@example
@group
(recordp #s(a))
@result{} t
@end group
@end example
@end defun
@defun record type &rest objects
This function creates and returns a record whose type is @var{type}
and remaining slots are the rest of the arguments, @var{objects}.
@example
@group
(vector 'foo 23 [bar baz] "rats")
@result{} #s(foo 23 [bar baz] "rats")
@end group
@end example
@end defun
@defun make-record type length object
This function returns a new record with type @var{type} and
@var{length} more slots, each initialized to @var{object}.
@example
@group
(setq sleepy (make-record 'foo 9 'Z))
@result{} #s(foo Z Z Z Z Z Z Z Z Z)
@end group
@end example
@end defun
@defun copy-record record
This function returns a shallow copy of @var{record}. The copy is the
same type as the original record, and it has the same slots in the
same order.
Storing a new slot into the copy does not affect the original
@var{record}, and vice versa. However, the slots of the new record
are not copies; they are identical (@code{eq}) to the slots of the
original. Therefore, changes made within these slots, as found via
the copied record, are also visible in the original record.
@example
@group
(setq x (record 'foo 1 2))
@result{} #s(foo 1 2)
@end group
@group
(setq y (copy-record x))
@result{} #s(foo 1 2)
@end group
@group
(eq x y)
@result{} nil
@end group
@group
(equal x y)
@result{} t
@end group
@end example
@end defun

93
src/alloc.c
View File

@ -3392,6 +3392,94 @@ allocate_buffer (void)
return b;
}
/* Allocate a new record with COUNT slots. Return NULL if COUNT is
too large. */
static struct Lisp_Vector *
allocate_record (int count)
{
if (count >= (1 << PSEUDOVECTOR_SIZE_BITS))
return NULL;
struct Lisp_Vector *p = allocate_vector (count);
XSETPVECTYPE (p, PVEC_RECORD);
return p;
}
DEFUN ("make-record", Fmake_record, Smake_record, 3, 3, 0,
doc: /* Create a new record.
TYPE is its type as returned by `type-of'. SLOTS is the number of
slots, each initialized to INIT. The number of slots, including the
type slot, must fit in PSEUDOVECTOR_SIZE_BITS. */)
(Lisp_Object type, Lisp_Object slots, Lisp_Object init)
{
Lisp_Object record;
ptrdiff_t size, i;
struct Lisp_Vector *p;
CHECK_NATNUM (slots);
size = XFASTINT (slots) + 1;
p = allocate_record (size);
if (p == NULL)
error ("Attempt to allocate a record of %ld slots; max is %d",
size, (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
p->contents[0] = type;
for (i = 1; i < size; i++)
p->contents[i] = init;
XSETVECTOR (record, p);
return record;
}
DEFUN ("record", Frecord, Srecord, 1, MANY, 0,
doc: /* Create a new record.
TYPE is its type as returned by `type-of'. SLOTS is used to
initialize the record slots with shallow copies of the arguments. The
number of slots, including the type slot, must fit in
PSEUDOVECTOR_SIZE_BITS.
usage: (record TYPE &rest SLOTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
struct Lisp_Vector *p = allocate_record (nargs);
if (p == NULL)
error ("Attempt to allocate a record of %ld slots; max is %d",
nargs, (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
Lisp_Object type = args[0];
Lisp_Object record;
p->contents[0] = type;
memcpy (p->contents + 1, args + 1, (nargs - 1) * sizeof *args);
XSETVECTOR (record, p);
return record;
}
DEFUN ("copy-record", Fcopy_record, Scopy_record, 1, 1, 0,
doc: /* Return a new record that is a shallow copy of the argument RECORD. */)
(Lisp_Object record)
{
CHECK_RECORD (record);
struct Lisp_Vector *src = XVECTOR (record);
ptrdiff_t size = ASIZE (record) & PSEUDOVECTOR_SIZE_MASK;
struct Lisp_Vector *new = allocate_record (size);
if (new == NULL)
error ("Attempt to allocate a record of %ld slots; max is %d",
size, (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
memcpy (&(new->contents[0]), &(src->contents[0]),
size * sizeof (Lisp_Object));
XSETVECTOR (record, new);
return record;
}
DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
See also the function `vector'. */)
@ -5532,7 +5620,7 @@ purecopy (Lisp_Object obj)
struct Lisp_Hash_Table *h = purecopy_hash_table (table);
XSET_HASH_TABLE (obj, h);
}
else if (COMPILEDP (obj) || VECTORP (obj))
else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj))
{
struct Lisp_Vector *objp = XVECTOR (obj);
ptrdiff_t nbytes = vector_nbytes (objp);
@ -7461,10 +7549,13 @@ The time is in seconds as a floating point value. */);
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
defsubr (&Srecord);
defsubr (&Scopy_record);
defsubr (&Sbool_vector);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
defsubr (&Smake_record);
defsubr (&Smake_string);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);

35
src/data.c
View File

@ -267,6 +267,15 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_MUTEX: return Qmutex;
case PVEC_CONDVAR: return Qcondition_variable;
case PVEC_TERMINAL: return Qterminal;
case PVEC_RECORD:
{
Lisp_Object t = AREF (object, 0);
if (RECORDP (t) && 1 < (ASIZE (t) & PSEUDOVECTOR_SIZE_MASK))
/* Return the type name field of the class! */
return AREF (t, 1);
else
return t;
}
/* "Impossible" cases. */
case PVEC_XWIDGET:
case PVEC_OTHER:
@ -359,6 +368,15 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
return Qnil;
}
DEFUN ("recordp", Frecordp_p, Srecordp, 1, 1, 0,
doc: /* Return t if OBJECT is a record. */)
(Lisp_Object object)
{
if (RECORDP (object))
return Qt;
return Qnil;
}
DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
doc: /* Return t if OBJECT is a string. */
attributes: const)
@ -2287,7 +2305,7 @@ or a byte-code object. IDX starts at 0. */)
ptrdiff_t size = 0;
if (VECTORP (array))
size = ASIZE (array);
else if (COMPILEDP (array))
else if (COMPILEDP (array) || RECORDP (array))
size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK;
else
wrong_type_argument (Qarrayp, array);
@ -2308,7 +2326,8 @@ bool-vector. IDX starts at 0. */)
CHECK_NUMBER (idx);
idxval = XINT (idx);
CHECK_ARRAY (array, Qarrayp);
if (! RECORDP (array))
CHECK_ARRAY (array, Qarrayp);
if (VECTORP (array))
{
@ -2328,7 +2347,14 @@ bool-vector. IDX starts at 0. */)
CHECK_CHARACTER (idx);
CHAR_TABLE_SET (array, idxval, newelt);
}
else
else if (RECORDP (array))
{
ptrdiff_t size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK;
if (idxval < 0 || idxval >= size)
args_out_of_range (array, idx);
ASET (array, idxval, newelt);
}
else /* STRINGP */
{
int c;
@ -3604,6 +3630,7 @@ syms_of_data (void)
DEFSYM (Qsequencep, "sequencep");
DEFSYM (Qbufferp, "bufferp");
DEFSYM (Qvectorp, "vectorp");
DEFSYM (Qrecordp, "recordp");
DEFSYM (Qbool_vector_p, "bool-vector-p");
DEFSYM (Qchar_or_string_p, "char-or-string-p");
DEFSYM (Qmarkerp, "markerp");
@ -3714,6 +3741,7 @@ syms_of_data (void)
DEFSYM (Qbuffer, "buffer");
DEFSYM (Qframe, "frame");
DEFSYM (Qvector, "vector");
DEFSYM (Qrecord, "record");
DEFSYM (Qchar_table, "char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
@ -3750,6 +3778,7 @@ syms_of_data (void)
defsubr (&Sstringp);
defsubr (&Smultibyte_string_p);
defsubr (&Svectorp);
defsubr (&Srecordp);
defsubr (&Schar_table_p);
defsubr (&Svector_or_char_table_p);
defsubr (&Sbool_vector_p);

2
src/fns.c
View File

@ -106,7 +106,7 @@ To get the number of bytes, use `string-bytes'. */)
XSETFASTINT (val, MAX_CHAR);
else if (BOOL_VECTOR_P (sequence))
XSETFASTINT (val, bool_vector_size (sequence));
else if (COMPILEDP (sequence))
else if (COMPILEDP (sequence) || RECORDP (sequence))
XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
else if (CONSP (sequence))
{

14
src/lisp.h
View File

@ -889,6 +889,7 @@ enum pvec_type
PVEC_COMPILED,
PVEC_CHAR_TABLE,
PVEC_SUB_CHAR_TABLE,
PVEC_RECORD,
PVEC_FONT /* Should be last because it's used for range checking. */
};
@ -1412,6 +1413,7 @@ CHECK_VECTOR (Lisp_Object x)
CHECK_TYPE (VECTORP (x), Qvectorp, x);
}
/* A pseudovector is like a vector, but has other non-Lisp components. */
INLINE enum pvec_type
@ -2732,6 +2734,18 @@ FRAMEP (Lisp_Object a)
return PSEUDOVECTORP (a, PVEC_FRAME);
}
INLINE bool
RECORDP (Lisp_Object a)
{
return PSEUDOVECTORP (a, PVEC_RECORD);
}
INLINE void
CHECK_RECORD (Lisp_Object x)
{
CHECK_TYPE (RECORDP (x), Qrecordp, x);
}
/* Test for image (image . spec) */
INLINE bool
IMAGEP (Lisp_Object x)

14
src/lread.c
View File

@ -2603,8 +2603,18 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
int param_count = 0;
if (!EQ (head, Qhash_table))
error ("Invalid extended read marker at head of #s list "
"(only hash-table allowed)");
{
ptrdiff_t size = XINT (Flength (tmp));
Lisp_Object record = Fmake_record (CAR_SAFE (tmp),
make_number (size - 1),
Qnil);
for (int i = 1; i < size; i++)
{
tmp = Fcdr (tmp);
ASET (record, i, Fcar (tmp));
}
return record;
}
tmp = CDR_SAFE (tmp);

27
src/print.c
View File

@ -1135,7 +1135,8 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|| (VECTORLIKEP (obj) \
&& (VECTORP (obj) || COMPILEDP (obj) \
|| CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
|| HASH_TABLE_P (obj) || FONTP (obj))) \
|| HASH_TABLE_P (obj) || FONTP (obj) \
|| RECORDP (obj))) \
|| (! NILP (Vprint_gensym) \
&& SYMBOLP (obj) \
&& !SYMBOL_INTERNED_P (obj)))
@ -1963,6 +1964,30 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
}
break;
case PVEC_RECORD:
{
ptrdiff_t n, size = ASIZE (obj) & PSEUDOVECTOR_SIZE_MASK;
int i;
/* Don't print more elements than the specified maximum. */
if (NATNUMP (Vprint_length)
&& XFASTINT (Vprint_length) < size)
n = XFASTINT (Vprint_length);
else
n = size;
print_c_string ("#s(", printcharfun);
for (i = 0; i < n; i ++)
{
if (i) printchar (' ', printcharfun);
print_object (AREF (obj, i), printcharfun, escapeflag);
}
if (n < size)
print_c_string (" ...", printcharfun);
printchar (')', printcharfun);
}
break;
case PVEC_SUB_CHAR_TABLE:
case PVEC_COMPILED:
case PVEC_CHAR_TABLE:

10
test/lisp/emacs-lisp/cl-print-tests.el
View File

@ -37,4 +37,14 @@
(should (string-match "\\`#f(compiled-function (x) .*\n\n.*)\\'"
(cl-prin1-to-string (symbol-function #'caar))))))
(ert-deftest cl-print-tests-2 ()
(let ((x (record 'foo 1 2 3)))
(should (equal
x
(car (read-from-string (with-output-to-string (prin1 x))))))
(let ((print-circle t))
(should (string-match
"\\`(#1=#s(foo 1 2 3) #1#)\\'"
(cl-prin1-to-string (list x x)))))))
;;; cl-print-tests.el ends here.

20
test/src/alloc-tests.el
View File

@ -31,3 +31,23 @@
(ert-deftest finalizer-object-type ()
(should (equal (type-of (make-finalizer nil)) 'finalizer)))
(ert-deftest record-1 ()
(let ((x (record 'foo 1 2 3)))
(should (recordp x))
(should (eq (type-of x) 'foo))
(should (eq (aref x 0) 'foo))
(should (eql (aref x 3) 3))
(should (eql (length x) 4))))
(ert-deftest record-2 ()
(let ((x (make-record 'bar 1 0)))
(should (eql (length x) 2))
(should (eql (aref x 1) 0))))
(ert-deftest record-3 ()
(let* ((x (record 'foo 1 2 3))
(y (copy-record x)))
(should-not (eq x y))
(dotimes (i 4)
(should (eql (aref x i) (aref y i))))))