* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Define an internal predicate

even if :predicate was nil, for the benefit of typep.
Record the name of the predicate for typep's use.
(cl--make-type-test): Use pcase.  Obey new cl-deftype-satisfies property.

1 files changed, 54 insertions, 48 deletions

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 8336a2443da..e76c0a411b7 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2487,6 +2487,8 @@ non-nil value, that slot cannot be set via `setf'.
 	(setq type 'vector named 'true)))
     (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
     (push `(defvar ,tag-symbol) forms)
+    (when (and (null predicate) named)
+      (setq predicate (intern (format "cl--struct-%s-p" name))))
     (setq pred-form (and named
 			 (let ((pos (- (length descs)
 				       (length (memq (assq 'cl-tag-slot descs)
@@ -2502,7 +2504,8 @@ non-nil value, that slot cannot be set via `setf'.
 	  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)))
+			      (cons 'and (cl-cdddr pred-form))
+                            `(,predicate cl-x))))
     (let ((pos 0) (descp descs))
       (while descp
 	(let* ((desc (pop descp))
@@ -2557,13 +2560,14 @@ non-nil value, that slot cannot be set via `setf'.
 	(setq pos (1+ pos))))
     (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)
-		(push (cons predicate 'error-free) side-eff)))
+    (when pred-form
+      (push `(cl-defsubst ,predicate (cl-x)
+               ,(if (eq (car pred-form) 'and)
+                    (append pred-form '(t))
+                  `(and ,pred-form t)))
+            forms)
+      (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)
+      (push (cons predicate 'error-free) side-eff))
     (and copier
 	 (progn (push `(defun ,copier (x) (copy-sequence x)) forms)
 		(push (cons copier t) side-eff)))
@@ -2647,46 +2651,48 @@ Of course, we really can't know that for sure, so it's just a heuristic."
                (cdr (assq sym byte-compile-macro-environment))))))
 
 (defun cl--make-type-test (val type)
-  (if (symbolp type)
-      (cond ((get type 'cl-deftype-handler)
-	     (cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
-	    ((memq type '(nil t)) type)
-	    ((eq type 'null) `(null ,val))
-	    ((eq type 'atom) `(atom ,val))
-	    ((eq type 'float) `(floatp ,val))
-	    ((eq type 'real) `(numberp ,val))
-	    ((eq type 'fixnum) `(integerp ,val))
-	    ;; FIXME: Should `character' accept things like ?\C-\M-a ?  --Stef
-	    ((memq type '(character string-char)) `(characterp ,val))
-	    (t
-	     (let* ((name (symbol-name type))
-		    (namep (intern (concat name "p"))))
-	       (cond
-                ((cl--macroexp-fboundp namep) (list namep val))
-                ((cl--macroexp-fboundp
-                  (setq namep (intern (concat name "-p"))))
-                 (list namep val))
-                (t (list type val))))))
-    (cond ((get (car type) 'cl-deftype-handler)
-	   (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler)
-					 (cdr type))))
-	  ((memq (car type) '(integer float real number))
-	   (delq t `(and ,(cl--make-type-test val (car type))
-			 ,(if (memq (cadr type) '(* nil)) t
-                            (if (consp (cadr type)) `(> ,val ,(cl-caadr type))
-                              `(>= ,val ,(cadr type))))
-			 ,(if (memq (cl-caddr type) '(* nil)) t
-                            (if (consp (cl-caddr type))
-                                `(< ,val ,(cl-caaddr type))
-                              `(<= ,val ,(cl-caddr type)))))))
-	  ((memq (car type) '(and or not))
-	   (cons (car type)
-		 (mapcar (function (lambda (x) (cl--make-type-test val x)))
-			 (cdr type))))
-	  ((memq (car type) '(member cl-member))
-	   `(and (cl-member ,val ',(cdr type)) t))
-	  ((eq (car type) 'satisfies) `(funcall #',(cadr type) ,val))
-	  (t (error "Bad type spec: %s" type)))))
+  (pcase type
+    ((and `(,name . ,args) (guard (get name 'cl-deftype-handler)))
+     (cl--make-type-test val (apply (get name 'cl-deftype-handler)
+                                    args)))
+    (`(,(and name (or 'integer 'float 'real 'number))
+       . ,(or `(,min ,max) pcase--dontcare))
+     `(and ,(cl--make-type-test val name)
+           ,(if (memq min '(* nil)) t
+              (if (consp min) `(> ,val ,(car min))
+                `(>= ,val ,min)))
+           ,(if (memq max '(* nil)) t
+              (if (consp max)
+                  `(< ,val ,(car max))
+                `(<= ,val ,max)))))
+    (`(,(and name (or 'and 'or 'not)) . ,args)
+     (cons name (mapcar (lambda (x) (cl--make-type-test val x)) args)))
+    (`(member . ,args)
+     `(and (cl-member ,val ',args) t))
+    (`(satisfies ,pred) `(funcall #',pred ,val))
+    ((and (pred symbolp) (guard (get type 'cl-deftype-handler)))
+     (cl--make-type-test val (funcall (get type 'cl-deftype-handler))))
+    ((and (pred symbolp) (guard (get type 'cl-deftype-satisfies)))
+     `(funcall #',(get type 'cl-deftype-satisfies) ,val))
+    ((or 'nil 't) type)
+    ('null `(null ,val))
+    ('atom `(atom ,val))
+    ('float `(floatp ,val))
+    ('real `(numberp ,val))
+    ('fixnum `(integerp ,val))
+    ;; FIXME: Implement `base-char' and `extended-char'.
+    ('character `(characterp ,val))
+    ((pred symbolp)
+     (let* ((name (symbol-name type))
+            (namep (intern (concat name "p"))))
+       (cond
+        ((cl--macroexp-fboundp namep) (list namep val))
+        ((cl--macroexp-fboundp
+          (setq namep (intern (concat name "-p"))))
+         (list namep val))
+        ((cl--macroexp-fboundp type) (list type val))
+        (t (error "Unknown type %S" type)))))
+    (_ (error "Bad type spec: %s" type))))
 
 (defvar cl--object)
 ;;;###autoload