Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5470:0af042a0c116

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 Mon, 07 Feb 2011 21:22:17 +0100
parents a9094f28f9a9 38e24b8be4ea
children 00e79bbbe48f
comparison
equal deleted inserted replaced
5469:2a8a04f73c15 5470:0af042a0c116
728 `otherwise'-clauses are not allowed." 728 `otherwise'-clauses are not allowed."
729 (list* 'typecase expr (append clauses '((ecase-error-flag))))) 729 (list* 'typecase expr (append clauses '((ecase-error-flag)))))
730 730
731 731
732 ;;; Blocks and exits. 732 ;;; Blocks and exits.
733 (defvar cl-active-block-names nil)
733 734
734 ;;;###autoload 735 ;;;###autoload
735 (defmacro block (name &rest body) 736 (defmacro block (name &rest body)
736 "Define a lexically-scoped block named NAME. 737 "Define a lexically-scoped block named NAME.
737 NAME may be any symbol. Code inside the BODY forms can call `return-from' 738 NAME may be any symbol. Code inside the BODY forms can call `return-from'
738 to jump prematurely out of the block. This differs from `catch' and `throw' 739 to jump prematurely out of the block. This differs from `catch' and `throw'
739 in two respects: First, the NAME is an unevaluated symbol rather than a 740 in two respects: First, the NAME is an unevaluated symbol rather than a
740 quoted symbol or other form; and second, NAME is lexically rather than 741 quoted symbol or other form; and second, NAME is lexically rather than
741 dynamically scoped: Only references to it within BODY will work. These 742 dynamically scoped: Only references to it within BODY will work. These
742 references may appear inside macro expansions, but not inside functions 743 references may appear inside macro expansions and in lambda expressions, but
743 called from BODY." 744 not inside other functions called from BODY."
744 (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body) 745 (let ((cl-active-block-names (acons name (copy-symbol name)
745 (list 'cl-block-wrapper 746 cl-active-block-names))
746 (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) 747 (body (cons 'progn body)))
747 body)))) 748 `(catch ',(cdar cl-active-block-names)
748 749 ,(cl-macroexpand-all body cl-macro-environment))))
749 (defvar cl-active-block-names nil)
750
751 (put 'cl-block-wrapper 'byte-compile
752 #'(lambda (cl-form)
753 (if (/= (length cl-form) 2)
754 (byte-compile-warn-wrong-args cl-form 1))
755
756 (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing
757 ; compiler
758 (progn
759 (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
760 (cl-active-block-names (cons cl-entry
761 cl-active-block-names))
762 (cl-body (byte-compile-top-level
763 (cons 'progn (cddr (nth 1 cl-form))))))
764 (if (cdr cl-entry)
765 (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form))
766 cl-body))
767 (byte-compile-form cl-body))))
768 (byte-compile-form (nth 1 cl-form)))))
769
770 (put 'cl-block-throw 'byte-compile
771 #'(lambda (cl-form)
772 (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
773 (if cl-found (setcdr cl-found t)))
774 (byte-compile-throw (cons 'throw (cdr cl-form)))))
775 750
776 ;;;###autoload 751 ;;;###autoload
777 (defmacro return (&optional result) 752 (defmacro return (&optional result)
778 "Return from the block named nil. 753 "Return from the block named nil.
779 This is equivalent to `(return-from nil RESULT)'." 754 This is equivalent to `(return-from nil RESULT)'."
780 (list 'return-from nil result)) 755 `(return-from nil ,result))
781 756
782 ;;;###autoload 757 ;;;###autoload
783 (defmacro return-from (name &optional result) 758 (defmacro return-from (name &optional result)
784 "Return from the block named NAME. 759 "Return from the block named NAME.
785 This jumps out to the innermost enclosing `(block NAME ...)' form, 760 This jumps out to the innermost enclosing `(block NAME ...)' form,
786 returning RESULT from that form (or nil if RESULT is omitted). 761 returning RESULT from that form (or nil if RESULT is omitted).
787 This is compatible with Common Lisp, but note that `defun' and 762 This is compatible with Common Lisp, but note that `defun' and
788 `defmacro' do not create implicit blocks as they do in Common Lisp." 763 `defmacro' do not create implicit blocks as they do in Common Lisp."
789 (let ((name2 (intern (format "--cl-block-%s--" name)))) 764 `(throw ',(or (cdr (assq name cl-active-block-names)) (copy-symbol name))
790 (list 'cl-block-throw (list 'quote name2) result))) 765 ,result))
791
792 766
793 ;;; The "loop" macro. 767 ;;; The "loop" macro.
794 768
795 (defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) 769 (defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
796 (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) 770 (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
3339 (not (memq :key keys))) 3313 (not (memq :key keys)))
3340 (list 'if (list* 'member* a list keys) list (list 'cons a list)) 3314 (list 'if (list* 'member* a list keys) list (list 'cons a list))
3341 form)) 3315 form))
3342 3316
3343 (define-compiler-macro delete (&whole form &rest args) 3317 (define-compiler-macro delete (&whole form &rest args)
3344 (symbol-macrolet 3318 (if (eql 3 (length form))
3345 ((not-constant '#:not-constant)) 3319 (symbol-macrolet ((not-constant '#:not-constant))
3346 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant))) 3320 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3347 (if (and (cdr form) (not (eq not-constant cl-const-expr-val)) 3321 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3348 (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val) 3322 (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
3349 (characterp cl-const-expr-val))) 3323 (characterp cl-const-expr-val)))
3350 (cons 'delete* (cdr form)) 3324 (cons 'delete* (cdr form))
3351 `(delete* ,@(cdr form) :test #'equal))))) 3325 `(delete* ,@(cdr form) :test #'equal))))
3326 form))
3352 3327
3353 (define-compiler-macro delq (&whole form &rest args) 3328 (define-compiler-macro delq (&whole form &rest args)
3354 (symbol-macrolet 3329 (if (eql 3 (length form))
3355 ((not-constant '#:not-constant)) 3330 (symbol-macrolet
3356 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant))) 3331 ((not-constant '#:not-constant))
3357 (if (and (cdr form) (not (eq not-constant cl-const-expr-val)) 3332 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3358 (not (cl-non-fixnum-number-p cl-const-expr-val))) 3333 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3359 (cons 'delete* (cdr form)) 3334 (not (cl-non-fixnum-number-p cl-const-expr-val)))
3360 `(delete* ,@(cdr form) :test #'eq))))) 3335 (cons 'delete* (cdr form))
3336 `(delete* ,@(cdr form) :test #'eq))))
3337 form))
3361 3338
3362 (define-compiler-macro remove (&whole form &rest args) 3339 (define-compiler-macro remove (&whole form &rest args)
3363 (symbol-macrolet 3340 (if (eql 3 (length form))
3364 ((not-constant '#:not-constant)) 3341 (symbol-macrolet
3365 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant))) 3342 ((not-constant '#:not-constant))
3366 (if (and (cdr form) (not (eq not-constant cl-const-expr-val)) 3343 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3367 (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val) 3344 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3368 (characterp cl-const-expr-val))) 3345 (or (symbolp cl-const-expr-val) (fixnump cl-const-expr-val)
3369 (cons 'remove* (cdr form)) 3346 (characterp cl-const-expr-val)))
3370 `(remove* ,@(cdr form) :test #'equal))))) 3347 (cons 'remove* (cdr form))
3348 `(remove* ,@(cdr form) :test #'equal))))
3349 form))
3371 3350
3372 (define-compiler-macro remq (&whole form &rest args) 3351 (define-compiler-macro remq (&whole form &rest args)
3373 (symbol-macrolet 3352 (if (eql 3 (length form))
3374 ((not-constant '#:not-constant)) 3353 (symbol-macrolet
3375 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant))) 3354 ((not-constant '#:not-constant))
3376 (if (and (cdr form) (not (eq not-constant cl-const-expr-val)) 3355 (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
3377 (not (cl-non-fixnum-number-p cl-const-expr-val))) 3356 (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
3378 (cons 'remove* (cdr form)) 3357 (not (cl-non-fixnum-number-p cl-const-expr-val)))
3379 `(remove* ,@(cdr form) :test #'eq))))) 3358 (cons 'remove* (cdr form))
3359 `(remove* ,@(cdr form) :test #'eq))))
3360 form))
3380 3361
3381 (macrolet 3362 (macrolet
3382 ((define-foo-if-compiler-macros (&rest alist) 3363 ((define-foo-if-compiler-macros (&rest alist)
3383 "Avoid the funcall, variable binding and keyword parsing overhead 3364 "Avoid the funcall, variable binding and keyword parsing overhead
3384 for the FOO-IF and FOO-IF-NOT functions, transforming to forms using the 3365 for the FOO-IF and FOO-IF-NOT functions, transforming to forms using the