Mercurial > hg > xemacs-beta

comparison lisp/cl.el @ 227:0e522484dd2a r20-5b12

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b12
author cvs
date Mon, 13 Aug 2007 10:12:37 +0200
parents 41ff10fd062f
children c5d627a313b1
comparison
equal deleted inserted replaced
226:eea38c7ad7b4 227:0e522484dd2a
149 ;;; Predicates. 149 ;;; Predicates.
150 150
151 (defun eql (a b) ; See compiler macro in cl-macs.el 151 (defun eql (a b) ; See compiler macro in cl-macs.el
152 "T if the two args are the same Lisp object. 152 "T if the two args are the same Lisp object.
153 Floating-point numbers of equal value are `eql', but they may not be `eq'." 153 Floating-point numbers of equal value are `eql', but they may not be `eq'."
154 (if (numberp a) 154 (if (floatp a)
155 (equal a b) 155 (equal a b)
156 (eq a b))) 156 (eq a b)))
157 157
158 158
159 ;;; Generalized variables. These macros are defined here so that they 159 ;;; Generalized variables. These macros are defined here so that they
163 "(incf PLACE [X]): increment PLACE by X (1 by default). 163 "(incf PLACE [X]): increment PLACE by X (1 by default).
164 PLACE may be a symbol, or any generalized variable allowed by `setf'. 164 PLACE may be a symbol, or any generalized variable allowed by `setf'.
165 The return value is the incremented value of PLACE." 165 The return value is the incremented value of PLACE."
166 (if (symbolp place) 166 (if (symbolp place)
167 (list 'setq place (if x (list '+ place x) (list '1+ place))) 167 (list 'setq place (if x (list '+ place x) (list '1+ place)))
168 ;; XEmacs byte-compiler optimizes (+ FOO 1) to (1+ FOO), so this
169 ;; is OK.
168 (list 'callf '+ place (or x 1)))) 170 (list 'callf '+ place (or x 1))))
169 171
170 (defmacro decf (place &optional x) 172 (defmacro decf (place &optional x)
171 "(decf PLACE [X]): decrement PLACE by X (1 by default). 173 "(decf PLACE [X]): decrement PLACE by X (1 by default).
172 PLACE may be a symbol, or any generalized variable allowed by `setf'. 174 PLACE may be a symbol, or any generalized variable allowed by `setf'.
221 (and (< end (length str)) (substring str end)))) 223 (and (< end (length str)) (substring str end))))
222 224
223 225
224 ;;; Control structures. 226 ;;; Control structures.
225 227
226 ;;; These macros are so simple and so often-used that it's better to have 228 ;; These macros are so simple and so often-used that it's better to have
227 ;;; them all the time than to load them from cl-macs.el. 229 ;; them all the time than to load them from cl-macs.el.
230
231 ;; NOTE: these macros were moved to subr.el in FSF 20. It is of no
232 ;; consequence to XEmacs, because we preload this file, and they
233 ;; should better remain here.
228 234
229 (defmacro when (cond &rest body) 235 (defmacro when (cond &rest body)
230 "(when COND BODY...): if COND yields non-nil, do BODY, else return nil." 236 "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
231 (list 'if cond (cons 'progn body))) 237 (list 'if cond (cons 'progn body)))
232 238
233 (defmacro unless (cond &rest body) 239 (defmacro unless (cond &rest body)
234 "(unless COND BODY...): if COND yields nil, do BODY, else return nil." 240 "(unless COND BODY...): if COND yields nil, do BODY, else return nil."
235 (cons 'if (cons cond (cons nil body)))) 241 (cons 'if (cons cond (cons nil body))))
236 242
237 (defun cl-map-extents (&rest cl-args) 243 (defun cl-map-extents (&rest cl-args)
238 (if (fboundp 'next-overlay-at) (apply 'cl-map-overlays cl-args) 244 ;; XEmacs: This used to check for overlays first, but that's wrong
239 (if (fboundp 'map-extents) (apply 'map-extents cl-args)))) 245 ;; because of the new compatibility library. *duh*
246 (cond ((fboundp 'map-extents)
247 (apply 'map-extents cl-args))
248 ((fboundp 'next-overlay-at)
249 (apply 'cl-map-overlays cl-args))))
240 250
241 251
242 ;;; Blocks and exits. 252 ;;; Blocks and exits.
243 253
244 (defalias 'cl-block-wrapper 'identity) 254 (defalias 'cl-block-wrapper 'identity)
323 333
324 (defun floatp-safe (x) 334 (defun floatp-safe (x)
325 "T if OBJECT is a floating point number. 335 "T if OBJECT is a floating point number.
326 On Emacs versions that lack floating-point support, this function 336 On Emacs versions that lack floating-point support, this function
327 always returns nil." 337 always returns nil."
328 (and (numberp x) (not (integerp x)))) 338 ;;(and (numberp x) (not (integerp x)))
339 ;; XEmacs: use floatp. XEmacs is always compiled with
340 ;; floating-point, anyway.
341 (floatp x))
329 342
330 (defun plusp (x) 343 (defun plusp (x)
331 "T if NUMBER is positive." 344 "T if NUMBER is positive."
332 (> x 0)) 345 (> x 0))
333 346