Commit d5c6faf9 authored by Stefan Monnier's avatar Stefan Monnier

* lisp/emacs-lisp/cl.el (flet): Mark obsolete.

* lisp/emacs-lisp/cl-macs.el (cl-flet*): New macro.
* lisp/vc/vc-rcs.el (vc-rcs-annotate-command, vc-rcs-parse):
* lisp/progmodes/js.el (js-c-fill-paragraph):
* lisp/progmodes/ebrowse.el (ebrowse-switch-member-buffer-to-sibling-class)
(ebrowse-switch-member-buffer-to-derived-class):
* test/automated/ert-x-tests.el (ert-test-run-tests-interactively-2):
* lisp/play/5x5.el (5x5-solver): Use cl-flet.

Fixes: debbugs:11780
parent 7b953864
2012-06-27 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl.el (flet): Mark obsolete.
* emacs-lisp/cl-macs.el (cl-flet*): New macro.
* vc/vc-rcs.el (vc-rcs-annotate-command, vc-rcs-parse):
* progmodes/js.el (js-c-fill-paragraph):
* progmodes/ebrowse.el (ebrowse-switch-member-buffer-to-sibling-class)
(ebrowse-switch-member-buffer-to-derived-class):
* play/5x5.el (5x5-solver): Use cl-flet.
* emacs-lisp/cl.el: Use lexical-binding. Fix flet (bug#11780).
(cl--symbol-function): New macro.
(cl--letf, cl--letf*): Use it.
......
......@@ -260,12 +260,12 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
;;;;;; cl-deftype cl-defstruct cl-callf2 cl-callf 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-progv cl-psetq cl-do-all-symbols cl-do-symbols
;;;;;; 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-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-macs" "cl-macs.el"
;;;;;; "41a15289eda7e6ae03ac9edd86bbb1a6")
;;;;;; "e7bb76130254614df1603a1c1e89cb49")
;;; Generated autoloads from cl-macs.el
(autoload 'cl-gensym "cl-macs" "\
......@@ -492,6 +492,14 @@ Like `cl-labels' but the definitions are not recursive.
(put 'cl-flet 'lisp-indent-function '1)
(autoload 'cl-flet* "cl-macs" "\
Make temporary function definitions.
Like `cl-flet' but the definitions can refer to previous ones.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t)
(put 'cl-flet* 'lisp-indent-function '1)
(autoload 'cl-labels "cl-macs" "\
Make temporary function bindings.
The bindings can be recursive. Assumes the use of `lexical-binding'.
......
......@@ -1570,7 +1570,6 @@ a `let' form, except that the list of symbols can be computed at run-time."
(setq cl--labels-convert-cache (cons f res))
res))))))
;;; This should really have some way to shadow 'byte-compile properties, etc.
;;;###autoload
(defmacro cl-flet (bindings &rest body)
"Make temporary function definitions.
......@@ -1595,6 +1594,18 @@ Like `cl-labels' but the definitions are not recursive.
(if (assq 'function newenv) newenv
(cons (cons 'function #'cl--labels-convert) newenv)))))))
;;;###autoload
(defmacro cl-flet* (bindings &rest body)
"Make temporary function definitions.
Like `cl-flet' but the definitions can refer to previous ones.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body)))
(cond
((null bindings) (macroexp-progn body))
((null (cdr bindings)) `(cl-flet ,bindings ,@body))
(t `(cl-flet (,(pop bindings)) (cl-flet* ,bindings ,@body)))))
;;;###autoload
(defmacro cl-labels (bindings &rest body)
"Make temporary function bindings.
......@@ -2257,6 +2268,7 @@ STRING is an optional description of the desired type."
;;;###autoload
(defmacro cl-assert (form &optional show-args string &rest args)
;; FIXME: This is actually not compatible with Common-Lisp's `assert'.
"Verify that FORM returns non-nil; signal an error if not.
Second arg SHOW-ARGS means to include arguments of FORM in message.
Other args STRING and ARGS... are arguments to be passed to `error'.
......
......@@ -461,11 +461,13 @@ Common Lisp.
;; This should really have some way to shadow 'byte-compile properties, etc.
(defmacro flet (bindings &rest body)
"Make temporary function definitions.
This is an analogue of `let' that operates on the function cell of FUNC
rather than its value cell. The FORMs are evaluated with the specified
function definitions in place, then the definitions are undone (the FUNCs
go back to their previous definitions, or lack thereof).
"Make temporary overriding function definitions.
This is an analogue of a dynamically scoped `let' that operates on the function
cell of FUNCs rather than their value cell.
If you want the Common-Lisp style of `flet', you should use `cl-flet'.
The FORMs are evaluated with the specified function definitions in place,
then the definitions are undone (the FUNCs go back to their previous
definitions, or lack thereof).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet))
......@@ -491,6 +493,7 @@ will not work - use `labels' instead" (symbol-name (car x))))
(list `(symbol-function ',(car x)) func)))
bindings)
,@body))
(make-obsolete 'flet "Use either `cl-flet' or `letf'." "24.2")
(defmacro labels (bindings &rest body)
"Make temporary function bindings.
......
......@@ -568,14 +568,14 @@ to complete the 5x5.
Solutions are sorted from least to greatest Hamming weight."
(require 'calc-ext)
(flet ((5x5-mat-mode-2
(a)
(math-map-vec
(lambda (y)
(math-map-vec
(lambda (x) `(mod ,x 2))
y))
a)))
(cl-flet ((5x5-mat-mode-2
(a)
(math-map-vec
(lambda (y)
(math-map-vec
(lambda (x) `(mod ,x 2))
y))
a)))
(let* (calc-command-flags
(grid-size-squared (* 5x5-grid-size 5x5-grid-size))
......@@ -658,8 +658,8 @@ Solutions are sorted from least to greatest Hamming weight."
(cdr (5x5-mat-mode-2
'(vec (vec 0 1 1 1 0 1 0 1 0 1 1 1 0 1
1 1 0 1 0 1 0 1 1 1 0)
(vec 1 1 0 1 1 0 0 0 0 0 1 1 0 1
1 0 0 0 0 0 1 1 0 1 1)))))
(vec 1 1 0 1 1 0 0 0 0 0 1 1 0 1
1 0 0 0 0 0 1 1 0 1 1)))))
(calcFunc-trn id))))
(inv-base-change
......
......@@ -2957,10 +2957,10 @@ Prefix arg INC specifies which one."
(let ((containing-list ebrowse--tree)
index cls
(supers (ebrowse-direct-base-classes ebrowse--displayed-class)))
(flet ((trees-alist (trees)
(loop for tr in trees
collect (cons (ebrowse-cs-name
(ebrowse-ts-class tr)) tr))))
(cl-flet ((trees-alist (trees)
(loop for tr in trees
collect (cons (ebrowse-cs-name
(ebrowse-ts-class tr)) tr))))
(when supers
(let ((tree (if (second supers)
(ebrowse-completing-read-value
......@@ -2985,11 +2985,11 @@ Prefix arg INC specifies which one."
Prefix arg ARG says which class should be displayed. Default is
the first derived class."
(interactive "P")
(flet ((ebrowse-tree-obarray-as-alist ()
(loop for s in (ebrowse-ts-subclasses
ebrowse--displayed-class)
collect (cons (ebrowse-cs-name
(ebrowse-ts-class s)) s))))
(cl-flet ((ebrowse-tree-obarray-as-alist ()
(loop for s in (ebrowse-ts-subclasses
ebrowse--displayed-class)
collect (cons (ebrowse-cs-name
(ebrowse-ts-class s)) s))))
(let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class)
(error "No derived classes"))))
(if (and arg (second subs))
......
......@@ -1821,15 +1821,15 @@ nil."
(defun js-c-fill-paragraph (&optional justify)
"Fill the paragraph with `c-fill-paragraph'."
(interactive "*P")
(flet ((c-forward-sws
(&optional limit)
(js--forward-syntactic-ws limit))
(c-backward-sws
(&optional limit)
(js--backward-syntactic-ws limit))
(c-beginning-of-macro
(&optional limit)
(js--beginning-of-macro limit)))
(letf (((symbol-function 'c-forward-sws)
(lambda (&optional limit)
(js--forward-syntactic-ws limit)))
((symbol-function 'c-backward-sws)
(lambda (&optional limit)
(js--backward-syntactic-ws limit)))
((symbol-function 'c-beginning-of-macro)
(lambda (&optional limit)
(js--beginning-of-macro limit))))
(let ((fill-paragraph-function 'c-fill-paragraph))
(c-fill-paragraph justify))))
......
......@@ -3380,21 +3380,23 @@ Use `math-format-value' as a printer for Calc objects."
(setq iter (cdr iter))))
(setq result ret)))
(flet ((vectorize-*1
(clean result)
(cons clean (cons (quote 'vec) (apply 'append result))))
(vectorize-*2
(clean result)
(cons clean (cons (quote 'vec) (mapcar (lambda (x)
(cons clean (cons (quote 'vec) x)))
result)))))
(cl-flet ((vectorize-*1
(clean result)
(cons clean (cons (quote 'vec) (apply 'append result))))
(vectorize-*2
(clean result)
(cons clean (cons (quote 'vec)
(mapcar (lambda (x)
(cons clean (cons (quote 'vec) x)))
result)))))
(case vectorize
((nil) (cons clean (apply 'append result)))
((*1) (vectorize-*1 clean result))
((*2) (vectorize-*2 clean result))
((*) (if (cdr result)
(vectorize-*2 clean result)
(vectorize-*1 clean result)))))))
((*) (funcall (if (cdr result)
#'vectorize-*2
#'vectorize-*1)
clean result))))))
(defun ses-delete-blanks (&rest args)
"Return ARGS reversed, with the blank elements (nil and *skip*) removed."
......
......@@ -679,9 +679,9 @@ Optional arg REVISION is a revision to annotate from."
;; Apply reverse-chronological edits on the trunk, computing and
;; accumulating forward-chronological edits after some point, for
;; later.
(flet ((r/d/a () (vector pre
(cdr (assq 'date meta))
(cdr (assq 'author meta)))))
(cl-flet ((r/d/a () (vector pre
(cdr (assq 'date meta))
(cdr (assq 'author meta)))))
(while (when (setq pre cur cur (cdr (assq 'next meta)))
(not (string= "" cur)))
(setq
......@@ -769,16 +769,16 @@ Optional arg REVISION is a revision to annotate from."
ht)
(setq maxw (max w maxw))))
(let ((padding (make-string maxw 32)))
(flet ((pad (w) (substring-no-properties padding w))
(render (rda &rest ls)
(propertize
(apply 'concat
(format-time-string "%Y-%m-%d" (aref rda 1))
" "
(aref rda 0)
ls)
:vc-annotate-prefix t
:vc-rcs-r/d/a rda)))
(cl-flet ((pad (w) (substring-no-properties padding w))
(render (rda &rest ls)
(propertize
(apply 'concat
(format-time-string "%Y-%m-%d" (aref rda 1))
" "
(aref rda 0)
ls)
:vc-annotate-prefix t
:vc-rcs-r/d/a rda)))
(maphash
(if all-me
(lambda (rda w)
......@@ -1306,50 +1306,51 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
;; to "de-@@-format" the printed representation as the first step
;; to translating it into some value. See internal func `gather'.
@-holes)
(flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]'
(at (tag) (save-excursion (eq tag (read buffer))))
(to-eol () (buffer-substring-no-properties
(point) (progn (forward-line 1)
(1- (point)))))
(to-semi () (setq b (point)
e (progn (search-forward ";")
(1- (point)))))
(to-one@ () (setq @-holes nil
b (progn (search-forward "@") (point))
e (progn (while (and (search-forward "@")
(= ?@ (char-after))
(progn
(push (point) @-holes)
(forward-char 1)
(push (point) @-holes))))
(1- (point)))))
(tok+val (set-b+e name &optional proc)
(unless (eq name (setq tok (read buffer)))
(error "Missing `%s' while parsing %s" name context))
(sw)
(funcall set-b+e)
(cons tok (if proc
(funcall proc)
(buffer-substring-no-properties b e))))
(k-semi (name &optional proc) (tok+val 'to-semi name proc))
(gather () (let ((pairs `(,e ,@@-holes ,b))
acc)
(while pairs
(push (buffer-substring-no-properties
(cadr pairs) (car pairs))
acc)
(setq pairs (cddr pairs)))
(apply 'concat acc)))
(k-one@ (name &optional later) (tok+val 'to-one@ name
(if later
(lambda () t)
'gather))))
(cl-flet*
((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]'
(at (tag) (save-excursion (eq tag (read buffer))))
(to-eol () (buffer-substring-no-properties
(point) (progn (forward-line 1)
(1- (point)))))
(to-semi () (setq b (point)
e (progn (search-forward ";")
(1- (point)))))
(to-one@ () (setq @-holes nil
b (progn (search-forward "@") (point))
e (progn (while (and (search-forward "@")
(= ?@ (char-after))
(progn
(push (point) @-holes)
(forward-char 1)
(push (point) @-holes))))
(1- (point)))))
(tok+val (set-b+e name &optional proc)
(unless (eq name (setq tok (read buffer)))
(error "Missing `%s' while parsing %s" name context))
(sw)
(funcall set-b+e)
(cons tok (if proc
(funcall proc)
(buffer-substring-no-properties b e))))
(k-semi (name &optional proc) (tok+val #'to-semi name proc))
(gather () (let ((pairs `(,e ,@@-holes ,b))
acc)
(while pairs
(push (buffer-substring-no-properties
(cadr pairs) (car pairs))
acc)
(setq pairs (cddr pairs)))
(apply 'concat acc)))
(k-one@ (name &optional later) (tok+val #'to-one@ name
(if later
(lambda () t)
#'gather))))
(save-excursion
(goto-char (point-min))
;; headers
(setq context 'headers)
(flet ((hpush (name &optional proc)
(push (k-semi name proc) headers)))
(cl-flet ((hpush (name &optional proc)
(push (k-semi name proc) headers)))
(hpush 'head)
(when (at 'branch)
(hpush 'branch))
......@@ -1391,7 +1392,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
(when (< (car ls) 100)
(setcar ls (+ 1900 (car ls))))
(apply 'encode-time (nreverse ls)))))
,@(mapcar 'k-semi '(author state))
,@(mapcar #'k-semi '(author state))
,(k-semi 'branches
(lambda ()
(split-string
......@@ -1421,16 +1422,17 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
;; only the former since it behaves identically to the
;; latter in the absence of "@@".)
sub)
(flet ((incg (beg end) (let ((b beg) (e end) @-holes)
(while (and asc (< (car asc) e))
(push (pop asc) @-holes))
;; Self-deprecate when work is done.
;; Folding many dimensions into one.
;; Thanks B.Mandelbrot, for complex sum.
;; O beauteous math! --the Unvexed Bum
(unless asc
(setq sub 'buffer-substring-no-properties))
(gather))))
(cl-flet ((incg (beg end)
(let ((b beg) (e end) @-holes)
(while (and asc (< (car asc) e))
(push (pop asc) @-holes))
;; Self-deprecate when work is done.
;; Folding many dimensions into one.
;; Thanks B.Mandelbrot, for complex sum.
;; O beauteous math! --the Unvexed Bum
(unless asc
(setq sub #'buffer-substring-no-properties))
(gather))))
(while (and (sw)
(not (eobp))
(setq context (to-eol)
......@@ -1449,8 +1451,8 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
(setcdr (cadr rev) (gather))
(if @-holes
(setq asc (nreverse @-holes)
sub 'incg)
(setq sub 'buffer-substring-no-properties))
sub #'incg)
(setq sub #'buffer-substring-no-properties))
(goto-char b)
(setq acc nil)
(while (< (point) e)
......
2012-06-27 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/ert-x-tests.el (ert-test-run-tests-interactively-2):
Use cl-flet.
2012-06-08 Ulf Jasper <ulf.jasper@web.de>
* automated/icalendar-tests.el (icalendar--parse-vtimezone): Test
escaped commas in TZID (Bug#11473).
* automated/icalendar-tests.el (icalendar--parse-vtimezone):
Test escaped commas in TZID (Bug#11473).
(icalendar-import-with-timezone): New.
(icalendar-real-world): Add new testcase as given in the bugreport
of Bug#11473.
......@@ -332,8 +337,8 @@
2009-12-18 Ulf Jasper <ulf.jasper@web.de>
* icalendar-testsuite.el
(icalendar-testsuite--run-function-tests): Add
icalendar-testsuite--test-parse-vtimezone.
(icalendar-testsuite--run-function-tests):
Add icalendar-testsuite--test-parse-vtimezone.
(icalendar-testsuite--test-parse-vtimezone): New.
(icalendar-testsuite--do-test-cycle): Doc changes.
(icalendar-testsuite--run-real-world-tests): Remove trailing
......@@ -375,7 +380,7 @@
2008-10-31 Ulf Jasper <ulf.jasper@web.de>
* icalendar-testsuite.el (icalendar-testsuite--run-function-tests):
Added `icalendar-testsuite--test-create-uid'.
Add `icalendar-testsuite--test-create-uid'.
(icalendar-testsuite--test-create-uid): New.
2008-06-14 Ulf Jasper <ulf.jasper@web.de>
......
......@@ -103,79 +103,79 @@
(ert-deftest ert-test-run-tests-interactively-2 ()
:tags '(:causes-redisplay)
(let ((passing-test (make-ert-test :name 'passing-test
:body (lambda () (ert-pass))))
(failing-test (make-ert-test :name 'failing-test
:body (lambda ()
(ert-info ((propertize "foo\nbar"
'a 'b))
(ert-fail
"failure message"))))))
(let ((ert-debug-on-error nil))
(let* ((buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
(messages nil)
(mock-message-fn
(lambda (format-string &rest args)
(push (apply #'format format-string args) messages))))
(flet ((expected-string (with-font-lock-p)
(ert-propertized-string
"Selector: (member <passing-test> <failing-test>)\n"
"Passed: 1\n"
"Failed: 1 (1 unexpected)\n"
"Total: 2/2\n\n"
"Started at:\n"
"Finished.\n"
"Finished at:\n\n"
`(category ,(button-category-symbol
'ert--results-progress-bar-button)
button (t)
face ,(if with-font-lock-p
'ert-test-result-unexpected
'button))
".F" nil "\n\n"
`(category ,(button-category-symbol
'ert--results-expand-collapse-button)
button (t)
face ,(if with-font-lock-p
'ert-test-result-unexpected
'button))
"F" nil " "
`(category ,(button-category-symbol
'ert--test-name-button)
button (t)
ert-test-name failing-test)
"failing-test"
nil "\n Info: " '(a b) "foo\n"
nil " " '(a b) "bar"
nil "\n (ert-test-failed \"failure message\")\n\n\n"
)))
(save-window-excursion
(unwind-protect
(let ((case-fold-search nil))
(ert-run-tests-interactively
`(member ,passing-test ,failing-test) buffer-name
mock-message-fn)
(should (equal messages `(,(concat
"Ran 2 tests, 1 results were "
"as expected, 1 unexpected"))))
(with-current-buffer buffer-name
(font-lock-mode 0)
(should (ert-equal-including-properties
(ert-filter-string (buffer-string)
'("Started at:\\(.*\\)$" 1)
'("Finished at:\\(.*\\)$" 1))
(expected-string nil)))
;; `font-lock-mode' only works if interactive, so
;; pretend we are.
(let ((noninteractive nil))
(font-lock-mode 1))
(should (ert-equal-including-properties
(ert-filter-string (buffer-string)
'("Started at:\\(.*\\)$" 1)
'("Finished at:\\(.*\\)$" 1))
(expected-string t)))))
(when (get-buffer buffer-name)
(kill-buffer buffer-name)))))))))
(let* ((passing-test (make-ert-test :name 'passing-test
:body (lambda () (ert-pass))))
(failing-test (make-ert-test :name 'failing-test
:body (lambda ()
(ert-info ((propertize "foo\nbar"
'a 'b))
(ert-fail
"failure message")))))
(ert-debug-on-error nil)
(buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
(messages nil)
(mock-message-fn
(lambda (format-string &rest args)
(push (apply #'format format-string args) messages))))
(cl-flet ((expected-string (with-font-lock-p)
(ert-propertized-string
"Selector: (member <passing-test> <failing-test>)\n"
"Passed: 1\n"
"Failed: 1 (1 unexpected)\n"
"Total: 2/2\n\n"
"Started at:\n"
"Finished.\n"
"Finished at:\n\n"
`(category ,(button-category-symbol
'ert--results-progress-bar-button)
button (t)
face ,(if with-font-lock-p
'ert-test-result-unexpected
'button))
".F" nil "\n\n"
`(category ,(button-category-symbol
'ert--results-expand-collapse-button)
button (t)
face ,(if with-font-lock-p
'ert-test-result-unexpected
'button))
"F" nil " "
`(category ,(button-category-symbol
'ert--test-name-button)
button (t)
ert-test-name failing-test)
"failing-test"
nil "\n Info: " '(a b) "foo\n"
nil " " '(a b) "bar"
nil "\n (ert-test-failed \"failure message\")\n\n\n"
)))
(save-window-excursion
(unwind-protect
(let ((case-fold-search nil))
(ert-run-tests-interactively
`(member ,passing-test ,failing-test) buffer-name
mock-message-fn)
(should (equal messages `(,(concat
"Ran 2 tests, 1 results were "
"as expected, 1 unexpected"))))
(with-current-buffer buffer-name
(font-lock-mode 0)
(should (ert-equal-including-properties
(ert-filter-string (buffer-string)
'("Started at:\\(.*\\)$" 1)
'("Finished at:\\(.*\\)$" 1))
(expected-string nil)))
;; `font-lock-mode' only works if interactive, so
;; pretend we are.
(let ((noninteractive nil))
(font-lock-mode 1))
(should (ert-equal-including-properties
(ert-filter-string (buffer-string)
'("Started at:\\(.*\\)$" 1)
'("Finished at:\\(.*\\)$" 1))
(expected-string t)))))
(when (get-buffer buffer-name)
(kill-buffer buffer-name)))))))
(ert-deftest ert-test-describe-test ()
"Tests `ert-describe-test'."
......
Markdown is supported
0% or .