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: User-defined record types Date: Tue, 14 Mar 2017 10:52:51 +0100 Organization: nocrew Message-ID: <867f3s2nik.fsf_-_@molnjunk.nocrew.org> References: <87pokampa4.fsf@ericabrahamsen.net> <8760m2mmlq.fsf@ericabrahamsen.net> <87lguq5r87.fsf@ericabrahamsen.net> <878tp0i74g.fsf@users.sourceforge.net> <87efyg6y0i.fsf_-_@drachen> <87zigwz9wx.fsf@tromey.com> <86bmtbd45s.fsf@molnjunk.nocrew.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1489485232 19102 195.159.176.226 (14 Mar 2017 09:53:52 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Tue, 14 Mar 2017 09:53:52 +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 Tue Mar 14 10:53:46 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 1cnj99-0003Zo-Jv for ged-emacs-devel@m.gmane.org; Tue, 14 Mar 2017 10:53:39 +0100 Original-Received: from localhost ([::1]:57409 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cnj9F-0000gk-GX for ged-emacs-devel@m.gmane.org; Tue, 14 Mar 2017 05:53:45 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:40341) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cnj8h-0000gZ-ET for emacs-devel@gnu.org; Tue, 14 Mar 2017 05:53:13 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cnj8e-0007FC-7p for emacs-devel@gnu.org; Tue, 14 Mar 2017 05:53:11 -0400 Original-Received: from [195.159.176.226] (port=40287 helo=blaine.gmane.org) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cnj8d-0007EE-TK for emacs-devel@gnu.org; Tue, 14 Mar 2017 05:53:08 -0400 Original-Received: from list by blaine.gmane.org with local (Exim 4.84_2) (envelope-from ) id 1cnj8U-0007yo-OE for emacs-devel@gnu.org; Tue, 14 Mar 2017 10:52:58 +0100 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 254 Original-X-Complaints-To: usenet@blaine.gmane.org Cancel-Lock: sha1:Vo0UVVMRIZGMuro4T54kiJEJ4RQ= 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:213011 Archived-At: Stefan Monnier wrote: >> Tom Tromey wrote: >>> It's kind of hacky though. I think it's probably better to just add >>> funcallable instances directly, and real types of some kind at the >>> same time. >> I tried to submit a patch for user-defined record types some years >> ago. Instances were pseudovectors, with the first element being a >> symbol naming its type. > Yes, I think we're pretty much ready to accept such a patch This is my old patch dusted off and rebased to current master. It's just a raw material posted for review. A test case would be: (let ((x (make-record 'foo 3 nil))) (aset x 1 1) (aset x 2 2) (aset x 3 3) (list (read-from-string (with-output-to-string (prin1 x))) (recordp x) (type-of x) (aref x 0) (aref x 3) (length x))) This evalates to ((#%[foo 1 2 3] . 13) t foo foo 3 4). diff --git a/src/alloc.c b/src/alloc.c index ae3e151..de08276 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3392,6 +3392,46 @@ struct buffer * return b; } +static void +check_record_type (Lisp_Object type) +{ + if (!SYMBOLP(type)) + error ("Invalid type; must be symbol"); +} + +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 vector; + ptrdiff_t size, i; + struct Lisp_Vector *p; + + CHECK_NATNUM (slots); + check_record_type (type); + + size = XFASTINT (slots) + 1; + p = allocate_record (size); + p->contents[0] = type; + for (i = 1; i < size; i++) + p->contents[i] = init; + + XSETVECTOR (vector, p); + return vector; +} + + 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'. */) @@ -7465,6 +7505,7 @@ This means that certain objects should be allocated in shared (pure) space. 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..eceb752 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,14 @@ 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); + ASET (array, idxval, newelt); + } + else /* STRINGP */ { int c; @@ -3714,6 +3732,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 +3769,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..fb5fed1 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, @@ -2728,6 +2729,12 @@ enum char_bits return PSEUDOVECTORP (a, PVEC_FRAME); } +INLINE bool +RECORDP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_RECORD); +} + /* 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,