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 13:07:19 +0100 Message-ID: References: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1391083700 24419 80.91.229.3 (30 Jan 2014 12:08:20 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 30 Jan 2014 12:08:20 +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 13:08:27 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 1W8qPy-0001Zv-Ti for geb-bug-gnu-emacs@m.gmane.org; Thu, 30 Jan 2014 13:08:27 +0100 Original-Received: from localhost ([::1]:48123 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1W8qPy-0005C8-CC for geb-bug-gnu-emacs@m.gmane.org; Thu, 30 Jan 2014 07:08:26 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:43613) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1W8qPl-000534-Uw for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 07:08:21 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1W8qPa-0007rc-7O for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 07:08:13 -0500 Original-Received: from debbugs.gnu.org ([140.186.70.43]:55193) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1W8qPa-0007rY-22 for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 07:08:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.80) (envelope-from ) id 1W8qPZ-0006GB-Js for bug-gnu-emacs@gnu.org; Thu, 30 Jan 2014 07:08:01 -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 12:08: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.139108365024015 (code B ref 16520); Thu, 30 Jan 2014 12:08:01 +0000 Original-Received: (at 16520) by debbugs.gnu.org; 30 Jan 2014 12:07:30 +0000 Original-Received: from localhost ([127.0.0.1]:40979 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1W8qP3-0006FG-Jy for submit@debbugs.gnu.org; Thu, 30 Jan 2014 07:07:30 -0500 Original-Received: from mail-ea0-f173.google.com ([209.85.215.173]:52219) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1W8qP1-0006F8-Jr for 16520@debbugs.gnu.org; Thu, 30 Jan 2014 07:07:28 -0500 Original-Received: by mail-ea0-f173.google.com with SMTP id d10so1595423eaj.4 for <16520@debbugs.gnu.org>; Thu, 30 Jan 2014 04:07:26 -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=KhnZw+89JUNty3thu7KMPVG1D/8G1TKwdqb3yyCRqxg=; b=Kb0UgbV6jBXWk5PkEqMW1yoHrsUQ7mHtoC+lS0CrAjLXhU5yxspvjRRs9z5lzZEVzP wHU4pqIT6cGNqLbEEJBdv8FgkoP7bmmf8Cps7CFe08O/oo0mjU1YSW1silrV0tct7NSE JCz91nu6Wv3eEFQjQFOFsUzxd2oarTRa7iKcdXM8Q6KbMryvqEqgWuo9RhUI73FN2VYm v0jwZ1oQ+vJdDSoY7Did5hNDfXxMkuxgXeAtRbc6MpPxSHVdLnZFy/eaR3FCiTZZx+4g yt8RtqbWIQUJXUB1jWql6P9JS10g+PPiPmt12uo4WWtunicy7uOzutXJKLYarSS9Lg2/ rhdg== X-Received: by 10.15.107.205 with SMTP id cb53mr89933eeb.107.1391083646712; Thu, 30 Jan 2014 04:07:26 -0800 (PST) Original-Received: from ix ([212.46.176.45]) by mx.google.com with ESMTPSA id 8sm21610535eeq.15.2014.01.30.04.07.23 for (version=TLSv1.2 cipher=RC4-SHA bits=128/128); Thu, 30 Jan 2014 04:07:24 -0800 (PST) Original-Received: from helmut by ix with local (Exim 4.80) (envelope-from ) id 1W8qOu-0001Vp-0M; Thu, 30 Jan 2014 13:07:20 +0100 In-Reply-To: (Stefan Monnier's message of "Wed, 29 Jan 2014 22:58:44 -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:84253 Archived-At: --=-=-= Content-Type: text/plain On Thu, Jan 30 2014, Stefan Monnier wrote: >>>> neither for >>>> (cl-defstruct (foo (:predicate nil))) >>> Not sure if it should work in that case, >> It does work in Common Lisp. > > Then.. patch welcome ;-) Maybe something like this: --=-=-= 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..d8e62c3 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2569,6 +2569,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) @@ -2599,6 +2600,26 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym byte-compile-macro-environment)))))) +(defun cl--make-struct-type-test (val type) + (let* ((stype (get type 'cl-struct-type)) + (slots (get type 'cl-struct-slots)) + (tag-symbol (get type 'cl-struct-tag-symbol)) + (pos (cl-loop for i from 0 for s in slots + when (eq (car s) 'cl-tag-slot) return i))) + (or pos (error "Not a named struct: %s" type)) + (cl-ecase (car stype) + (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-type-test (val type) (if (symbolp type) (cond ((get type 'cl-deftype-handler) @@ -2611,6 +2632,9 @@ 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 type)) (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 --=-=-=--