From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Helmut Eller Newsgroups: gmane.emacs.bugs Subject: bug#16520: 24.3.50; cl-defstruct with :predicate option Date: Thu, 30 Jan 2014 23:33:07 +0100 Message-ID: References: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1391121262 24642 80.91.229.3 (30 Jan 2014 22:34:22 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 30 Jan 2014 22:34:22 +0000 (UTC) Cc: 16520@debbugs.gnu.org To: Stefan Monnier Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Thu Jan 30 23:34:25 2014 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1W90Bk-0004dz-Sp for geb-bug-gnu-emacs@m.gmane.org; Thu, 30 Jan 2014 23:34:25 +0100 Original-Received: from localhost ([::1]:52431 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1W90Bk-0006ij-AG for geb-bug-gnu-emacs@m.gmane.org; Thu, 30 Jan 2014 17:34:24 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:44469) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1W90Ba-0006iQ-8d for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 17:34:21 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1W90BP-0003t0-33 for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 17:34:14 -0500 Original-Received: from debbugs.gnu.org ([140.186.70.43]:56038) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1W90BO-0003sw-V4 for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 17:34:03 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.80) (envelope-from ) id 1W90BO-0000sO-0s for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 17:34:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Helmut Eller Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Thu, 30 Jan 2014 22:34:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 16520 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: Original-Received: via spool by 16520-submit@debbugs.gnu.org id=B16520.13911211943303 (code B ref 16520); Thu, 30 Jan 2014 22:34:01 +0000 Original-Received: (at 16520) by debbugs.gnu.org; 30 Jan 2014 22:33:14 +0000 Original-Received: from localhost ([127.0.0.1]:41824 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1W90Ab-0000rC-Ff for submit@debbugs.gnu.org; Thu, 30 Jan 2014 17:33:14 -0500 Original-Received: from mail-ea0-f178.google.com ([209.85.215.178]:47242) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1W90AY-0000r3-E0 for 16520@debbugs.gnu.org; Thu, 30 Jan 2014 17:33:11 -0500 Original-Received: by mail-ea0-f178.google.com with SMTP id a15so1941342eae.23 for <16520@debbugs.gnu.org>; Thu, 30 Jan 2014 14:33:09 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version:content-type; bh=IhWa3GuGAqbtQ4PDUt3rEUTwjT3GUeNjpKNOAvPJ07c=; b=KdqIOxLTBqEkjh9LIdaIvEh11nHVz6kbc0SPxUgh/koXS7GSNy9Cwz89L/k2/ww1gp umBplV2S25FtLWIvR7mXySNankua4wM/foN9iDPudMp8PRbflDPJmdmZRnTQboiGgzbi gPd9o5L1HcutZSQpyn9pew6bOW4yScqNQUwOC9UgMc1w6cRYVFq3/2c6bp08g6MeTne4 hHFHy/xF6iPZZq4QjL5JRlG2Qwzwd6zly0ba5qAX01F/FXZDvnVgUcbPGp5JgOqGd2KV l3RaeOrzI7uqoNo+zjMX9ZjhvaUe252fVpVeDKGxPp/kCrg5vmEuGf91g3AFYDkuSVEX kp5Q== X-Received: by 10.14.210.130 with SMTP id u2mr253874eeo.108.1391121189605; Thu, 30 Jan 2014 14:33:09 -0800 (PST) Original-Received: from ix ([212.46.176.45]) by mx.google.com with ESMTPSA id 46sm28190973ees.4.2014.01.30.14.33.07 for (version=TLSv1.2 cipher=RC4-SHA bits=128/128); Thu, 30 Jan 2014 14:33:08 -0800 (PST) Original-Received: from helmut by ix with local (Exim 4.80) (envelope-from ) id 1W90AV-000240-Rm; Thu, 30 Jan 2014 23:33:08 +0100 In-Reply-To: (Stefan Monnier's message of "Thu, 30 Jan 2014 09:43:50 -0500") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3.50 (gnu/linux) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.15 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 140.186.70.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.bugs:84299 Archived-At: --=-=-= Content-Type: text/plain On Thu, Jan 30 2014, Stefan Monnier wrote: >> Maybe something like this: > > Thanks, looks reasonable. Could you try and share the > cl--make-struct-type-test code with the part that defines foo-p to avoid > the duplication? I tried but it doesn't look much better: --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=defstruct.patch diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 45448ec..12f8ab1 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2319,6 +2319,40 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first. ;;; Structures. +(defun cl--make-struct-type-test (val type slots tag-symbol) + (let ((pos (cl-loop for i from 0 for (s) in slots + when (eq s 'cl-tag-slot) return i))) + (cl-ecase type + (vector + `(and (vectorp ,val) + (>= (length ,val) ,(length slots)) + (memq (aref ,val ,pos) ,tag-symbol) + t)) + (list + (cond ((zerop pos) + `(and (memq (car-safe ,val) ,tag-symbol) + t)) + (t + `(and (consp ,val) + (memq (nth ,pos ,val) ,tag-symbol) + t))))))) + +(defun cl--make-struct-check-form (pred-form safety) + (cond ((= safety 0) nil) + (t (let* ((form (cond ((and (eq (car pred-form) 'and) + (eq (car (last pred-form)) 't)) + (butlast pred-form)) + (t pred-form))) + (form (cond ((and (eq (car form) 'and) + (= (length form) 2)) + (nth 1 form)) + (t form)))) + (cond ((and (= safety 1) + (eq (car form) 'and) + (eq (car (nth 1 form)) 'vectorp)) + (nth 3 form)) + (t form)))))) + ;;;###autoload (defmacro cl-defstruct (struct &rest descs) "Define a struct type. @@ -2461,21 +2495,10 @@ non-nil value, that slot cannot be set via `setf'. (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) (push `(defvar ,tag-symbol) forms) (setq pred-form (and named - (let ((pos (- (length descs) - (length (memq (assq 'cl-tag-slot descs) - descs))))) - (if (eq type 'vector) - `(and (vectorp cl-x) - (>= (length cl-x) ,(length descs)) - (memq (aref cl-x ,pos) ,tag-symbol)) - (if (= pos 0) - `(memq (car-safe cl-x) ,tag-symbol) - `(and (consp cl-x) - (memq (nth ,pos cl-x) ,tag-symbol)))))) - pred-check (and pred-form (> safety 0) - (if (and (eq (cl-caadr pred-form) 'vectorp) - (= safety 1)) - (cons 'and (cl-cdddr pred-form)) pred-form))) + (cl--make-struct-type-test 'cl-x type descs + tag-symbol)) + pred-check (and pred-form + (cl--make-struct-check-form pred-form safety))) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2530,10 +2553,7 @@ non-nil value, that slot cannot be set via `setf'. (setq slots (nreverse slots) defaults (nreverse defaults)) (and predicate pred-form - (progn (push `(cl-defsubst ,predicate (cl-x) - ,(if (eq (car pred-form) 'and) - (append pred-form '(t)) - `(and ,pred-form t))) forms) + (progn (push `(cl-defsubst ,predicate (cl-x) ,pred-form) forms) (push (cons predicate 'error-free) side-eff))) (and copier (progn (push `(defun ,copier (x) (copy-sequence x)) forms) @@ -2569,6 +2589,7 @@ non-nil value, that slot cannot be set via `setf'. (push `(cl-eval-when (compile load eval) (put ',name 'cl-struct-slots ',descs) (put ',name 'cl-struct-type ',(list type (eq named t))) + (put ',name 'cl-struct-tag-symbol ',tag-symbol) (put ',name 'cl-struct-include ',include) (put ',name 'cl-struct-print ,print-auto) ,@(mapcar (lambda (x) @@ -2611,6 +2632,12 @@ Of course, we really can't know that for sure, so it's just a heuristic." ((eq type 'fixnum) `(integerp ,val)) ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef ((memq type '(character string-char)) `(characterp ,val)) + ((and (get type 'cl-struct-type) + (assq 'cl-tag-slot (get type 'cl-struct-slots))) + (cl--make-struct-type-test val + (car (get type 'cl-struct-type)) + (get type 'cl-struct-slots) + (get type 'cl-struct-tag-symbol))) (t (let* ((name (symbol-name type)) (namep (intern (concat name "p")))) diff --git a/test/automated/cl-lib.el b/test/automated/cl-lib.el index 8b6ed6d..3689c9c 100644 --- a/test/automated/cl-lib.el +++ b/test/automated/cl-lib.el @@ -195,4 +195,17 @@ (should (eql (cl-mismatch "Aa" "aA") 0)) (should (eql (cl-mismatch '(a b c) '(a b d)) 2))) +(cl-defstruct cl-lib-test-struct-1) +(cl-defstruct (cl-lib-test-struct-2 (:predicate cl-lib-test-struct-2?))) +(cl-defstruct (cl-lib-test-struct-3 (:predicate nil))) +(cl-defstruct (cl-lib-test-struct-4 (:predicate nil) + (:include cl-lib-test-struct-3))) + +(ert-deftest cl-lib-test-typep () + (should (cl-typep (make-cl-lib-test-struct-1) 'cl-lib-test-struct-1)) + (should (not (cl-typep (make-cl-lib-test-struct-2) 'cl-lib-test-struct-1))) + (should (cl-typep (make-cl-lib-test-struct-2) 'cl-lib-test-struct-2)) + (should (cl-typep (make-cl-lib-test-struct-3) 'cl-lib-test-struct-3)) + (should (cl-typep (make-cl-lib-test-struct-4) 'cl-lib-test-struct-3))) + ;;; cl-lib.el ends here --=-=-=--