GNU bug report logs - #16520
24.3.50; cl-defstruct with :predicate option

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 16520 in the body.
You can then email your comments to 16520 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Helmut Eller <eller.helmut <at> gmail.com>
To: bug-gnu-emacs <at> gnu.org
Subject: 24.3.50; cl-defstruct with :predicate option
Date: Wed, 22 Jan 2014 11:06:34 +0100

Compiling this code:

  (require 'cl-lib)
  (cl-defstruct (foo (:predicate foop)))
  (defun bar (x) (cl-check-type x foo))

with with:  emacs -Q -batch -f batch-byte-compile foo.el
produces this warning:

  foo.el:8:1:Warning: the function `foo-p' is not known to be defined.

and since foo-p is not defined will also lead errors at run-time when
bar is called.

Adding eval-and-compile to the structure definition avoids the problem
but it's a bug that the compiler emits a call to foo-p at all.


In GNU Emacs 24.3.50.2 (i686-pc-linux-gnu, GTK+ Version 2.24.10)
 of 2014-01-20 on ix

Message #8 received at 16520 <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Helmut Eller <eller.helmut <at> gmail.com>
Cc: 16520 <at> debbugs.gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Wed, 22 Jan 2014 08:47:16 -0500

> Compiling this code:
>   (require 'cl-lib)
>   (cl-defstruct (foo (:predicate foop)))
>   (defun bar (x) (cl-check-type x foo))

> with with:  emacs -Q -batch -f batch-byte-compile foo.el
> produces this warning:

>   foo.el:8:1:Warning: the function `foo-p' is not known to be defined.

Hmm... indeed, that's bad.


        Stefan

Message #13 received at 16520-done <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Helmut Eller <eller.helmut <at> gmail.com>
Cc: 16520-done <at> debbugs.gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Thu, 23 Jan 2014 10:02:02 -0500

Version: 24.4

>   (cl-defstruct (foo (:predicate foop)))
>   (defun bar (x) (cl-check-type x foo))
[...]
>   foo.el:8:1:Warning: the function `foo-p' is not known to be defined.

Thanks, should be fixed now (more or less: it's an ugly hack).


        Stefan

Message #16 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Helmut Eller <eller.helmut <at> gmail.com>
To: bug-gnu-emacs <at> gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Wed, 29 Jan 2014 11:00:40 +0100

On Thu, Jan 23 2014, Stefan Monnier wrote:

> Version: 24.4
>
>>   (cl-defstruct (foo (:predicate foop)))
>>   (defun bar (x) (cl-check-type x foo))
> [...]
>>   foo.el:8:1:Warning: the function `foo-p' is not known to be defined.
>
> Thanks, should be fixed now (more or less: it's an ugly hack).

The fix doesn't work for this example:

 (require 'cl-lib)
 (cl-defstruct (foo (:predicate foo?)))
 (defun bar (x) (cl-check-type x foo))

neither for

  (cl-defstruct (foo (:predicate nil)))

Helmut

Message #19 received at 16520 <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Helmut Eller <eller.helmut <at> gmail.com>
Cc: 16520 <at> debbugs.gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Wed, 29 Jan 2014 08:59:52 -0500

> The fix doesn't work for this example:

>  (require 'cl-lib)
>  (cl-defstruct (foo (:predicate foo?)))
>  (defun bar (x) (cl-check-type x foo))

Indeed.  But it should work for:

   (require 'cl-lib)
   (cl-defstruct (foo (:predicate foo?)))
   (defun bar (x) (cl-check-type x foo?))

> neither for
>   (cl-defstruct (foo (:predicate nil)))

Not sure if it should work in that case,


        Stefan

Message #22 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Helmut Eller <eller.helmut <at> gmail.com>
To: bug-gnu-emacs <at> gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Wed, 29 Jan 2014 18:47:05 +0100

On Wed, Jan 29 2014, Stefan Monnier wrote:

>> The fix doesn't work for this example:
>
>>  (require 'cl-lib)
>>  (cl-defstruct (foo (:predicate foo?)))
>>  (defun bar (x) (cl-check-type x foo))
>
> Indeed.  But it should work for:
>
>    (require 'cl-lib)
>    (cl-defstruct (foo (:predicate foo?)))
>    (defun bar (x) (cl-check-type x foo?))

Which is arguably a bug.  If the goal is to imitate Common Lisp
semantics then the type name is foo not foo?.  If I wanted to call a
predicate I would have written (check-type x (satisfies foo?)).

>> neither for
>>   (cl-defstruct (foo (:predicate nil)))
>
> Not sure if it should work in that case,

It does work in Common Lisp.

Helmut

Message #25 received at 16520 <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Helmut Eller <eller.helmut <at> gmail.com>
Cc: 16520 <at> debbugs.gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Wed, 29 Jan 2014 22:58:44 -0500

>>> 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 ;-)


        Stefan

Message #28 received at 16520 <at> debbugs.gnu.org (full text, mbox):

From: Helmut Eller <eller.helmut <at> gmail.com>
To: Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: 16520 <at> debbugs.gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Thu, 30 Jan 2014 13:07:19 +0100

[Message part 1 (text/plain, inline)]

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:

[defstruct.patch (text/x-diff, inline)]

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

Message #31 received at 16520 <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Helmut Eller <eller.helmut <at> gmail.com>
Cc: 16520 <at> debbugs.gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Thu, 30 Jan 2014 09:43:50 -0500

> 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?


        Stefan

Message #34 received at 16520 <at> debbugs.gnu.org (full text, mbox):

From: Helmut Eller <eller.helmut <at> gmail.com>
To: Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: 16520 <at> debbugs.gnu.org
Subject: Re: bug#16520: 24.3.50; cl-defstruct with :predicate option
Date: Thu, 30 Jan 2014 23:33:07 +0100

[Message part 1 (text/plain, inline)]

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:

[defstruct.patch (text/x-diff, inline)]

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

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.