Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.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 eac2e6bd5b2c
children 248176c74e6b
comparison
equal deleted inserted replaced
5473:ac37a5f7e5be 5474:4dee0387b9de
4191 4191
4192 (defun byte-compile-catch (form) 4192 (defun byte-compile-catch (form)
4193 "Byte-compile and return a `catch' from. 4193 "Byte-compile and return a `catch' from.
4194 4194
4195 If FORM is the result of macroexpanding a `block' form (the TAG argument is 4195 If FORM is the result of macroexpanding a `block' form (the TAG argument is
4196 a quoted symbol with a non-nil `cl-block-name' property) and there is no 4196 a quoted symbol with a `cl-block-name' property) and there is no
4197 corresponding `return-from' within the block--or equivalently, it was 4197 corresponding `return-from' within the block--or equivalently, it was
4198 optimized away--just byte compile and return the BODY." 4198 optimized away--just byte compile and return the BODY."
4199 (let* ((symbol (car-safe (cdr-safe (nth 1 form)))) 4199 (let* ((symbol (car-safe (cdr-safe (nth 1 form))))
4200 (block (and symbol (symbolp symbol) (get symbol 'cl-block-name))) 4200 (not-present '#:not-present)
4201 (elt (and block (cons block nil))) 4201 (block (and symbol (symbolp symbol)
4202 (get symbol 'cl-block-name not-present)))
4203 (elt (and (not (eq block not-present)) (list block)))
4202 (byte-compile-active-blocks 4204 (byte-compile-active-blocks
4203 (if block 4205 (if elt
4204 (cons elt byte-compile-active-blocks) 4206 (cons elt byte-compile-active-blocks)
4205 byte-compile-active-blocks)) 4207 byte-compile-active-blocks))
4206 (body 4208 (body
4207 (byte-compile-top-level (cons 'progn (cddr form)) 4209 (byte-compile-top-level (cons 'progn (cddr form))
4208 (if block nil for-effect)))) 4210 (and (not elt) for-effect))))
4209 (if (and block (not (cdr elt))) 4211 (if (and elt (not (cdr elt)))
4210 ;; A lexical block without any contained return-from clauses: 4212 ;; A lexical block without any contained return-from clauses:
4211 (byte-compile-form body) 4213 (byte-compile-form body)
4212 ;; A normal catch call, or a lexical block with a contained 4214 ;; A normal catch call, or a lexical block with a contained
4213 ;; return-from clause. 4215 ;; return-from clause.
4214 (byte-compile-form (car (cdr form))) 4216 (byte-compile-form (car (cdr form)))
4364 `(signal 'wrong-number-of-arguments '(,(car form) 4366 `(signal 'wrong-number-of-arguments '(,(car form)
4365 ,(length (cdr form)))))) 4367 ,(length (cdr form))))))
4366 ;; If this form was macroexpanded from `return-from', mark the 4368 ;; If this form was macroexpanded from `return-from', mark the
4367 ;; corresponding block as having been referenced. 4369 ;; corresponding block as having been referenced.
4368 (let* ((symbol (car-safe (cdr-safe (nth 1 form)))) 4370 (let* ((symbol (car-safe (cdr-safe (nth 1 form))))
4369 (block (and symbol (symbolp symbol) (get symbol 'cl-block-name))) 4371 (not-present '#:not-present)
4370 (assq (and block (assq block byte-compile-active-blocks)))) 4372 (block (if (and symbol (symbolp symbol))
4371 (and assq (setcdr assq t))) 4373 (get symbol 'cl-block-name not-present)
4372 (byte-compile-form (nth 1 form)) ;; Push the arguments 4374 not-present))
4373 (byte-compile-form (nth 2 form)) 4375 (assq (and (not (eq block not-present))
4376 (assq block byte-compile-active-blocks))))
4377 (if assq
4378 (setcdr assq t)
4379 (if (not (eq block not-present))
4380 ;; No corresponding enclosing block.
4381 (byte-compile-warn "return-from: no enclosing block named `%s'"
4382 block))))
4383 (mapc 'byte-compile-form (cdr form)) ;; Push the arguments
4374 (byte-compile-out (get (car form) 'byte-opcode) 0) 4384 (byte-compile-out (get (car form) 'byte-opcode) 0)
4375 (pushnew '(null (function-max-args 'throw)) 4385 (pushnew '(null (function-max-args 'throw)) byte-compile-checks-on-load
4376 byte-compile-checks-on-load
4377 :test #'equal))) 4386 :test #'equal)))
4378 4387
4379 ;;; top-level forms elsewhere 4388 ;;; top-level forms elsewhere
4380 4389
4381 (byte-defop-compiler-1 defun) 4390 (byte-defop-compiler-1 defun)