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

[Helmut Eller <eller.helmut@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 270 bytes --]

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:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: defstruct.patch --]
[-- Type: text/x-diff, Size: 5040 bytes --]

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