* lisp/emacs-lisp/cl-macs.el (cl-tagbody): New macro.

etc/NEWS

@@ -29,6 +29,7 @@ so we will look at it and add it to the manual.
 
 * Changes in Specialized Modes and Packages in Emacs 24.4
 
+** New macro cl-tagbody in cl-lib.
 ** Calc
 
 *** Calc by default now uses the Gregorian calendar for all dates, and

lisp/ChangeLog

@@ -1,3 +1,7 @@
+2012-12-07  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	* emacs-lisp/cl-macs.el (cl-tagbody): New macro.
+
 2012-12-06  Stefan Monnier  <monnier@iro.umontreal.ca>
 
 	Further cleanup of the "cl-" namespace.  Fit CL in 80 columns.

lisp/emacs-lisp/cl-loaddefs.el

@@ -262,12 +262,12 @@ including `cl-block' and `cl-eval-when'.
 ;;;;;;  cl-rotatef cl-shiftf cl-remf cl-psetf cl-declare cl-the cl-locally
 ;;;;;;  cl-multiple-value-setq cl-multiple-value-bind cl-symbol-macrolet
 ;;;;;;  cl-macrolet cl-labels cl-flet* cl-flet cl-progv cl-psetq
-;;;;;;  cl-do-all-symbols cl-do-symbols cl-dotimes cl-dolist cl-do*
-;;;;;;  cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase
+;;;;;;  cl-do-all-symbols cl-do-symbols cl-tagbody cl-dotimes cl-dolist
+;;;;;;  cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase
 ;;;;;;  cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
 ;;;;;;  cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
 ;;;;;;  cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
-;;;;;;  "cl-macs" "cl-macs.el" "5df0692d7c4bffb2cc353f802d94f796")
+;;;;;;  "cl-macs" "cl-macs.el" "d3af72b1cff3398fa1480065fc2887a2")
 ;;; Generated autoloads from cl-macs.el
 
 (autoload 'cl--compiler-macro-list* "cl-macs" "\
@@ -465,6 +465,19 @@ nil.
 
 (put 'cl-dotimes 'lisp-indent-function '1)
 
+(autoload 'cl-tagbody "cl-macs" "\
+Execute statements while providing for control transfers to labels.
+Each element of LABELS-OR-STMTS can be either a label (integer or symbol)
+or a `cons' cell, in which case it's taken to be a statement.
+This distinction is made before performing macroexpansion.
+Statements are executed in sequence left to right, discarding any return value,
+stopping only when reaching the end of LABELS-OR-STMTS.
+Any statement can transfer control at any time to the statements that follow
+one of the labels with the special form (go LABEL).
+Labels have lexical scope and dynamic extent.
+
+\(fn &rest LABELS-OR-STMTS)" nil t)
+
 (autoload 'cl-do-symbols "cl-macs" "\
 Loop over all symbols.
 Evaluate BODY with VAR bound to each interned symbol, or to each symbol
@@ -759,7 +772,7 @@ surrounded by (cl-block NAME ...).
 ;;;;;;  cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if
 ;;;;;;  cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not
 ;;;;;;  cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove
-;;;;;;  cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "697d04e7ae0a9b9c15eea705b359b1bb")
+;;;;;;  cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "4b8ddc5bea2fcc626526ce3644071568")
 ;;; Generated autoloads from cl-seq.el
 
 (autoload 'cl-reduce "cl-seq" "\

lisp/emacs-lisp/cl-macs.el

@@ -1611,6 +1611,52 @@ nil.
     (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes)
         loop `(cl-block nil ,loop))))
 
+(defvar cl--tagbody-alist nil)
+
+;;;###autoload
+(defmacro cl-tagbody (&rest labels-or-stmts)
+  "Execute statements while providing for control transfers to labels.
+Each element of LABELS-OR-STMTS can be either a label (integer or symbol)
+or a `cons' cell, in which case it's taken to be a statement.
+This distinction is made before performing macroexpansion.
+Statements are executed in sequence left to right, discarding any return value,
+stopping only when reaching the end of LABELS-OR-STMTS.
+Any statement can transfer control at any time to the statements that follow
+one of the labels with the special form (go LABEL).
+Labels have lexical scope and dynamic extent."
+  (let ((blocks '())
+        (first-label (if (consp (car labels-or-stmts))
+                       'cl--preamble (pop labels-or-stmts))))
+    (let ((block (list first-label)))
+      (dolist (label-or-stmt labels-or-stmts)
+        (if (consp label-or-stmt) (push label-or-stmt block)
+          ;; Add a "go to next block" to implement the fallthrough.
+          (unless (eq 'go (car-safe (car-safe block)))
+            (push `(go ,label-or-stmt) block))
+          (push (nreverse block) blocks)
+          (setq block (list label-or-stmt))))
+      (unless (eq 'go (car-safe (car-safe block)))
+        (push `(go cl--exit) block))
+      (push (nreverse block) blocks))
+    (let ((catch-tag (make-symbol "cl--tagbody-tag")))
+      (push (cons 'cl--exit catch-tag) cl--tagbody-alist)
+      (dolist (block blocks)
+        (push (cons (car block) catch-tag) cl--tagbody-alist))
+      (macroexpand-all
+       `(let ((next-label ',first-label))
+          (while
+              (not (eq (setq next-label
+                             (catch ',catch-tag
+                               (cl-case next-label
+                                 ,@blocks)))
+                       'cl--exit))))
+       `((go . ,(lambda (label)
+                  (let ((catch-tag (cdr (assq label cl--tagbody-alist))))
+                    (unless catch-tag
+                      (error "Unknown cl-tagbody go label `%S'" label))
+                    `(throw ',catch-tag ',label))))
+         ,@macroexpand-all-environment)))))
+
 ;;;###autoload
 (defmacro cl-do-symbols (spec &rest body)
   "Loop over all symbols.