Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5468:a9094f28f9a9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Wed, 19 Jan 2011 22:35:23 +0100
parents 89331fa1c819 ba62563ec7c7
children 0af042a0c116
comparison
equal deleted inserted replaced
5457:4ed2dedf36a1 5468:a9094f28f9a9
3338 (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) 3338 (if (and (cl-simple-expr-p a) (cl-simple-expr-p list)
3339 (not (memq :key keys))) 3339 (not (memq :key keys)))
3340 (list 'if (list* 'member* a list keys) list (list 'cons a list)) 3340 (list 'if (list* 'member* a list keys) list (list 'cons a list))
3341 form)) 3341 form))
3342 3342
3343 (define-compiler-macro remove (item sequence) 3343 (define-compiler-macro delete (&whole form &rest args)
3344 `(remove* ,item ,sequence :test #'equal)) 3344 (symbol-macrolet
3345 3345 ((not-constant '#:not-constant))
3346 (define-compiler-macro remq (item sequence) 3346 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3347 `(remove* ,item ,sequence :test #'eq)) 3347 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3348 3348 (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
3349 (characterp cl-const-expr-val)))
3350 (cons 'delete* (cdr form))
3351 `(delete* ,@(cdr form) :test #'equal)))))
3352
3353 (define-compiler-macro delq (&whole form &rest args)
3354 (symbol-macrolet
3355 ((not-constant '#:not-constant))
3356 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3357 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3358 (not (cl-non-fixnum-number-p cl-const-expr-val)))
3359 (cons 'delete* (cdr form))
3360 `(delete* ,@(cdr form) :test #'eq)))))
3361
3362 (define-compiler-macro remove (&whole form &rest args)
3363 (symbol-macrolet
3364 ((not-constant '#:not-constant))
3365 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3366 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3367 (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
3368 (characterp cl-const-expr-val)))
3369 (cons 'remove* (cdr form))
3370 `(remove* ,@(cdr form) :test #'equal)))))
3371
3372 (define-compiler-macro remq (&whole form &rest args)
3373 (symbol-macrolet
3374 ((not-constant '#:not-constant))
3375 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3376 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3377 (not (cl-non-fixnum-number-p cl-const-expr-val)))
3378 (cons 'remove* (cdr form))
3379 `(remove* ,@(cdr form) :test #'eq)))))
3380
3349 (macrolet 3381 (macrolet
3350 ((define-foo-if-compiler-macros (&rest alist) 3382 ((define-foo-if-compiler-macros (&rest alist)
3351 "Avoid the funcall, variable binding and keyword parsing overhead 3383 "Avoid the funcall, variable binding and keyword parsing overhead
3352 for the FOO-IF and FOO-IF-NOT functions, transforming to forms using the 3384 for the FOO-IF and FOO-IF-NOT functions, transforming to forms using the
3353 non-standard :if and :if-not keywords at compile time." 3385 non-standard :if and :if-not keywords at compile time."
3795 (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) 3827 (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
3796 (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) 3828 (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
3797 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) 3829 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
3798 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr))) 3830 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr)))
3799 3831
3800 ;;; Things that are inline. 3832 ;;; Things that are inline. XEmacs; the functions that used to be here have
3801 (proclaim '(inline acons map concatenate 3833 ;;; compiler macros or are built-in.
3802 ;; XEmacs omission: gethash is builtin 3834 (proclaim '(inline cl-set-elt))
3803 cl-set-elt revappend nreconc))
3804 3835
3805 ;;; Things that are side-effect-free. Moved to byte-optimize.el 3836 ;;; Things that are side-effect-free. Moved to byte-optimize.el
3806 ;(mapcar (function (lambda (x) (put x 'side-effect-free t))) 3837 ;(mapcar (function (lambda (x) (put x 'side-effect-free t)))
3807 ; '(oddp evenp signum last butlast ldiff pairlis gcd lcm 3838 ; '(oddp evenp signum last butlast ldiff pairlis gcd lcm
3808 ; isqrt floor* ceiling* truncate* round* mod* rem* subseq 3839 ; isqrt floor* ceiling* truncate* round* mod* rem* subseq