root/trunk/lisp/emacs-lisp/cl-macs.el

;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*-

;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
;;   Free Software Foundation, Inc.

;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; These are extensions to Emacs Lisp that provide a degree of
;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; Bug reports, comments, and suggestions are welcome!

;; This file contains the portions of the Common Lisp extensions
;; package which should be autoloaded, but need only be present
;; if the compiler or interpreter is used---this file is not
;; necessary for executing compiled code.

;; See cl.el for Change Log.


;;; Code:

(or (memq 'cl-19 features)
    (error "Tried to load `cl-macs' before `cl'!"))


(defmacro cl-pop2 (place)
  (list 'prog1 (list 'car (list 'cdr place))
        (list 'setq place (list 'cdr (list 'cdr place)))))
(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)

(defvar cl-optimize-safety)
(defvar cl-optimize-speed)


;;; This kludge allows macros which use cl-transform-function-property
;;; to be called at compile-time.

(require
 (progn
   (or (fboundp 'cl-transform-function-property)
       (defalias 'cl-transform-function-property
         (function (lambda (n p f)
                     (list 'put (list 'quote n) (list 'quote p)
                           (list 'function (cons 'lambda f)))))))
   (car (or features (setq features (list 'cl-kludge))))))


;;; Initialization.

(defvar cl-old-bc-file-form nil)

(defun cl-compile-time-init ()
  (run-hooks 'cl-hack-bytecomp-hook))


;;; Some predicates for analyzing Lisp forms.  These are used by various
;;; macro expanders to optimize the results in certain common cases.

(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
                            car-safe cdr-safe progn prog1 prog2))
(defconst cl-safe-funcs '(* / % length memq list vector vectorp
                          < > <= >= = error))

;;; Check if no side effects, and executes quickly.
(defun cl-simple-expr-p (x &optional size)
  (or size (setq size 10))
  (if (and (consp x) (not (memq (car x) '(quote function function*))))
      (and (symbolp (car x))
           (or (memq (car x) cl-simple-funcs)
               (get (car x) 'side-effect-free))
           (progn
             (setq size (1- size))
             (while (and (setq x (cdr x))
                         (setq size (cl-simple-expr-p (car x) size))))
             (and (null x) (>= size 0) size)))
    (and (> size 0) (1- size))))

(defun cl-simple-exprs-p (xs)
  (while (and xs (cl-simple-expr-p (car xs)))
    (setq xs (cdr xs)))
  (not xs))

;;; Check if no side effects.
(defun cl-safe-expr-p (x)
  (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
      (and (symbolp (car x))
           (or (memq (car x) cl-simple-funcs)
               (memq (car x) cl-safe-funcs)
               (get (car x) 'side-effect-free))
           (progn
             (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
             (null x)))))

;;; Check if constant (i.e., no side effects or dependencies).
(defun cl-const-expr-p (x)
  (cond ((consp x)
         (or (eq (car x) 'quote)
             (and (memq (car x) '(function function*))
                  (or (symbolp (nth 1 x))
                      (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
        ((symbolp x) (and (memq x '(nil t)) t))
        (t t)))

(defun cl-const-exprs-p (xs)
  (while (and xs (cl-const-expr-p (car xs)))
    (setq xs (cdr xs)))
  (not xs))

(defun cl-const-expr-val (x)
  (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))

(defun cl-expr-access-order (x v)
  (if (cl-const-expr-p x) v
    (if (consp x)
        (progn
          (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
          v)
      (if (eq x (car v)) (cdr v) '(t)))))

;;; Count number of times X refers to Y.  Return nil for 0 times.
(defun cl-expr-contains (x y)
  (cond ((equal y x) 1)
        ((and (consp x) (not (memq (car-safe x) '(quote function function*))))
         (let ((sum 0))
           (while x
             (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
           (and (> sum 0) sum)))
        (t nil)))

(defun cl-expr-contains-any (x y)
  (while (and y (not (cl-expr-contains x (car y)))) (pop y))
  y)

;;; Check whether X may depend on any of the symbols in Y.
(defun cl-expr-depends-p (x y)
  (and (not (cl-const-expr-p x))
       (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))

;;; Symbols.

(defvar *gensym-counter*)
(defun gensym (&optional prefix)
  "Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
  (let ((pfix (if (stringp prefix) prefix "G"))
        (num (if (integerp prefix) prefix
               (prog1 *gensym-counter*
                 (setq *gensym-counter* (1+ *gensym-counter*))))))
    (make-symbol (format "%s%d" pfix num))))

(defun gentemp (&optional prefix)
  "Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
  (let ((pfix (if (stringp prefix) prefix "G"))
        name)
    (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*)))
      (setq *gensym-counter* (1+ *gensym-counter*)))
    (intern name)))


;;; Program structure.

(defmacro defun* (name args &rest body)
  "Define NAME as a function.
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
and BODY is implicitly surrounded by (block NAME ...).

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
  (let* ((res (cl-transform-lambda (cons args body) name))
         (form (list* 'defun name (cdr res))))
    (if (car res) (list 'progn (car res) form) form)))

(defmacro defmacro* (name args &rest body)
  "Define NAME as a macro.
Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
and BODY is implicitly surrounded by (block NAME ...).

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
  (let* ((res (cl-transform-lambda (cons args body) name))
         (form (list* 'defmacro name (cdr res))))
    (if (car res) (list 'progn (car res) form) form)))

(defmacro function* (func)
  "Introduce a function.
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
  (if (eq (car-safe func) 'lambda)
      (let* ((res (cl-transform-lambda (cdr func) 'cl-none))
             (form (list 'function (cons 'lambda (cdr res)))))
        (if (car res) (list 'progn (car res) form) form))
    (list 'function func)))

(defun cl-transform-function-property (func prop form)
  (let ((res (cl-transform-lambda form func)))
    (append '(progn) (cdr (cdr (car res)))
            (list (list 'put (list 'quote func) (list 'quote prop)
                        (list 'function (cons 'lambda (cdr res))))))))

(defconst lambda-list-keywords
  '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))

(defvar cl-macro-environment nil)
(defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)

(defun cl-transform-lambda (form bind-block)
  (let* ((args (car form)) (body (cdr form)) (orig-args args)
         (bind-defs nil) (bind-enquote nil)
         (bind-inits nil) (bind-lets nil) (bind-forms nil)
         (header nil) (simple-args nil))
    (while (or (stringp (car body))
               (memq (car-safe (car body)) '(interactive declare)))
      (push (pop body) header))
    (setq args (if (listp args) (copy-list args) (list '&rest args)))
    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
    (if (setq bind-defs (cadr (memq '&cl-defs args)))
        (setq args (delq '&cl-defs (delq bind-defs args))
              bind-defs (cadr bind-defs)))
    (if (setq bind-enquote (memq '&cl-quote args))
        (setq args (delq '&cl-quote args)))
    (if (memq '&whole args) (error "&whole not currently implemented"))
    (let* ((p (memq '&environment args)) (v (cadr p)))
      (if p (setq args (nconc (delq (car p) (delq v args))
                              (list '&aux (list v 'cl-macro-environment))))))
    (while (and args (symbolp (car args))
                (not (memq (car args) '(nil &rest &body &key &aux)))
                (not (and (eq (car args) '&optional)
                          (or bind-defs (consp (cadr args))))))
      (push (pop args) simple-args))
    (or (eq bind-block 'cl-none)
        (setq body (list (list* 'block bind-block body))))
    (if (null args)
        (list* nil (nreverse simple-args) (nconc (nreverse header) body))
      (if (memq '&optional simple-args) (push '&optional args))
      (cl-do-arglist args nil (- (length simple-args)
                                 (if (memq '&optional simple-args) 1 0)))
      (setq bind-lets (nreverse bind-lets))
      (list* (and bind-inits (list* 'eval-when '(compile load eval)
                                    (nreverse bind-inits)))
             (nconc (nreverse simple-args)
                    (list '&rest (car (pop bind-lets))))
             (nconc (let ((hdr (nreverse header)))
                      ;; Macro expansion can take place in the middle of
                      ;; apparently harmless computation, so it should not
                      ;; touch the match-data.
                      (save-match-data
                        (require 'help-fns)
                        (cons (help-add-fundoc-usage
                               (if (stringp (car hdr)) (pop hdr))
                               ;; orig-args can contain &cl-defs (an internal
                               ;; CL thingy I don't understand), so remove it.
                               (let ((x (memq '&cl-defs orig-args)))
                                 (if (null x) orig-args
                                   (delq (car x) (remq (cadr x) orig-args)))))
                              hdr)))
                    (list (nconc (list 'let* bind-lets)
                                 (nreverse bind-forms) body)))))))

(defun cl-do-arglist (args expr &optional num)   ; uses bind-*
  (if (nlistp args)
      (if (or (memq args lambda-list-keywords) (not (symbolp args)))
          (error "Invalid argument name: %s" args)
        (push (list args expr) bind-lets))
    (setq args (copy-list args))
    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
    (let ((p (memq '&body args))) (if p (setcar p '&rest)))
    (if (memq '&environment args) (error "&environment used incorrectly"))
    (let ((save-args args)
          (restarg (memq '&rest args))
          (safety (if (cl-compiling-file) cl-optimize-safety 3))
          (keys nil)
          (laterarg nil) (exactarg nil) minarg)
      (or num (setq num 0))
      (if (listp (cadr restarg))
          (setq restarg (make-symbol "--cl-rest--"))
        (setq restarg (cadr restarg)))
      (push (list restarg expr) bind-lets)
      (if (eq (car args) '&whole)
          (push (list (cl-pop2 args) restarg) bind-lets))
      (let ((p args))
        (setq minarg restarg)
        (while (and p (not (memq (car p) lambda-list-keywords)))
          (or (eq p args) (setq minarg (list 'cdr minarg)))
          (setq p (cdr p)))
        (if (memq (car p) '(nil &aux))
            (setq minarg (list '= (list 'length restarg)
                               (length (ldiff args p)))
                  exactarg (not (eq args p)))))
      (while (and args (not (memq (car args) lambda-list-keywords)))
        (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
                            restarg)))
          (cl-do-arglist
           (pop args)
           (if (or laterarg (= safety 0)) poparg
             (list 'if minarg poparg
                   (list 'signal '(quote wrong-number-of-arguments)
                         (list 'list (and (not (eq bind-block 'cl-none))
                                          (list 'quote bind-block))
                               (list 'length restarg)))))))
        (setq num (1+ num) laterarg t))
      (while (and (eq (car args) '&optional) (pop args))
        (while (and args (not (memq (car args) lambda-list-keywords)))
          (let ((arg (pop args)))
            (or (consp arg) (setq arg (list arg)))
            (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
            (let ((def (if (cdr arg) (nth 1 arg)
                         (or (car bind-defs)
                             (nth 1 (assq (car arg) bind-defs)))))
                  (poparg (list 'pop restarg)))
              (and def bind-enquote (setq def (list 'quote def)))
              (cl-do-arglist (car arg)
                             (if def (list 'if restarg poparg def) poparg))
              (setq num (1+ num))))))
      (if (eq (car args) '&rest)
          (let ((arg (cl-pop2 args)))
            (if (consp arg) (cl-do-arglist arg restarg)))
        (or (eq (car args) '&key) (= safety 0) exactarg
            (push (list 'if restarg
                           (list 'signal '(quote wrong-number-of-arguments)
                                 (list 'list
                                       (and (not (eq bind-block 'cl-none))
                                            (list 'quote bind-block))
                                       (list '+ num (list 'length restarg)))))
                     bind-forms)))
      (while (and (eq (car args) '&key) (pop args))
        (while (and args (not (memq (car args) lambda-list-keywords)))
          (let ((arg (pop args)))
            (or (consp arg) (setq arg (list arg)))
            (let* ((karg (if (consp (car arg)) (caar arg)
                           (intern (format ":%s" (car arg)))))
                   (varg (if (consp (car arg)) (cadar arg) (car arg)))
                   (def (if (cdr arg) (cadr arg)
                          (or (car bind-defs) (cadr (assq varg bind-defs)))))
                   (look (list 'memq (list 'quote karg) restarg)))
              (and def bind-enquote (setq def (list 'quote def)))
              (if (cddr arg)
                  (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
                         (val (list 'car (list 'cdr temp))))
                    (cl-do-arglist temp look)
                    (cl-do-arglist varg
                                   (list 'if temp
                                         (list 'prog1 val (list 'setq temp t))
                                         def)))
                (cl-do-arglist
                 varg
                 (list 'car
                       (list 'cdr
                             (if (null def)
                                 look
                               (list 'or look
                                     (if (eq (cl-const-expr-p def) t)
                                         (list
                                          'quote
                                          (list nil (cl-const-expr-val def)))
                                       (list 'list nil def))))))))
              (push karg keys)))))
      (setq keys (nreverse keys))
      (or (and (eq (car args) '&allow-other-keys) (pop args))
          (null keys) (= safety 0)
          (let* ((var (make-symbol "--cl-keys--"))
                 (allow '(:allow-other-keys))
                 (check (list
                         'while var
                         (list
                          'cond
                          (list (list 'memq (list 'car var)
                                      (list 'quote (append keys allow)))
                                (list 'setq var (list 'cdr (list 'cdr var))))
                          (list (list 'car
                                      (list 'cdr
                                            (list 'memq (cons 'quote allow)
                                                  restarg)))
                                (list 'setq var nil))
                          (list t
                                (list
                                 'error
                                 (format "Keyword argument %%s not one of %s"
                                         keys)
                                 (list 'car var)))))))
            (push (list 'let (list (list var restarg)) check) bind-forms)))
      (while (and (eq (car args) '&aux) (pop args))
        (while (and args (not (memq (car args) lambda-list-keywords)))
          (if (consp (car args))
              (if (and bind-enquote (cadar args))
                  (cl-do-arglist (caar args)
                                 (list 'quote (cadr (pop args))))
                (cl-do-arglist (caar args) (cadr (pop args))))
            (cl-do-arglist (pop args) nil))))
      (if args (error "Malformed argument list %s" save-args)))))

(defun cl-arglist-args (args)
  (if (nlistp args) (list args)
    (let ((res nil) (kind nil) arg)
      (while (consp args)
        (setq arg (pop args))
        (if (memq arg lambda-list-keywords) (setq kind arg)
          (if (eq arg '&cl-defs) (pop args)
            (and (consp arg) kind (setq arg (car arg)))
            (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
            (setq res (nconc res (cl-arglist-args arg))))))
      (nconc res (and args (list args))))))

(defmacro destructuring-bind (args expr &rest body)
  (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
         (bind-defs nil) (bind-block 'cl-none))
    (cl-do-arglist (or args '(&aux)) expr)
    (append '(progn) bind-inits
            (list (nconc (list 'let* (nreverse bind-lets))
                         (nreverse bind-forms) body)))))


;;; The `eval-when' form.

(defvar cl-not-toplevel nil)

(defmacro eval-when (when &rest body)
  "Control when BODY is evaluated.
If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.

\(fn (WHEN...) BODY...)"
  (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
           (not cl-not-toplevel) (not (boundp 'for-effect)))  ; horrible kludge
      (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
            (cl-not-toplevel t))
        (if (or (memq 'load when) (memq :load-toplevel when))
            (if comp (cons 'progn (mapcar 'cl-compile-time-too body))
              (list* 'if nil nil body))
          (progn (if comp (eval (cons 'progn body))) nil)))
    (and (or (memq 'eval when) (memq :execute when))
         (cons 'progn body))))

(defun cl-compile-time-too (form)
  (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
      (setq form (macroexpand
                  form (cons '(eval-when) byte-compile-macro-environment))))
  (cond ((eq (car-safe form) 'progn)
         (cons 'progn (mapcar 'cl-compile-time-too (cdr form))))
        ((eq (car-safe form) 'eval-when)
         (let ((when (nth 1 form)))
           (if (or (memq 'eval when) (memq :execute when))
               (list* 'eval-when (cons 'compile when) (cddr form))
             form)))
        (t (eval form) form)))

(defmacro load-time-value (form &optional read-only)
  "Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
  (if (cl-compiling-file)
      (let* ((temp (gentemp "--cl-load-time--"))
             (set (list 'set (list 'quote temp) form)))
        (if (and (fboundp 'byte-compile-file-form-defmumble)
                 (boundp 'this-kind) (boundp 'that-one))
            (fset 'byte-compile-file-form
                  (list 'lambda '(form)
                        (list 'fset '(quote byte-compile-file-form)
                              (list 'quote
                                    (symbol-function 'byte-compile-file-form)))
                        (list 'byte-compile-file-form (list 'quote set))
                        '(byte-compile-file-form form)))
          (print set (symbol-value 'outbuffer)))
        (list 'symbol-value (list 'quote temp)))
    (list 'quote (eval form))))


;;; Conditional control structures.

(defmacro case (expr &rest clauses)
  "Eval EXPR and choose among clauses on that value.
Each clause looks like (KEYLIST BODY...).  EXPR is evaluated and compared
against each key in each KEYLIST; the corresponding BODY is evaluated.
If no clause succeeds, case returns nil.  A single atom may be used in
place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
allowed only in the final clause, and matches if no other keys match.
Key values are compared by `eql'.
\n(fn EXPR (KEYLIST BODY...)...)"
  (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
         (head-list nil)
         (body (cons
                'cond
                (mapcar
                 (function
                  (lambda (c)
                    (cons (cond ((memq (car c) '(t otherwise)) t)
                                ((eq (car c) 'ecase-error-flag)
                                 (list 'error "ecase failed: %s, %s"
                                       temp (list 'quote (reverse head-list))))
                                ((listp (car c))
                                 (setq head-list (append (car c) head-list))
                                 (list 'member* temp (list 'quote (car c))))
                                (t
                                 (if (memq (car c) head-list)
                                     (error "Duplicate key in case: %s"
                                            (car c)))
                                 (push (car c) head-list)
                                 (list 'eql temp (list 'quote (car c)))))
                          (or (cdr c) '(nil)))))
                 clauses))))
    (if (eq temp expr) body
      (list 'let (list (list temp expr)) body))))

(defmacro ecase (expr &rest clauses)
  "Like `case', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
  (list* 'case expr (append clauses '((ecase-error-flag)))))

(defmacro typecase (expr &rest clauses)
  "Evals EXPR, chooses among clauses on that value.
Each clause looks like (TYPE BODY...).  EXPR is evaluated and, if it
satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
  (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
         (type-list nil)
         (body (cons
                'cond
                (mapcar
                 (function
                  (lambda (c)
                    (cons (cond ((eq (car c) 'otherwise) t)
                                ((eq (car c) 'ecase-error-flag)
                                 (list 'error "etypecase failed: %s, %s"
                                       temp (list 'quote (reverse type-list))))
                                (t
                                 (push (car c) type-list)
                                 (cl-make-type-test temp (car c))))
                          (or (cdr c) '(nil)))))
                 clauses))))
    (if (eq temp expr) body
      (list 'let (list (list temp expr)) body))))

(defmacro etypecase (expr &rest clauses)
  "Like `typecase', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
  (list* 'typecase expr (append clauses '((ecase-error-flag)))))


;;; Blocks and exits.

(defmacro block (name &rest body)
  "Define a lexically-scoped block named NAME.
NAME may be any symbol.  Code inside the BODY forms can call `return-from'
to jump prematurely out of the block.  This differs from `catch' and `throw'
in two respects:  First, the NAME is an unevaluated symbol rather than a
quoted symbol or other form; and second, NAME is lexically rather than
dynamically scoped:  Only references to it within BODY will work.  These
references may appear inside macro expansions, but not inside functions
called from BODY."
  (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body)
    (list 'cl-block-wrapper
          (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
                 body))))

(defvar cl-active-block-names nil)

(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
(defun cl-byte-compile-block (cl-form)
  (if (fboundp 'byte-compile-form-do-effect)  ; Check for optimizing compiler
      (progn
        (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
               (cl-active-block-names (cons cl-entry cl-active-block-names))
               (cl-body (byte-compile-top-level
                         (cons 'progn (cddr (nth 1 cl-form))))))
          (if (cdr cl-entry)
              (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
            (byte-compile-form cl-body))))
    (byte-compile-form (nth 1 cl-form))))

(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
(defun cl-byte-compile-throw (cl-form)
  (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
    (if cl-found (setcdr cl-found t)))
  (byte-compile-normal-call (cons 'throw (cdr cl-form))))

(defmacro return (&optional result)
  "Return from the block named nil.
This is equivalent to `(return-from nil RESULT)'."
  (list 'return-from nil result))

(defmacro return-from (name &optional result)
  "Return from the block named NAME.
This jump out to the innermost enclosing `(block NAME ...)' form,
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
  (let ((name2 (intern (format "--cl-block-%s--" name))))
    (list 'cl-block-throw (list 'quote name2) result)))


;;; The "loop" macro.

(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
(defvar loop-result) (defvar loop-result-explicit)
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)

(defmacro loop (&rest args)
  "The Common Lisp `loop' macro.
Valid clauses are:
  for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
  for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
  for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,
  always COND, never COND, thereis COND, collect EXPR into VAR,
  append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,
  count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,
  if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
  unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
  do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
  finally return EXPR, named NAME.

\(fn CLAUSE...)"
  (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
      (list 'block nil (list* 'while t args))
    (let ((loop-name nil)       (loop-bindings nil)
          (loop-body nil)       (loop-steps nil)
          (loop-result nil)     (loop-result-explicit nil)
          (loop-result-var nil) (loop-finish-flag nil)
          (loop-accum-var nil)  (loop-accum-vars nil)
          (loop-initially nil)  (loop-finally nil)
          (loop-map-form nil)   (loop-first-flag nil)
          (loop-destr-temps nil) (loop-symbol-macs nil))
      (setq args (append args '(cl-end-loop)))
      (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
      (if loop-finish-flag
          (push `((,loop-finish-flag t)) loop-bindings))
      (if loop-first-flag
          (progn (push `((,loop-first-flag t)) loop-bindings)
                 (push `(setq ,loop-first-flag nil) loop-steps)))
      (let* ((epilogue (nconc (nreverse loop-finally)
                              (list (or loop-result-explicit loop-result))))
             (ands (cl-loop-build-ands (nreverse loop-body)))
             (while-body (nconc (cadr ands) (nreverse loop-steps)))
             (body (append
                    (nreverse loop-initially)
                    (list (if loop-map-form
                              (list 'block '--cl-finish--
                                    (subst
                                     (if (eq (car ands) t) while-body
                                       (cons `(or ,(car ands)
                                                  (return-from --cl-finish--
                                                    nil))
                                             while-body))
                                     '--cl-map loop-map-form))
                            (list* 'while (car ands) while-body)))
                    (if loop-finish-flag
                        (if (equal epilogue '(nil)) (list loop-result-var)
                          `((if ,loop-finish-flag
                                (progn ,@epilogue) ,loop-result-var)))
                      epilogue))))
        (if loop-result-var (push (list loop-result-var) loop-bindings))
        (while loop-bindings
          (if (cdar loop-bindings)
              (setq body (list (cl-loop-let (pop loop-bindings) body t)))
            (let ((lets nil))
              (while (and loop-bindings
                          (not (cdar loop-bindings)))
                (push (car (pop loop-bindings)) lets))
              (setq body (list (cl-loop-let lets body nil))))))
        (if loop-symbol-macs
            (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
        (list* 'block loop-name body)))))

(defun cl-parse-loop-clause ()          ; uses args, loop-*
  (let ((word (pop args))
        (hash-types '(hash-key hash-keys hash-value hash-values))
        (key-types '(key-code key-codes key-seq key-seqs
                     key-binding key-bindings)))
    (cond

     ((null args)
      (error "Malformed `loop' macro"))

     ((eq word 'named)
      (setq loop-name (pop args)))

     ((eq word 'initially)
      (if (memq (car args) '(do doing)) (pop args))
      (or (consp (car args)) (error "Syntax error on `initially' clause"))
      (while (consp (car args))
        (push (pop args) loop-initially)))

     ((eq word 'finally)
      (if (eq (car args) 'return)
          (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
        (if (memq (car args) '(do doing)) (pop args))
        (or (consp (car args)) (error "Syntax error on `finally' clause"))
        (if (and (eq (caar args) 'return) (null loop-name))
            (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
          (while (consp (car args))
            (push (pop args) loop-finally)))))

     ((memq word '(for as))
      (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
            (ands nil))
        (while
            ;; Use `gensym' rather than `make-symbol'.  It's important that
            ;; (not (eq (symbol-name var1) (symbol-name var2))) because
            ;; these vars get added to the cl-macro-environment.
            (let ((var (or (pop args) (gensym "--cl-var--"))))
              (setq word (pop args))
              (if (eq word 'being) (setq word (pop args)))
              (if (memq word '(the each)) (setq word (pop args)))
              (if (memq word '(buffer buffers))
                  (setq word 'in args (cons '(buffer-list) args)))
              (cond

               ((memq word '(from downfrom upfrom to downto upto
                             above below by))
                (push word args)
                (if (memq (car args) '(downto above))
                    (error "Must specify `from' value for downward loop"))
                (let* ((down (or (eq (car args) 'downfrom)
                                 (memq (caddr args) '(downto above))))
                       (excl (or (memq (car args) '(above below))
                                 (memq (caddr args) '(above below))))
                       (start (and (memq (car args) '(from upfrom downfrom))
                                   (cl-pop2 args)))
                       (end (and (memq (car args)
                                       '(to upto downto above below))
                                 (cl-pop2 args)))
                       (step (and (eq (car args) 'by) (cl-pop2 args)))
                       (end-var (and (not (cl-const-expr-p end))
                                     (make-symbol "--cl-var--")))
                       (step-var (and (not (cl-const-expr-p step))