Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.el @ 5471:00e79bbbe48f

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, 14 Feb 2011 22:43:46 +0100
parents 0af042a0c116 5dd1ba5e0113
children e79980ee5efe
comparison
equal deleted inserted replaced
5470:0af042a0c116 5471:00e79bbbe48f
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))))
517 "The default macro-environment passed to macroexpand by the compiler. 513 "The default macro-environment passed to macroexpand by the compiler.
518 Placing a macro here will cause a macro to have different semantics when 514 Placing a macro here will cause a macro to have different semantics when
519 expanded by the compiler as when expanded by the interpreter.") 515 expanded by the compiler as when expanded by the interpreter.")
520 516
521 (defvar byte-compile-macro-environment byte-compile-initial-macro-environment 517 (defvar byte-compile-macro-environment byte-compile-initial-macro-environment
4182 (cdr form)))) 4178 (cdr form))))
4183 4179
4184 ;;; other tricky macro-like special-operators 4180 ;;; other tricky macro-like special-operators
4185 4181
4186 (byte-defop-compiler-1 catch) 4182 (byte-defop-compiler-1 catch)
4187 (byte-defop-compiler-1 block-1)
4188 (byte-defop-compiler-1 return-from-1)
4189 (byte-defop-compiler-1 unwind-protect) 4183 (byte-defop-compiler-1 unwind-protect)
4190 (byte-defop-compiler-1 condition-case) 4184 (byte-defop-compiler-1 condition-case)
4191 (byte-defop-compiler-1 save-excursion) 4185 (byte-defop-compiler-1 save-excursion)
4192 (byte-defop-compiler-1 save-current-buffer) 4186 (byte-defop-compiler-1 save-current-buffer)
4193 (byte-defop-compiler-1 save-restriction) 4187 (byte-defop-compiler-1 save-restriction)
4194 (byte-defop-compiler-1 with-output-to-temp-buffer) 4188 (byte-defop-compiler-1 with-output-to-temp-buffer)
4195 ;; no track-mouse. 4189 ;; no track-mouse.
4196 4190
4191 (defvar byte-compile-active-blocks nil)
4192
4197 (defun byte-compile-catch (form) 4193 (defun byte-compile-catch (form)
4198 (byte-compile-form (car (cdr form))) 4194 "Byte-compile and return a `catch' from.
4199 (byte-compile-push-constant 4195
4200 (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) 4196 If FORM is the result of macroexpanding a `block' form (the TAG argument is
4201 (byte-compile-out 'byte-catch 0)) 4197 a quoted symbol with a non-nil `cl-block-name' property) and there is no
4202 4198 corresponding `return-from' within the block--or equivalently, it was
4203 ;; `return-from' and `block' are different from `throw' and `catch' when it 4199 optimized away--just byte compile and return the BODY."
4204 ;; comes to scope and extent. These differences are implemented for 4200 (let* ((symbol (car-safe (cdr-safe (nth 1 form))))
4205 ;; interpreted code in cl-macs.el, in compiled code in bytecomp.el. There's 4201 (block (and symbol (symbolp symbol) (get symbol 'cl-block-name)))
4206 ;; a certain amount of bootstrapping needed for the latter, and until this 4202 (elt (and block (cons block nil)))
4207 ;; is done return-from and block behave as throw and catch in their scope 4203 (byte-compile-active-blocks
4208 ;; and extent. This is only relevant to people working on bytecomp.el. 4204 (if block
4209 4205 (cons elt byte-compile-active-blocks)
4210 (defalias 'return-from-1 'throw) 4206 byte-compile-active-blocks))
4211 (defalias 'block-1 'catch) 4207 (body
4212 4208 (byte-compile-top-level (cons 'progn (cddr form))
4213 (defvar byte-compile-active-blocks nil) 4209 (if block nil for-effect))))
4214 4210 (if (and block (not (cdr elt)))
4215 (defun byte-compile-block-1 (form) 4211 ;; A lexical block without any contained return-from clauses:
4216 (let* ((name (nth 1 (nth 1 form))) 4212 (byte-compile-form body)
4217 (elt (list name (copy-symbol name) nil)) 4213 ;; A normal catch call, or a lexical block with a contained
4218 (byte-compile-active-blocks (cons elt byte-compile-active-blocks)) 4214 ;; return-from clause.
4219 (body (byte-compile-top-level (cons 'progn (cddr form))))) 4215 (byte-compile-form (car (cdr form)))
4220 (if (nth 2 elt) 4216 (byte-compile-push-constant body)
4221 (byte-compile-catch `(catch ',(nth 1 elt) ,body)) 4217 (byte-compile-out 'byte-catch 0))))
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)))))
4235 4218
4236 (defun byte-compile-unwind-protect (form) 4219 (defun byte-compile-unwind-protect (form)
4237 (byte-compile-push-constant 4220 (byte-compile-push-constant
4238 (byte-compile-top-level-body (cdr (cdr form)) t)) 4221 (byte-compile-top-level-body (cdr (cdr form)) t))
4239 (byte-compile-out 'byte-unwind-protect 0) 4222 (byte-compile-out 'byte-unwind-protect 0)
4379 (progn 4362 (progn
4380 (byte-compile-warn-wrong-args form 2) 4363 (byte-compile-warn-wrong-args form 2)
4381 (byte-compile-normal-call 4364 (byte-compile-normal-call
4382 `(signal 'wrong-number-of-arguments '(,(car form) 4365 `(signal 'wrong-number-of-arguments '(,(car form)
4383 ,(length (cdr form)))))) 4366 ,(length (cdr form))))))
4367 ;; If this form was macroexpanded from `return-from', mark the
4368 ;; corresponding block as having been referenced.
4369 (let* ((symbol (car-safe (cdr-safe (nth 1 form))))
4370 (block (and symbol (symbolp symbol) (get symbol 'cl-block-name)))
4371 (assq (and block (assq block byte-compile-active-blocks))))
4372 (and assq (setcdr assq t)))
4384 (byte-compile-form (nth 1 form)) ;; Push the arguments 4373 (byte-compile-form (nth 1 form)) ;; Push the arguments
4385 (byte-compile-form (nth 2 form)) 4374 (byte-compile-form (nth 2 form))
4386 (byte-compile-out (get (car form) 'byte-opcode) 0) 4375 (byte-compile-out (get (car form) 'byte-opcode) 0)
4387 (pushnew '(null (function-max-args 'throw)) 4376 (pushnew '(null (function-max-args 'throw))
4388 byte-compile-checks-on-load 4377 byte-compile-checks-on-load