Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5305:09fed7053634

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Handle slightly more complex type specifications, #'coerce, #'typep. 2010-11-17 Aidan Kehoe <kehoea@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.
author Aidan Kehoe <kehoea@parhasard.net>
date Wed, 17 Nov 2010 14:30:03 +0000
parents 99de5fd48e87
children f6471e4ae703 8d29f1c4bb98
comparison
equal deleted inserted replaced
5304:6784adb405ad 5305:09fed7053634
51 (eval-when-compile 51 (eval-when-compile
52 (require 'obsolete)) 52 (require 'obsolete))
53 53
54 ;;; Type coercion. 54 ;;; Type coercion.
55 55
56 (defun coerce (x type) 56 (defun coerce (object type)
57 "Coerce OBJECT to type TYPE. 57 "Coerce OBJECT to type TYPE.
58 TYPE is a Common Lisp type specifier." 58 TYPE is a Common Lisp type specifier."
59 (cond ((eq type 'list) (if (listp x) x (append x nil))) 59 (cond ((eq type 'list) (if (listp object) object (append object nil)))
60 ((eq type 'vector) (if (vectorp x) x (vconcat x))) 60 ((eq type 'vector) (if (vectorp object) object (vconcat object)))
61 ((eq type 'string) (if (stringp x) x (concat x))) 61 ((eq type 'string) (if (stringp object) object (concat object)))
62 ((eq type 'array) (if (arrayp x) x (vconcat x))) 62 ((eq type 'array) (if (arrayp object) object (vconcat object)))
63 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) 63 ((and (eq type 'character) (stringp object)
64 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) 64 (eql (length object) 1)) (aref object 0))
65 ((and (eq type 'character) (symbolp object))
66 (coerce (symbol-name object) type))
65 ;; XEmacs addition character <-> integer coercions 67 ;; XEmacs addition character <-> integer coercions
66 ((and (eq type 'character) (char-int-p x)) (int-char x)) 68 ((and (eq type 'character) (char-int-p object)) (int-char object))
67 ((and (memq type '(integer fixnum)) (characterp x)) (char-int x)) 69 ((and (memq type '(integer fixnum)) (characterp object))
68 ((eq type 'float) (float x)) 70 (char-int object))
71 ((eq type 'float) (float object))
69 ;; XEmacs addition: enhanced numeric type coercions 72 ;; XEmacs addition: enhanced numeric type coercions
70 ((and-fboundp 'coerce-number 73 ((and-fboundp 'coerce-number
71 (memq type '(integer ratio bigfloat fixnum)) 74 (memq type '(integer ratio bigfloat fixnum))
72 (coerce-number x type))) 75 (coerce-number object type)))
73 ;; XEmacs addition: bit-vector coercion 76 ;; XEmacs addition: bit-vector coercion
74 ((or (eq type 'bit-vector) 77 ((or (eq type 'bit-vector)
75 (eq type 'simple-bit-vector)) 78 (eq type 'simple-bit-vector))
76 (if (bit-vector-p x) x (apply 'bit-vector (append x nil)))) 79 (if (bit-vector-p object)
80 object
81 (apply 'bit-vector (append object nil))))
77 ;; XEmacs addition: weak-list coercion 82 ;; XEmacs addition: weak-list coercion
78 ((eq type 'weak-list) 83 ((eq type 'weak-list)
79 (if (weak-list-p x) x 84 (if (weak-list-p object) object
80 (let ((wl (make-weak-list))) 85 (let ((wl (make-weak-list)))
81 (set-weak-list-list wl (if (listp x) x (append x nil))) 86 (set-weak-list-list wl (if (listp object)
87 object
88 (append object nil)))
82 wl))) 89 wl)))
83 ((and 90 ((and
84 (consp type) 91 (memq (car-safe type) '(vector simple-array))
85 (or (eq (car type) 'vector) 92 (loop
86 (eq (car type) 'simple-array) 93 for (ignore elements length) = type
87 (eq (car type) 'simple-vector)) 94 initially (declare (special ignore))
88 (cond 95 return (if (or (memq length '(* nil)) (eql length (length object)))
89 ((equal (cdr-safe type) '(*)) 96 (cond
90 (coerce x 'vector)) 97 ((memq elements '(t * nil))
91 ((equal (cdr-safe type) '(bit)) 98 (coerce object 'vector))
92 (coerce x 'bit-vector)) 99 ((memq elements '(string-char character))
93 ((equal (cdr-safe type) '(character)) 100 (coerce object 'string))
94 (coerce x 'string))))) 101 ((eq elements 'bit)
95 ((typep x type) x) 102 (coerce object 'bit-vector)))
96 (t (error "Can't coerce %s to type %s" x type)))) 103 (error
104 'wrong-type-argument
105 "Type specifier length must equal sequence length"
106 type)))))
107 ((eq (car-safe type) 'simple-vector)
108 (coerce object (list* 'vector t (cdr type))))
109 ((memq (car-safe type)
110 '(string simple-string base-string simple-base-string))
111 (coerce object (list* 'vector 'character (cdr type))))
112 ((eq (car-safe type) 'bit-vector)
113 (coerce object (list* 'vector 'bit (cdr type))))
114 ((typep object type) object)
115 (t (error 'invalid-operation
116 "Can't coerce object to type" object type))))
97 117
98 ;; XEmacs; #'equalp is in C. 118 ;; XEmacs; #'equalp is in C.
99 119
100 ;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every 120 ;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every
101 ;; are now in C, together with #'map-into, which was never in this file. 121 ;; are now in C, together with #'map-into, which was never in this file.