2:39 p.m.
This is necessary (but not sufficient) for various of Paul Dietz’ tests to
work.
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1290004203 0
# Node ID 09fed7053634cd8ab9c1a79add8533ac93d8023d
# Parent 6784adb405ad56d87bd69e31c3e5a15c1977d813
Handle slightly more complex type specifications, #'coerce, #'typep.
2010-11-17 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
diff -r 6784adb405ad -r 09fed7053634 lisp/ChangeLog
--- a/lisp/ChangeLog Mon Nov 15 19:31:06 2010 +0000
+++ b/lisp/ChangeLog Wed Nov 17 14:30:03 2010 +0000
＠＠ -1,3 +1,13 ＠＠
+2010-11-17 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-extra.el (coerce):
+ In the argument list, name the first argument OBJECT, not X; the
+ former name was always used in the doc string and is clearer.
+ Handle vector type specifications which include the length of the
+ target sequence, error if there's a mismatch.
+ * cl-macs.el (cl-make-type-test): Handle type specifications
+ starting with the symbol 'eql.
+
2010-11-14 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
diff -r 6784adb405ad -r 09fed7053634 lisp/cl-extra.el
--- a/lisp/cl-extra.el Mon Nov 15 19:31:06 2010 +0000
+++ b/lisp/cl-extra.el Wed Nov 17 14:30:03 2010 +0000
＠＠ -53,47 +53,67 ＠＠
;;; Type coercion.
-(defun coerce (x type)
+(defun coerce (object type)
"Coerce OBJECT to type TYPE.
TYPE is a Common Lisp type specifier."
- (cond ((eq type 'list) (if (listp x) x (append x nil)))
- ((eq type 'vector) (if (vectorp x) x (vconcat x)))
- ((eq type 'string) (if (stringp x) x (concat x)))
- ((eq type 'array) (if (arrayp x) x (vconcat x)))
- ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
- ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
+ (cond ((eq type 'list) (if (listp object) object (append object nil)))
+ ((eq type 'vector) (if (vectorp object) object (vconcat object)))
+ ((eq type 'string) (if (stringp object) object (concat object)))
+ ((eq type 'array) (if (arrayp object) object (vconcat object)))
+ ((and (eq type 'character) (stringp object)
+ (eql (length object) 1)) (aref object 0))
+ ((and (eq type 'character) (symbolp object))
+ (coerce (symbol-name object) type))
;; XEmacs addition character <-> integer coercions
- ((and (eq type 'character) (char-int-p x)) (int-char x))
- ((and (memq type '(integer fixnum)) (characterp x)) (char-int x))
- ((eq type 'float) (float x))
+ ((and (eq type 'character) (char-int-p object)) (int-char object))
+ ((and (memq type '(integer fixnum)) (characterp object))
+ (char-int object))
+ ((eq type 'float) (float object))
;; XEmacs addition: enhanced numeric type coercions
((and-fboundp 'coerce-number
(memq type '(integer ratio bigfloat fixnum))
- (coerce-number x type)))
+ (coerce-number object type)))
;; XEmacs addition: bit-vector coercion
((or (eq type 'bit-vector)
(eq type 'simple-bit-vector))
- (if (bit-vector-p x) x (apply 'bit-vector (append x nil))))
+ (if (bit-vector-p object)
+ object
+ (apply 'bit-vector (append object nil))))
;; XEmacs addition: weak-list coercion
((eq type 'weak-list)
- (if (weak-list-p x) x
+ (if (weak-list-p object) object
(let ((wl (make-weak-list)))
- (set-weak-list-list wl (if (listp x) x (append x nil)))
+ (set-weak-list-list wl (if (listp object)
+ object
+ (append object nil)))
wl)))
((and
- (consp type)
- (or (eq (car type) 'vector)
- (eq (car type) 'simple-array)
- (eq (car type) 'simple-vector))
- (cond
- ((equal (cdr-safe type) '(*))
- (coerce x 'vector))
- ((equal (cdr-safe type) '(bit))
- (coerce x 'bit-vector))
- ((equal (cdr-safe type) '(character))
- (coerce x 'string)))))
- ((typep x type) x)
- (t (error "Can't coerce %s to type %s" x type))))
+ (memq (car-safe type) '(vector simple-array))
+ (loop
+ for (ignore elements length) = type
+ initially (declare (special ignore))
+ return (if (or (memq length '(* nil)) (eql length (length object)))
+ (cond
+ ((memq elements '(t * nil))
+ (coerce object 'vector))
+ ((memq elements '(string-char character))
+ (coerce object 'string))
+ ((eq elements 'bit)
+ (coerce object 'bit-vector)))
+ (error
+ 'wrong-type-argument
+ "Type specifier length must equal sequence length"
+ type)))))
+ ((eq (car-safe type) 'simple-vector)
+ (coerce object (list* 'vector t (cdr type))))
+ ((memq (car-safe type)
+ '(string simple-string base-string simple-base-string))
+ (coerce object (list* 'vector 'character (cdr type))))
+ ((eq (car-safe type) 'bit-vector)
+ (coerce object (list* 'vector 'bit (cdr type))))
+ ((typep object type) object)
+ (t (error 'invalid-operation
+ "Can't coerce object to type" object type))))
;; XEmacs; #'equalp is in C.
diff -r 6784adb405ad -r 09fed7053634 lisp/cl-macs.el
--- a/lisp/cl-macs.el Mon Nov 15 19:31:06 2010 +0000
+++ b/lisp/cl-macs.el Wed Nov 17 14:30:03 2010 +0000
＠＠ -3116,6 +3116,8 ＠＠
(cdr type))))
((memq (car-safe type) '(member member*))
(list 'and (list 'member* val (list 'quote (cdr type))) t))
+ ((eq (car-safe type) 'eql)
+ (list 'eql (cadr type) val))
((eq (car-safe type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches