Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5474:4dee0387b9de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merged with trunk.
author Mats Lidell <matsl@xemacs.org>
date Tue, 29 Mar 2011 00:02:47 +0200
parents ac37a5f7e5be 3889ef128488
children 248176c74e6b
comparison
equal deleted inserted replaced
5473:ac37a5f7e5be 5474:4dee0387b9de
763 This jumps out to the innermost enclosing `(block NAME ...)' form, 763 This jumps out to the innermost enclosing `(block NAME ...)' form,
764 returning RESULT from that form (or nil if RESULT is omitted). 764 returning RESULT from that form (or nil if RESULT is omitted).
765 This is compatible with Common Lisp, but note that `defun' and 765 This is compatible with Common Lisp, but note that `defun' and
766 `defmacro' do not create implicit blocks as they do in Common Lisp." 766 `defmacro' do not create implicit blocks as they do in Common Lisp."
767 `(throw ',(or (cdr (assq name cl-active-block-names)) 767 `(throw ',(or (cdr (assq name cl-active-block-names))
768 (prog1 (copy-symbol name) 768 ;; Tell the byte-compiler the original name of the block,
769 (and-fboundp 'byte-compile-warn (cl-compiling-file) 769 ;; leave any warning to it.
770 (byte-compile-warn 770 (let ((copy-symbol (copy-symbol name)))
771 "return-from: no enclosing block named `%s'" 771 (put copy-symbol 'cl-block-name name)
772 name)))) 772 copy-symbol))
773 ,result)) 773 ,result))
774 774
775 ;;; The "loop" macro. 775 ;;; The "loop" macro.
776 776
777 (defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) 777 (defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
778 (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) 778 (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
824 standard Lisp macro called `return'. Normally they work similarly\; but if 824 standard Lisp macro called `return'. Normally they work similarly\; but if
825 you give the loop a name with `named', you will need to use the macro 825 you give the loop a name with `named', you will need to use the macro
826 `return-from'.) 826 `return-from'.)
827 827
828 Another extremely useful feature of loops is called \"destructuring\". If, 828 Another extremely useful feature of loops is called \"destructuring\". If,
829 in place of VAR, a list (possibly dotted, possibly a tree of arbitary 829 in place of VAR, a list (possibly dotted, possibly a tree of arbitrary
830 complexity) is given, the value to be assigned is assumed to have a similar 830 complexity) is given, the value to be assigned is assumed to have a similar
831 structure to the list given, and variables in the list will be matched up 831 structure to the list given, and variables in the list will be matched up
832 with corresponding elements in the structure. For example: 832 with corresponding elements in the structure. For example:
833 833
834 \(loop 834 \(loop
3226 (and unsafe (list (list argn argv)))) 3226 (and unsafe (list (list argn argv))))
3227 (list (list argn argv)))) 3227 (list (list argn argv))))
3228 argns argvs))) 3228 argns argvs)))
3229 (if lets (list 'let lets body) body)))) 3229 (if lets (list 'let lets body) body))))
3230 3230
3231 ;; When a 64-bit build is byte-compiling code, some of its native fixnums
3232 ;; will not be represented as fixnums if the byte-compiled code is read by
3233 ;; the Lisp reader in a 32-bit build. So in that case we need to check the
3234 ;; range of fixnums as well as their types. XEmacs doesn't support machines
3235 ;; with word size less than 32, so it's OK to have that as the minimum.
3236 (macrolet
3237 ((most-negative-fixnum-on-32-bit-machines () (lognot (1- (lsh 1 30))))
3238 (most-positive-fixnum-on-32-bit-machines () (lsh 1 30)))
3239 (defun cl-non-fixnum-number-p (object)
3240 "Return t if OBJECT is a number not guaranteed to be immediate."
3241 (and (numberp object)
3242 (or (not (fixnump object))
3243 (not (<= (most-negative-fixnum-on-32-bit-machines)
3244 object
3245 (most-positive-fixnum-on-32-bit-machines)))))))
3231 3246
3232 ;;; Compile-time optimizations for some functions defined in this package. 3247 ;;; Compile-time optimizations for some functions defined in this package.
3233 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, 3248 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
3234 ;;; mainly to make sure these macros will be present. 3249 ;;; mainly to make sure these macros will be present.
3235
3236 (defun cl-non-fixnum-number-p (object)
3237 (and (numberp object) (not (fixnump object))))
3238 3250
3239 (define-compiler-macro eql (&whole form a b) 3251 (define-compiler-macro eql (&whole form a b)
3240 (cond ((eq (cl-const-expr-p a) t) 3252 (cond ((eq (cl-const-expr-p a) t)
3241 (let ((val (cl-const-expr-val a))) 3253 (let ((val (cl-const-expr-val a)))
3242 (if (cl-non-fixnum-number-p val) 3254 (if (cl-non-fixnum-number-p val)
3694 `(cons (cons ,a ,b) ,c)) 3706 `(cons (cons ,a ,b) ,c))
3695 3707
3696 (define-compiler-macro pairlis (a b &optional c) 3708 (define-compiler-macro pairlis (a b &optional c)
3697 `(nconc (mapcar* #'cons ,a ,b) ,c)) 3709 `(nconc (mapcar* #'cons ,a ,b) ,c))
3698 3710
3711 (define-compiler-macro revappend (&whole form &rest args)
3712 (if (eql 3 (length form)) `(nconc (reverse ,(pop args)) ,(pop args)) form))
3713
3714 (define-compiler-macro nreconc (&whole form &rest args)
3715 (if (eql 3 (length form)) `(nconc (nreverse ,(pop args)) ,(pop args)) form))
3716
3699 (define-compiler-macro complement (&whole form fn) 3717 (define-compiler-macro complement (&whole form fn)
3700 (if (or (eq (car-safe fn) 'function) (eq (car-safe fn) 'quote)) 3718 (if (or (eq (car-safe fn) 'function) (eq (car-safe fn) 'quote))
3701 (cond 3719 (cond
3702 ((and (symbolp (second fn)) (get (second fn) 'byte-compile-negated-op)) 3720 ((and (symbolp (second fn)) (get (second fn) 'byte-compile-negated-op))
3703 (list 'function (get (second fn) 'byte-compile-negated-op))) 3721 (list 'function (get (second fn) 'byte-compile-negated-op)))