1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-24 10:38:38 +00:00

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

This commit is contained in:
Stefan Monnier 2012-12-06 22:56:57 -05:00
parent f24f2e22aa
commit 4611a3cce7
4 changed files with 68 additions and 4 deletions

View File

@ -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

View File

@ -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.

View File

@ -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" "\

View File

@ -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.