Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.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 002cb5224e4f 38e24b8be4ea
children 00e79bbbe48f
comparison
equal deleted inserted replaced
5469:2a8a04f73c15 5470:0af042a0c116
507 (or (eval (cl-make-type-test form type)) 507 (or (eval (cl-make-type-test form type))
508 (byte-compile-warn 508 (byte-compile-warn
509 "%s is not of type %s" form type))) 509 "%s is not of type %s" form type)))
510 (if byte-compile-delete-errors 510 (if byte-compile-delete-errors
511 form 511 form
512 (funcall (cdr (symbol-function 'the)) type form))))) 512 (funcall (cdr (symbol-function 'the)) type form))))
513 (return-from .
514 ,#'(lambda (name &optional result) `(return-from-1 ',name ,result)))
515 (block .
516 ,#'(lambda (name &rest body) `(block-1 ',name ,@body))))
513 "The default macro-environment passed to macroexpand by the compiler. 517 "The default macro-environment passed to macroexpand by the compiler.
514 Placing a macro here will cause a macro to have different semantics when 518 Placing a macro here will cause a macro to have different semantics when
515 expanded by the compiler as when expanded by the interpreter.") 519 expanded by the compiler as when expanded by the interpreter.")
516 520
517 (defvar byte-compile-macro-environment byte-compile-initial-macro-environment 521 (defvar byte-compile-macro-environment byte-compile-initial-macro-environment
3725 (setq var (pop args)) 3729 (setq var (pop args))
3726 (if (null args) 3730 (if (null args)
3727 ;; Odd number of args? Let `set' get the error. 3731 ;; Odd number of args? Let `set' get the error.
3728 (byte-compile-form `(set ',var) for-effect) 3732 (byte-compile-form `(set ',var) for-effect)
3729 (setq val (pop args)) 3733 (setq val (pop args))
3730 (if (keywordp var) 3734 (byte-compile-form val)
3731 ;; (setq :foo ':foo) compatibility kludge 3735 (unless (or args for-effect)
3732 (byte-compile-form `(set ',var ,val) (if args t for-effect)) 3736 (byte-compile-out 'byte-dup 0))
3733 (byte-compile-form val) 3737 (byte-compile-variable-ref 'byte-varset var)))))
3734 (unless (or args for-effect)
3735 (byte-compile-out 'byte-dup 0))
3736 (byte-compile-variable-ref 'byte-varset var))))))
3737 (setq for-effect nil)) 3738 (setq for-effect nil))
3738 3739
3739 (defun byte-compile-set (form) 3740 (defun byte-compile-set (form)
3740 ;; Compile (set 'foo x) as (setq foo x) for trivially better code and so 3741 ;; Compile (set 'foo x) as (setq foo x) for trivially better code and so
3741 ;; that we get applicable warnings. Compile everything else (including 3742 ;; that we get applicable warnings. Compile everything else (including
3742 ;; malformed calls) like a normal 2-arg byte-coded function. 3743 ;; malformed calls) like a normal 2-arg byte-coded function.
3743 (let ((symform (nth 1 form)) 3744 (let ((symform (nth 1 form))
3744 (valform (nth 2 form)) 3745 (valform (nth 2 form))
3745 sym) 3746 sym)
3746 (if (and (= (length form) 3) 3747 (if (and (eql (length form) 3)
3747 (= (safe-length symform) 2) 3748 (eql (safe-length symform) 2)
3748 (eq (car symform) 'quote) 3749 (eq (car symform) 'quote)
3749 (symbolp (setq sym (car (cdr symform)))) 3750 (symbolp (setq sym (car (cdr symform)))))
3750 (not (byte-compile-constant-symbol-p sym)))
3751 (byte-compile-setq `(setq ,sym ,valform)) 3751 (byte-compile-setq `(setq ,sym ,valform))
3752 (byte-compile-two-args form)))) 3752 (byte-compile-two-args form))))
3753 3753
3754 (defun byte-compile-setq-default (form) 3754 (defun byte-compile-setq-default (form)
3755 (let ((args (cdr form))) 3755 (let ((args (cdr form)))
4182 (cdr form)))) 4182 (cdr form))))
4183 4183
4184 ;;; other tricky macro-like special-operators 4184 ;;; other tricky macro-like special-operators
4185 4185
4186 (byte-defop-compiler-1 catch) 4186 (byte-defop-compiler-1 catch)
4187 (byte-defop-compiler-1 block-1)
4188 (byte-defop-compiler-1 return-from-1)
4187 (byte-defop-compiler-1 unwind-protect) 4189 (byte-defop-compiler-1 unwind-protect)
4188 (byte-defop-compiler-1 condition-case) 4190 (byte-defop-compiler-1 condition-case)
4189 (byte-defop-compiler-1 save-excursion) 4191 (byte-defop-compiler-1 save-excursion)
4190 (byte-defop-compiler-1 save-current-buffer) 4192 (byte-defop-compiler-1 save-current-buffer)
4191 (byte-defop-compiler-1 save-restriction) 4193 (byte-defop-compiler-1 save-restriction)
4195 (defun byte-compile-catch (form) 4197 (defun byte-compile-catch (form)
4196 (byte-compile-form (car (cdr form))) 4198 (byte-compile-form (car (cdr form)))
4197 (byte-compile-push-constant 4199 (byte-compile-push-constant
4198 (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) 4200 (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect))
4199 (byte-compile-out 'byte-catch 0)) 4201 (byte-compile-out 'byte-catch 0))
4202
4203 ;; `return-from' and `block' are different from `throw' and `catch' when it
4204 ;; comes to scope and extent. These differences are implemented for
4205 ;; interpreted code in cl-macs.el, in compiled code in bytecomp.el. There's
4206 ;; a certain amount of bootstrapping needed for the latter, and until this
4207 ;; is done return-from and block behave as throw and catch in their scope
4208 ;; and extent. This is only relevant to people working on bytecomp.el.
4209
4210 (defalias 'return-from-1 'throw)
4211 (defalias 'block-1 'catch)
4212
4213 (defvar byte-compile-active-blocks nil)
4214
4215 (defun byte-compile-block-1 (form)
4216 (let* ((name (nth 1 (nth 1 form)))
4217 (elt (list name (copy-symbol name) nil))
4218 (byte-compile-active-blocks (cons elt byte-compile-active-blocks))
4219 (body (byte-compile-top-level (cons 'progn (cddr form)))))
4220 (if (nth 2 elt)
4221 (byte-compile-catch `(catch ',(nth 1 elt) ,body))
4222 (byte-compile-form body))))
4223
4224 (defun byte-compile-return-from-1 (form)
4225 (let* ((name (nth 1 (nth 1 form)))
4226 (assq (assq name byte-compile-active-blocks)))
4227 (if assq
4228 (setf (nth 2 assq) t)
4229 (byte-compile-warn
4230 "return-from: %S: no current lexical block with this name"
4231 name))
4232 (byte-compile-throw
4233 `(throw ',(or (nth 1 assq) (copy-symbol name))
4234 ,@(nthcdr 2 form)))))
4200 4235
4201 (defun byte-compile-unwind-protect (form) 4236 (defun byte-compile-unwind-protect (form)
4202 (byte-compile-push-constant 4237 (byte-compile-push-constant
4203 (byte-compile-top-level-body (cdr (cdr form)) t)) 4238 (byte-compile-top-level-body (cdr (cdr form)) t))
4204 (byte-compile-out 'byte-unwind-protect 0) 4239 (byte-compile-out 'byte-unwind-protect 0)