1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
;;; noflet.el --- locally override functions
;; Copyright (C) 2013 Nic Ferrier
;; Author: Nic Ferrier <nferrier@ferrier.me.uk>
;; Keywords: lisp
;; Version: 0.0.6
;; Url: https://github.com/nicferrier/emacs-noflet
;; This program 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 of the License, or
;; (at your option) any later version.
;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This let's you locally override functions, in the manner of `flet',
;; but with access to the original function through the symbol:
;; `this-fn'.
;;; Code:
(require 'cl-macs)
(defun noflet|base ()
"A base function."
:noflet)
(defun noflet|expand (bindings &rest forms)
"Expand BINDINGS and evaluate FORMS.
Used by `noflet' to expand it's contents.
Example:
(noflet|expand
'((find-file-noselect (file-name)
(if t
(this-fn \"/tmp/mytest\")
(this-fn file-name)))
(expand-file-name (file-name &optional thing)
(if t
(concat \"/tmp/\" file-name)
(funcall this-fn file-name thing))))
'(progn (expand-file-name \"/home/nferrier/thing\")))
It should not be necessary ever to call this. Hence the exotic
name."
(let*
((fsets
(cl-loop
for i in bindings
collect
(cl-destructuring-bind (name args &rest body) i
(let ((saved-func-namev (make-symbol "saved-func-name")))
(let ((saved-func-namev
(intern (format "saved-func-%s"
(symbol-name name)))))
`(fset (quote ,name)
(lambda ,args
(let ((this-fn ,saved-func-namev))
,@body))))))))
(fresets
(cl-loop
for i in bindings
collect
(cl-destructuring-bind (name args &rest body) i
(let ((saved-func-namev (make-symbol "saved-func-name")))
(let ((saved-func-namev
(intern (format "saved-func-%s"
(symbol-name name)))))
`(if
(eq (symbol-function (quote noflet|base))
,saved-func-namev)
(fmakunbound (quote ,name))
(fset (quote ,name) ,saved-func-namev)))))))
(lets
(cl-loop
for i in bindings
collect
(cl-destructuring-bind (name args &rest body) i
(let ((saved-func-namev (make-symbol "saved-func-name")))
(let ((saved-func-namev
(intern (format "saved-func-%s"
(symbol-name name)))))
`(,saved-func-namev
(condition-case err
(symbol-function (quote ,name))
(void-function
(symbol-function (quote noflet|base)))))))))))
`(let ,lets
(unwind-protect
(progn
(progn ,@fsets)
,@forms)
(progn ,@fresets)))))
(defmacro noflet (bindings &rest body)
"Make local function BINDINGS allowing access to the original.
Each of the BINDINGS is done like in `flet':
(noflet
((expand-file-name (file-name &optional default-dir)
(concat defaulr-dir file-name)))
(expand-file-name \"~/test\"))
In each of the BINDINGS the original function is accessible with
the name `this-fn':
(noflet
((expand-file-name (file-name &optional default-dir)
(if (string-match-p \"/fake.*\" file-name)
(concat default-dir file-name)
(funcall this-fn file-name default-dir))))
(expand-file-name \"~/test\"))
This is great for overriding in testing and such like.
If new bindings are introduced the binding is discarded upon
exit. Even with new bindings there is still a `this-fn'. It
points to `noflet|base' for all new bindings."
(declare (debug ((&rest (cl-defun)) cl-declarations body))
(indent ((&whole 4 &rest (&whole 1 &lambda &body)) &body)))
(apply 'noflet|expand bindings body))
(defmacro* let-while ((var expression) &rest body)
"A simple binding loop.
VAR is bound to EXPRESSION repeatedly until `nil'.
BODY is evaluated each time."
(declare
(debug (sexp sexp &rest form))
(indent 1))
(let ((expression-proc (make-symbol "exprp")))
`(let ((,expression-proc (lambda () ,expression)))
(let ((,var (funcall ,expression-proc)))
(while ,var
(progn ,@body)
(setq ,var (funcall ,expression-proc)))))))
(provide 'noflet)
;;; noflet.el ends here
|
