procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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.
This commit is contained in:
Stefan Monnier 2014-10-23 17:44:36 -04:00
parent e77628bd58
commit 864d69a119
2 changed files with 60 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

6
lisp/ChangeLog
View file

@ -1,5 +1,11 @@
2014-10-23 Stefan Monnier <monnier@iro.umontreal.ca>
* 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.

102
lisp/emacs-lisp/cl-macs.el
View file

@ -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