From: Stefan Monnier Date: Thu, 23 Oct 2014 21:44:36 +0000 (-0400) Subject: * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Define an internal predicate X-Git-Tag: emacs-25.0.90~2635^2~666 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=864d69a119e50eaabb80076bf13e3a5b0c8815cd;p=emacs.git * 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. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7c5b1ac06a0..ac556a3a0c8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,11 @@ 2014-10-23 Stefan Monnier + * 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. + * epg.el: Use cl-defstruct. (epg-make-data-from-file, epg-make-data-from-string, epg-data-file) (epg-data-string): Define via cl-defstruct. 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