[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] trunk r118187: * lisp/emacs-lisp/cl-macs.el (cl-defstruct)
From: |
Stefan Monnier |
Subject: |
[Emacs-diffs] trunk r118187: * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Define an internal predicate |
Date: |
Thu, 23 Oct 2014 21:44:39 +0000 |
User-agent: |
Bazaar (2.6b2) |
------------------------------------------------------------
revno: 118187
revision-id: address@hidden
parent: address@hidden
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Thu 2014-10-23 17:44:36 -0400
message:
* 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.
modified:
lisp/ChangeLog changelog-20091113204419-o5vbwnq5f7feedwu-1432
lisp/emacs-lisp/cl-macs.el clmacs.el-20091113204419-o5vbwnq5f7feedwu-612
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2014-10-23 21:38:56 +0000
+++ b/lisp/ChangeLog 2014-10-23 21:44:36 +0000
@@ -1,5 +1,11 @@
2014-10-23 Stefan Monnier <address@hidden>
+ * 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.
=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el 2014-10-17 05:09:24 +0000
+++ b/lisp/emacs-lisp/cl-macs.el 2014-10-23 21:44:36 +0000
@@ -2487,6 +2487,8 @@
(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 @@
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 @@
(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 @@
(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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] trunk r118187: * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Define an internal predicate,
Stefan Monnier <=