From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Lars Brinkhoff Newsgroups: gmane.emacs.devel Subject: Re: User-defined record types, v2 Date: Sat, 18 Mar 2017 18:05:50 +0100 Organization: nocrew Message-ID: <86tw6qtt01.fsf@molnjunk.nocrew.org> References: <86y3w2tt2n.fsf@molnjunk.nocrew.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1489857077 32303 195.159.176.226 (18 Mar 2017 17:11:17 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sat, 18 Mar 2017 17:11:17 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Sat Mar 18 18:11:10 2017 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cpHsc-0006Xh-4A for ged-emacs-devel@m.gmane.org; Sat, 18 Mar 2017 18:11:02 +0100 Original-Received: from localhost ([::1]:54112 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cpHsg-0006B0-71 for ged-emacs-devel@m.gmane.org; Sat, 18 Mar 2017 13:11:06 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:54811) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cpHs2-0006Ap-F2 for emacs-devel@gnu.org; Sat, 18 Mar 2017 13:10:28 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cpHrx-0007m0-EW for emacs-devel@gnu.org; Sat, 18 Mar 2017 13:10:26 -0400 Original-Received: from [195.159.176.226] (port=42757 helo=blaine.gmane.org) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cpHrx-0007lq-34 for emacs-devel@gnu.org; Sat, 18 Mar 2017 13:10:21 -0400 Original-Received: from list by blaine.gmane.org with local (Exim 4.84_2) (envelope-from ) id 1cpHrh-0001Je-5R for emacs-devel@gnu.org; Sat, 18 Mar 2017 18:10:05 +0100 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 320 Original-X-Complaints-To: usenet@blaine.gmane.org Cancel-Lock: sha1:UF5cjehrG/Hmc1mMDFXqGFNemcs= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-Received-From: 195.159.176.226 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:213132 Archived-At: Add record objects with user-defined types. * 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. (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_object): Add syntax for records. diff --git a/src/alloc.c b/src/alloc.c index ae3e151..14a179f 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3392,6 +3392,75 @@ struct buffer * return b; } + +static struct Lisp_Vector * +allocate_record (int count) +{ + if (count >= (1 << PSEUDOVECTOR_SIZE_BITS)) + error ("Record too large"); + + 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 of type TYPE with SLOTS elements, each initialized to INIT. */) + (Lisp_Object type, Lisp_Object slots, Lisp_Object init) +{ + Lisp_Object record; + ptrdiff_t size, i; + struct Lisp_Vector *p; + + CHECK_RECORD_TYPE (type); + CHECK_NATNUM (slots); + + size = XFASTINT (slots) + 1; + p = allocate_record (size); + 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: /* Return a newly created record of type TYPE the rest of the arguments as slots. +Any number of slots, even zero slots, are allowed. +usage: (record TYPE &rest SLOTS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + struct Lisp_Vector *p = allocate_record (nargs); + Lisp_Object type = args[0]; + Lisp_Object record; + + CHECK_RECORD_TYPE (type); + 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: /* Shallow copy of a 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); + 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 +5601,7 @@ struct marker_block 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 +7530,13 @@ This means that certain objects should be allocated in shared (pure) space. 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); diff --git a/src/data.c b/src/data.c index ae8dd97..8e0bccc 100644 --- a/src/data.c +++ b/src/data.c @@ -267,6 +267,7 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol *, case PVEC_MUTEX: return Qmutex; case PVEC_CONDVAR: return Qcondition_variable; case PVEC_TERMINAL: return Qterminal; + case PVEC_RECORD: return AREF (object, 0); /* "Impossible" cases. */ case PVEC_XWIDGET: case PVEC_OTHER: @@ -359,6 +360,15 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol *, 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 +2297,7 @@ If the current binding is global (the default), the value is nil. */) 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 +2318,8 @@ If the current binding is global (the default), the value is nil. */) CHECK_NUMBER (idx); idxval = XINT (idx); - CHECK_ARRAY (array, Qarrayp); + if (! RECORDP (array)) + CHECK_ARRAY (array, Qarrayp); if (VECTORP (array)) { @@ -2328,7 +2339,16 @@ If the current binding is global (the default), the value is nil. */) 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); + if (idxval == 0) + CHECK_RECORD_TYPE (newelt); + ASET (array, idxval, newelt); + } + else /* STRINGP */ { int c; @@ -3604,6 +3624,7 @@ enum bool_vector_op { bool_vector_exclusive_or, 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 +3735,7 @@ enum bool_vector_op { bool_vector_exclusive_or, 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 +3772,7 @@ enum bool_vector_op { bool_vector_exclusive_or, defsubr (&Sstringp); defsubr (&Smultibyte_string_p); defsubr (&Svectorp); + defsubr (&Srecordp); defsubr (&Schar_table_p); defsubr (&Svector_or_char_table_p); defsubr (&Sbool_vector_p); diff --git a/src/fns.c b/src/fns.c index 1065355..36bde20 100644 --- a/src/fns.c +++ b/src/fns.c @@ -104,7 +104,7 @@ static void sort_vector_copy (Lisp_Object, ptrdiff_t, 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)) { diff --git a/src/lisp.h b/src/lisp.h index ab4db4c..d3793ac 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -874,6 +874,7 @@ enum pvec_type PVEC_TERMINAL, PVEC_WINDOW_CONFIGURATION, PVEC_SUBR, + PVEC_RECORD, PVEC_OTHER, /* Should never be visible to Elisp code. */ PVEC_XWIDGET, PVEC_XWIDGET_VIEW, @@ -1408,6 +1409,7 @@ struct Lisp_Vector CHECK_TYPE (VECTORP (x), Qvectorp, x); } + /* A pseudovector is like a vector, but has other non-Lisp components. */ INLINE enum pvec_type @@ -2728,6 +2730,24 @@ enum char_bits 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); +} + +INLINE void +CHECK_RECORD_TYPE (Lisp_Object x) +{ + /* CHECK_SYMBOL (x); */ +} + /* Test for image (image . spec) */ INLINE bool IMAGEP (Lisp_Object x) diff --git a/src/lread.c b/src/lread.c index 5c6a7f9..1fcbc37 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2762,6 +2762,19 @@ BUFFER is the buffer to evaluate (nil means use current buffer), make_byte_code (vec); return tmp; } + if (c == '%') + { + c = READCHAR; + if (c == '[') + { + Lisp_Object tmp; + tmp = read_vector (readcharfun, 1); + XSETPVECTYPE (XVECTOR(tmp), PVEC_RECORD); + return tmp; + } + UNREAD (c); + invalid_syntax ("#"); + } if (c == '(') { Lisp_Object tmp; diff --git a/src/print.c b/src/print.c index e857761..f7ecd3c 100644 --- a/src/print.c +++ b/src/print.c @@ -1966,6 +1966,7 @@ case PVEC_SUB_CHAR_TABLE: case PVEC_COMPILED: case PVEC_CHAR_TABLE: + case PVEC_RECORD: case PVEC_NORMAL_VECTOR: ; { ptrdiff_t size = ASIZE (obj); @@ -1974,6 +1975,12 @@ printchar ('#', printcharfun); size &= PSEUDOVECTOR_SIZE_MASK; } + if (RECORDP (obj)) + { + printchar ('#', printcharfun); + printchar ('%', printcharfun); + size &= PSEUDOVECTOR_SIZE_MASK; + } if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)) { /* We print a char-table as if it were a vector,