Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5438:8d29f1c4bb98

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