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

Previous Next

Full log

View this message in rfc822 format

From: Helmut Eller <eller.helmut <at> gmail.com>
To: Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: 16520 <at> debbugs.gnu.org
Subject: 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

Previous Next

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