|
0
|
1 ;; Some tests for edebug.
|
|
|
2
|
|
|
3 ;;=======================
|
|
|
4 ;; Reading tests.
|
|
|
5
|
|
|
6 (testing (one two) three)
|
|
|
7
|
|
|
8 (progn '(testing))
|
|
|
9
|
|
|
10 (a . (b . c))
|
|
|
11
|
|
|
12 (a . "test")
|
|
|
13
|
|
|
14 (a . (b . nil))
|
|
|
15
|
|
|
16 (a . [one two three])
|
|
|
17
|
|
|
18 ;;===========================
|
|
|
19 ;; Backquote test
|
|
|
20
|
|
|
21 (defun test ()
|
|
|
22 (macroexpand '(` ((, (a)) . (, test))))
|
|
|
23 )
|
|
|
24 (test)
|
|
|
25
|
|
|
26 (progn (` ((, (point)) . (, (point)))))
|
|
|
27 (` (, (point)))
|
|
|
28
|
|
|
29 (defun test ()
|
|
|
30 (message "%d" 999999)
|
|
|
31
|
|
|
32 (defun test1 ()
|
|
|
33
|
|
|
34 (progn
|
|
|
35 (defun test ()
|
|
|
36 (message "%d" 99999))
|
|
|
37 (test)
|
|
|
38 )
|
|
|
39
|
|
|
40 )
|
|
|
41 (test1)
|
|
|
42 (test)
|
|
|
43
|
|
|
44 (eval (edebug-` (append [(, (point)) (, (point))] nil)))
|
|
|
45 (eval (edebug-` (append (, (point)) (, (point)) nil)))
|
|
|
46
|
|
|
47 (eval (progn (edebug-` (edebug-` (, '(, (point)))))))
|
|
|
48
|
|
|
49 (eval (edebug-` (let (((, 'a) 'b))
|
|
|
50 (message "%s" a))))
|
|
|
51
|
|
|
52 (defun test ()
|
|
|
53
|
|
|
54 (let ((r '(union x y)))
|
|
|
55 (` (` (foo (, '(, r))))))
|
|
|
56 )
|
|
|
57
|
|
|
58 (defun test ()
|
|
|
59 (let ((a '(one two))) a))
|
|
|
60
|
|
|
61 (def-edebug-spec test-func (sexp &rest def-form))
|
|
|
62
|
|
|
63 (setq edebug-unwrap-results t)
|
|
|
64 (setq edebug-unwrap-results nil)
|
|
|
65
|
|
|
66 (defmacro test-func (func &rest args)
|
|
|
67 (edebug-` ((, func) (,@ args))))
|
|
|
68
|
|
|
69 (test-func message (concat "hi%s" "there") (+ 1 2))
|
|
|
70
|
|
|
71 (defmacro test-progn (&rest body)
|
|
|
72 (edebug-` (progn (,@ body))))
|
|
|
73
|
|
|
74 (def-edebug-spec test-progn (&rest def-form))
|
|
|
75
|
|
|
76 (test-progn
|
|
|
77 (message "testing"))
|
|
|
78
|
|
|
79
|
|
|
80 ;;=================
|
|
|
81 ;; Testing read syntax.
|
|
|
82
|
|
|
83 (format "testing %s %s %s" 1 2 (+ 1 2))
|
|
|
84
|
|
|
85 (defun test-syntax ()
|
|
|
86 (setq mode-line-stuff'("draft(%b) ^C^S(end) ^C^Q(uit) ^C^K(ill)"))
|
|
|
87 ;; (re-search-forward "[.?!][])""']*$" nil t)
|
|
|
88 ;; (let (test)
|
|
|
89 )
|
|
|
90 )
|
|
|
91
|
|
|
92 (test-syntax)
|
|
|
93
|
|
|
94 (let ())
|
|
|
95 ;;====================
|
|
|
96 ;; Testing function
|
|
|
97
|
|
|
98 (defun foo (x)
|
|
|
99 (mapconcat (function identity) x ", "))
|
|
|
100
|
|
|
101 (defun foo (x)
|
|
|
102 (mapconcat 'identity x ", "))
|
|
|
103
|
|
|
104 (defun foo (x)
|
|
|
105 (mapconcat (function (lambda (x) x)) x ", "))
|
|
|
106
|
|
|
107 (require 'cl)
|
|
|
108
|
|
|
109 (defun foo (x)
|
|
|
110 (mapconcat (function* (lambda (x &optional (y (1+ x)) &key xyz) x)) x ", "))
|
|
|
111
|
|
|
112 (defun foo (x)
|
|
|
113 (mapconcat '(lambda (x) x) x ", "))
|
|
|
114
|
|
|
115 (foo '(1 2 3))
|
|
|
116
|
|
|
117 (apply 'identity one two)
|
|
|
118
|
|
|
119 (defun test1 (arg)
|
|
|
120 arg)
|
|
|
121
|
|
|
122 (def-edebug-spec test1
|
|
|
123 (form))
|
|
|
124 (setq x 5)
|
|
|
125 (test1 (+ x 2))
|
|
|
126
|
|
|
127 (("test1" test1)))
|
|
|
128
|
|
|
129 (def-edebug-spec test1
|
|
|
130 (&define sexp form))
|
|
|
131
|
|
|
132 (test (test1 xyz (message "jfdjfd")))
|
|
|
133
|
|
|
134 ;;====================
|
|
|
135 ;; Anonymous function test
|
|
|
136 (defun hej (arg)
|
|
|
137 "docstring"
|
|
|
138 (interactive (list 2))
|
|
|
139 ((lambda (luttr &rest params)
|
|
|
140 (apply luttr luttr params))
|
|
|
141 (function (lambda (self n)
|
|
|
142 (edebug-trace "n: %s" n)
|
|
|
143 (if (= n 5) (edebug nil "n is 5"))
|
|
|
144 (edebug-tracing "cond"
|
|
|
145 (cond
|
|
|
146 ((= 0 n) 1)
|
|
|
147 (t (* n (funcall self self (1- n))))))))
|
|
|
148 11))
|
|
|
149
|
|
|
150 (defun hej-test ()
|
|
|
151 (interactive)
|
|
|
152 (message
|
|
|
153 "testing")
|
|
|
154 (hej edebug-execution-mode)
|
|
|
155 )
|
|
|
156 (hej-test)
|
|
|
157
|
|
|
158 (defun lambda-test ()
|
|
|
159 ((lambda (arg) arg) 'xyz))
|
|
|
160 (lambda-test)
|
|
|
161
|
|
|
162 (defun test ()
|
|
|
163 "doc string
|
|
|
164 (with left paren on start of line)"
|
|
|
165
|
|
|
166 1)
|
|
|
167
|
|
|
168
|
|
|
169 (progn
|
|
|
170 (save-window-excursion
|
|
|
171 (split-window)
|
|
|
172 (split-window)
|
|
|
173 (setq w (next-window)))
|
|
|
174 (edebug-window-live-p w))
|
|
|
175
|
|
|
176
|
|
|
177 ;;====================
|
|
|
178 ;; Test edebugging top-level-forms
|
|
|
179
|
|
|
180 (def-edebug-spec test nil)
|
|
|
181 (let ((arg (list 'a 'b 'c)))
|
|
|
182 (defun test (arg)
|
|
|
183 arg)
|
|
|
184 (test arg))
|
|
|
185
|
|
|
186
|
|
|
187 (fset 'emacs-setq (symbol-function 'setq))
|
|
|
188
|
|
|
189 (defmacro my-setq (&rest args)
|
|
|
190 (while args
|
|
|
191 (set (car args) (eval (car (cdr args))))
|
|
|
192 (setq args (cdr (cdr args)))))
|
|
|
193
|
|
|
194 (defmacro test-macro (&rest args)
|
|
|
195 (cons 'list args))
|
|
|
196 (def-edebug-spec test-macro 0)
|
|
|
197
|
|
|
198 (defun test ()
|
|
|
199 (test-macro (message "testing")))
|
|
|
200 (test)
|
|
|
201
|
|
|
202 (defun test ()
|
|
|
203 (message "someting")
|
|
|
204 (function (lambda ()
|
|
|
205 (message "something else")))
|
|
|
206 )
|
|
|
207
|
|
|
208 (funcall (test))
|
|
|
209
|
|
|
210 ;;====================
|
|
|
211 ;; Test for and inc
|
|
|
212 (def-edebug-spec for
|
|
|
213 (symbolp ["from" def-form ["to" def-form] ["do" &rest def-form]]))
|
|
|
214
|
|
|
215 ;; (symbolp ['from form ['to form] ['do &rest form]])
|
|
|
216
|
|
|
217 (inc x)
|
|
|
218 (defmacro inc (var)
|
|
|
219 (list 'setq var (list '1+ var)))
|
|
|
220
|
|
|
221 (defmacro for (var from init to final do &rest body)
|
|
|
222 (let ((tempvar (make-symbol "max")))
|
|
|
223 (edebug-` (let (((, var) (, init))
|
|
|
224 ((, tempvar) (, final)))
|
|
|
225 (while (<= (, var) (, tempvar))
|
|
|
226 (,@ body)
|
|
|
227 (inc (, var)))))))
|
|
|
228
|
|
|
229 (defun test-for (one two)
|
|
|
230 (for i from one to two do
|
|
|
231 (message "%s" i))
|
|
|
232 )
|
|
|
233
|
|
|
234 (let ((n 5))
|
|
|
235 (for i from n to (* n (+ n 1)) do
|
|
|
236 (message "%s" i)))
|
|
|
237
|
|
|
238 (test-for 3 10)
|
|
|
239
|
|
|
240 ;;====================
|
|
|
241 ;; Test condition-case
|
|
|
242 (def-edebug-spec condition-case
|
|
|
243 (symbolp
|
|
|
244 form
|
|
|
245 &rest (symbolp &optional form)))
|
|
|
246
|
|
|
247 (setq edebug-on-signal '(error))
|
|
|
248
|
|
|
249 (defun test-condition-case ()
|
|
|
250 (condition-case err
|
|
|
251 (signal 'error '(oh))
|
|
|
252 (error (message "error: %s" err))
|
|
|
253 ))
|
|
|
254 (test-condition-case)
|
|
|
255
|
|
|
256 (require 'cl)
|
|
|
257
|
|
|
258 ;;=============
|
|
|
259 ;; lexical let
|
|
|
260
|
|
|
261 (defun test-lexical ()
|
|
|
262 (funcall (lexical-let ((xyz 123))
|
|
|
263 (function (lambda (arg) (+ arg xyz))))
|
|
|
264 456))
|
|
|
265 (test-lexical)
|
|
|
266
|
|
|
267 ;;====================
|
|
|
268 ;; case test.
|
|
|
269 (defun test-case (one)
|
|
|
270 (case one
|
|
|
271 ((one) (message "(one)"))
|
|
|
272 ("one" (message "one"))
|
|
|
273 ('one (message "'one"))
|
|
|
274 ))
|
|
|
275
|
|
|
276 (test-case 'one)
|
|
|
277
|
|
|
278 ;;====================
|
|
|
279 ;; Test of do from cl.el
|
|
|
280
|
|
|
281 (defun list-reverse (list)
|
|
|
282 (do ((x list (cdr x))
|
|
|
283 (y nil (cons (car x) y)))
|
|
|
284 ((endp x) y)
|
|
|
285 (message "x: %s y: %s" x y)
|
|
|
286 ))
|
|
|
287
|
|
|
288
|
|
|
289 (list-reverse '(testing one two three))
|
|
|
290
|
|
|
291 (defmacro test-backquote (arg list)
|
|
|
292 (edebug-`
|
|
|
293 (progn
|
|
|
294 (message "%s %s" (, arg) (, list))
|
|
|
295 (mapcar (function (lambda (arg1)
|
|
|
296 (message "%s %s" arg1 (, arg)))) (, list)))))
|
|
|
297
|
|
|
298 (def-edebug-spec test-backquote (def-form def-form))
|
|
|
299 (test-backquote (symbol-name 'something) (list 1 2 3))
|
|
|
300
|
|
|
301
|
|
|
302 (defmacro dired-map-over-marks (body arg &optional show-progress)
|
|
|
303 (edebug-` (prog1
|
|
|
304 (let (buffer-read-only case-fold-search found results)
|
|
|
305 (if (, arg)
|
|
|
306 (if (integerp (, arg))
|
|
|
307 (progn;; no save-excursion, want to move point.
|
|
|
308 (dired-repeat-over-lines
|
|
|
309 (, arg)
|
|
|
310 (function (lambda ()
|
|
|
311 (if (, show-progress) (sit-for 0))
|
|
|
312 (setq results (cons (, body) results)))))
|
|
|
313 (if (< (, arg) 0)
|
|
|
314 (nreverse results)
|
|
|
315 results))
|
|
|
316 ;; non-nil, non-integer ARG means use current file:
|
|
|
317 (list (, body)))
|
|
|
318 (let ((regexp (dired-marker-regexp)) next-position)
|
|
|
319 (save-excursion
|
|
|
320 (goto-char (point-min))
|
|
|
321 ;; remember position of next marked file before BODY
|
|
|
322 ;; can insert lines before the just found file,
|
|
|
323 ;; confusing us by finding the same marked file again
|
|
|
324 ;; and again and...
|
|
|
325 (setq next-position (and (re-search-forward regexp nil t)
|
|
|
326 (point-marker))
|
|
|
327 found (not (null next-position)))
|
|
|
328 (while next-position
|
|
|
329 (goto-char next-position)
|
|
|
330 (if (, show-progress) (sit-for 0))
|
|
|
331 (setq results (cons (, body) results))
|
|
|
332 ;; move after last match
|
|
|
333 (goto-char next-position)
|
|
|
334 (forward-line 1)
|
|
|
335 (set-marker next-position nil)
|
|
|
336 (setq next-position (and (re-search-forward regexp nil t)
|
|
|
337 (point-marker)))))
|
|
|
338 (if found
|
|
|
339 results
|
|
|
340 (list (, body))))))
|
|
|
341 ;; save-excursion loses, again
|
|
|
342 (dired-move-to-filename))))
|
|
|
343
|
|
|
344
|
|
|
345 (def-edebug-spec dired-map-over-marks (&rest def-form))
|
|
|
346
|
|
|
347 (dired-map-over-marks
|
|
|
348 (message "here") (+ 1 2) t)
|
|
|
349
|
|
|
350 ;;====================
|
|
|
351 ;; circular structure test
|
|
|
352
|
|
|
353 (edebug-install-custom-print)
|
|
|
354 (edebug-uninstall-custom-print)
|
|
|
355
|
|
|
356 (setq a '(1 2))
|
|
|
357 (progn
|
|
|
358 (edebug-install-custom-print)
|
|
|
359 (setq a '(1 2))
|
|
|
360 (setcar a a))
|
|
|
361
|
|
|
362 (defun test ()
|
|
|
363 (with-custom-print
|
|
|
364 (format "%s" (setcar a a)))))
|
|
|
365 (test)
|
|
|
366 (setcdr a a)
|
|
|
367 (let ((b a)) b)
|
|
|
368
|
|
|
369 (with-custom-print
|
|
|
370 (let ((print-circle t)
|
|
|
371 (circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)))
|
|
|
372 (setcar (nthcdr 3 circ-list) circ-list)
|
|
|
373 (aset (nth 2 circ-list) 2 circ-list)
|
|
|
374 (prin1-to-string circ-list)))
|
|
|
375
|
|
|
376 ;;====================
|
|
|
377 ;; interactive-p test
|
|
|
378 (defun test-interactive ()
|
|
|
379 (interactive)
|
|
|
380 (interactive-p))
|
|
|
381
|
|
|
382 (test-interactive)
|
|
|
383 (call-interactively 'test-interactive)
|
|
|
384
|
|
|
385
|
|
|
386 ;;====================
|
|
|
387 ;; test several things:
|
|
|
388 ;; - nested defun.
|
|
|
389 ;; - display scrolling.
|
|
|
390
|
|
|
391
|
|
|
392 (defmacro testmacro ()
|
|
|
393 '(interactive-p))
|
|
|
394
|
|
|
395 (call-interactively 'testing1)
|
|
|
396 (testing1 9)
|
|
|
397
|
|
|
398 (defun testing1 (arg)
|
|
|
399 (interactive (list 3))
|
|
|
400 (message "%s" (interactive-p)) (sit-for 2)
|
|
|
401 (edebug-trace "interactive: %s" (testmacro))
|
|
|
402 (defun testing1-1 ()
|
|
|
403 (testing1 2))
|
|
|
404 ;; (custom-message "%s" arg "extra")
|
|
|
405 (current-buffer)
|
|
|
406 (selected-window)
|
|
|
407 (while (< 0 (setq arg (1- arg)))
|
|
|
408 arg
|
|
|
409 arg
|
|
|
410 arg
|
|
|
411 arg
|
|
|
412 arg
|
|
|
413 arg
|
|
|
414 arg
|
|
|
415 arg
|
|
|
416 arg ; middle
|
|
|
417 arg
|
|
|
418 arg
|
|
|
419 arg
|
|
|
420 arg
|
|
|
421 arg
|
|
|
422 arg
|
|
|
423 arg
|
|
|
424 arg
|
|
|
425 arg
|
|
|
426 arg ; jump
|
|
|
427 arg
|
|
|
428 arg
|
|
|
429 arg
|
|
|
430 arg
|
|
|
431 arg
|
|
|
432 arg
|
|
|
433 arg
|
|
|
434 arg
|
|
|
435 arg
|
|
|
436 arg
|
|
|
437 arg
|
|
|
438 arg
|
|
|
439 arg
|
|
|
440 ))
|
|
|
441 (edebug-trace-display "*testing*" "one")
|
|
|
442 (edebug-tracer "one\n")
|
|
|
443
|
|
|
444 (testing1 a)
|
|
|
445 (call-interactively 'testing1)
|
|
|
446 (testing1 2)
|
|
|
447
|
|
|
448 (testing1-1)
|
|
|
449
|
|
|
450
|
|
|
451 (defmacro testmacro ()
|
|
|
452 (interactive)
|
|
|
453 '(one))
|
|
|
454
|
|
|
455 (defun testing2 ()
|
|
|
456 (let* ((buf (get-buffer-create "testing"))
|
|
|
457 (win (get-buffer-window buf)))
|
|
|
458 (testing1 1)
|
|
|
459 (window-point win)
|
|
|
460 (window-point win)
|
|
|
461
|
|
|
462 ;; (read-stream-char buf)
|
|
|
463 ))
|
|
|
464
|
|
|
465 (testing2)
|
|
|
466
|
|
|
467
|
|
|
468 (defun testing3 ()
|
|
|
469 (save-excursion
|
|
|
470 (set-buffer (get-buffer-create "*testing*"))
|
|
|
471 (current-buffer)
|
|
|
472 (point)
|
|
|
473 (forward-char 1)
|
|
|
474 ))
|
|
|
475 (testing3)
|
|
|
476
|
|
|
477
|
|
|
478 ;;====================
|
|
|
479 ;; anonymous function test
|
|
|
480 (defun testanon (arg)
|
|
|
481 (mapcar '(lambda (x) x) arg)
|
|
|
482 (mapcar (function (lambda (x) x)) arg)
|
|
|
483 (mapcar (function testing3 ) arg)
|
|
|
484 )
|
|
|
485
|
|
|
486 (testanon '(1 2 3))
|
|
|
487
|
|
|
488 ;;====================
|
|
|
489 ;; upward funarg test
|
|
|
490
|
|
|
491 (defmacro lambda (&rest args)
|
|
|
492 "Return the quoted lambda expression."
|
|
|
493 (cons 'function (list (cons 'lambda args))))
|
|
|
494
|
|
|
495 (lambda (testing) one two)
|
|
|
496
|
|
|
497 (defun testanon2 ()
|
|
|
498 "return an anoymous function."
|
|
|
499 (function (lambda (x) x))
|
|
|
500 )
|
|
|
501 ;; Emacs 19 has a lambda macro
|
|
|
502 (defun testanon2 ()
|
|
|
503 "return an anoymous function."
|
|
|
504 (lambda (x) x))
|
|
|
505 (testanon2)
|
|
|
506
|
|
|
507 (setq func
|
|
|
508 (testanon2))
|
|
|
509 (funcall func 2)
|
|
|
510
|
|
|
511 (defun foo ()
|
|
|
512 (mapcar #'(lambda (x)
|
|
|
513 (message "%S" x))
|
|
|
514 (append '(0) '(a b c d e f))))
|
|
|
515 (foo)
|
|
|
516
|
|
|
517 ;;====================
|
|
|
518 ;; downward funarg test
|
|
|
519
|
|
|
520 (defun xxx (func)
|
|
|
521 (funcall func))
|
|
|
522
|
|
|
523 (defun yyy ()
|
|
|
524 (xxx (function (lambda () (message "hello")))))
|
|
|
525
|
|
|
526 (yyy)
|
|
|
527
|
|
|
528 ;; eval this:
|
|
|
529 (def-edebug-spec test nil)
|
|
|
530 (defun test (func list)
|
|
|
531 (dolist (el list)
|
|
|
532 (funcall func el)))
|
|
|
533
|
|
|
534 ;; edebug this:
|
|
|
535 (defun testcall (l)
|
|
|
536 (test (function (lambda (x) (print x))) ;; set breakpoints in anon.
|
|
|
537 l))
|
|
|
538
|
|
|
539 ;; test call:
|
|
|
540 (testcall '(a b c))
|
|
|
541
|
|
|
542 ;; flet test.
|
|
|
543
|
|
|
544 (defun alep-write-history (&rest args)
|
|
|
545 (message "alep-write-history( %s )\n"
|
|
|
546 args)
|
|
|
547 ;; write out header
|
|
|
548 '(write-region (format ";;Saved on %s\n" (current-time-string))
|
|
|
549 nil buffer-file-name nil 'shut-up)
|
|
|
550 ;; dump all not deleted actions
|
|
|
551 (flet ((write-solution (sol)
|
|
|
552 t)
|
|
|
553 (write-action (action)
|
|
|
554 (if (a-h-action-deleted action)
|
|
|
555 ;; nothing to be done
|
|
|
556 t
|
|
|
557 (write-region
|
|
|
558 (format "(alep-new-history-action %S %S %S)\n"
|
|
|
559 (a-h-action-name action)
|
|
|
560 (alep-tnowv-string (a-h-action-in-tnowv
|
|
|
561 action))
|
|
|
562 (a-h-action-timestamp action))
|
|
|
563 nil buffer-file-name t 'shut-up)
|
|
|
564 (mapc 'write-solution
|
|
|
565 (a-h-action-solutions action)))))
|
|
|
566 (mapc 'write-action
|
|
|
567 history-list))
|
|
|
568 t)
|
|
|
569 (setq history-list '(1 2 3))
|
|
|
570 (alep-write-history)
|
|
|
571
|
|
|
572 ;;=========================
|
|
|
573
|
|
|
574 (edebug-trace "my stuff")
|
|
|
575
|
|
|
576 (defun fac (n)
|
|
|
577 (if (= n 0) (edebug))
|
|
|
578 ;#6 1 0 =5
|
|
|
579 (if (< 0 n)
|
|
|
580 ;#5 =
|
|
|
581 (* n (fac (1- n)))
|
|
|
582 ;# 5 0
|
|
|
583 1))
|
|
|
584 ;# 0
|
|
|
585
|
|
|
586 (fac 5)
|
|
|
587
|
|
|
588
|
|
|
589 ;;====================
|
|
|
590 ;; Timing test - how bad is edebug?
|
|
|
591
|
|
|
592 (defun looptest (n)
|
|
|
593 (let ((i 0))
|
|
|
594 (while (< i n) (setq i (1+ i)))))
|
|
|
595
|
|
|
596 (looptest 10000)
|
|
|
597
|
|
|
598 ;;====================
|
|
|
599 ;; eval-depth testing.
|
|
|
600
|
|
|
601 (defun test-depth (i)
|
|
|
602 (test-depth (1+ i)))
|
|
|
603
|
|
|
604 ;; Without edebug i reaches 193, failing on eval depth
|
|
|
605 ;; With edebug, i reaches about 57. Better safe than sorry.
|
|
|
606 (setq max-lisp-eval-depth 200)
|
|
|
607 (test-depth 0)
|
|
|
608
|
|
|
609 ;;====================
|
|
|
610 ;; specpdl-size testing.
|
|
|
611 (defun test-depth2 (i max)
|
|
|
612 (let ((test max-specpdl-size)
|
|
|
613 (max-lisp-eval-depth (+ 2 max-lisp-eval-depth))
|
|
|
614 )
|
|
|
615 (test-depth2 (1+ i) max-specpdl-size)))
|
|
|
616
|
|
|
617 (let ((max-lisp-eval-depth 300)
|
|
|
618 (max-specpdl-size 3))
|
|
|
619 (test-depth2 0 max-specpdl-size))
|
|
|
620
|
|
|
621 ;;====================
|
|
|
622 ;; Buffer testing.
|
|
|
623
|
|
|
624 (defun zprint-region-1 (start end switches)
|
|
|
625 (let ((name (concat (buffer-name) ""))
|
|
|
626 (width tab-width))
|
|
|
627 (save-excursion
|
|
|
628 (message "Spooling...")
|
|
|
629 (let ((oldbuf (current-buffer)))
|
|
|
630 (set-buffer (get-buffer-create " *spool temp*"))
|
|
|
631 (widen)
|
|
|
632 (erase-buffer)
|
|
|
633 (insert-buffer-substring oldbuf start end)
|
|
|
634 (setq tab-width width)
|
|
|
635 (if (/= tab-width 8)
|
|
|
636 (untabify (point-min) (point-max)))
|
|
|
637 (setq start (point-min) end (point-max)))
|
|
|
638 (apply 'call-process-region
|
|
|
639 (nconc (list start end zpr-command nil nil nil
|
|
|
640 "-h" name switches)))
|
|
|
641 (message "Spooling...done")
|
|
|
642 )
|
|
|
643 )
|
|
|
644 )
|
|
|
645
|
|
|
646
|
|
|
647
|
|
|
648 (defun quick-hanoi (nrings)
|
|
|
649 (with-output-to-temp-buffer "*hanio*"
|
|
|
650 (set-buffer "*hanio*")
|
|
|
651 (princ (format "Solution to %s ring hanoi problem\n\n" nrings))
|
|
|
652 (hanoi0 nrings 'pole-1 'pole-2 'pole-3)))
|
|
|
653
|
|
|
654 (defun hanoi0 (n from to work)
|
|
|
655 ;; (edebug-set-window-configuration (edebug-current-window-configuration))
|
|
|
656 (if (> n 0)
|
|
|
657 (progn
|
|
|
658 ;; (save-excursion
|
|
|
659 ;; (set-buffer "*hanio*")
|
|
|
660 ;; (message "Point=%s window-point=%s" (point)
|
|
|
661 ;; (window-point (get-buffer-window "*hanio*")))
|
|
|
662 ;; (set-window-point (get-buffer-window "*hanio*") (point))
|
|
|
663 ;; )
|
|
|
664
|
|
|
665 (hanoi0 (1- n) from work to)
|
|
|
666 (princ (format "ring %s from %s to %s\n" n from to))
|
|
|
667 (hanoi0 (1- n) work to from))))
|
|
|
668
|
|
|
669 (quick-hanoi 5)
|
|
|
670
|
|
|
671
|
|
|
672 ;;====================
|
|
|
673 ;; Error test
|
|
|
674
|
|
|
675 (defun error-generating-function ()
|
|
|
676 (message "try again?") (sit-for 1)
|
|
|
677 (prog1
|
|
|
678 (signal 'bogus '("some error" xyz abc))
|
|
|
679 (error "debug-on-error: %s edebug-entered: %s edebug-recursion-depth: %s"
|
|
|
680 debug-on-error edebug-entered edebug-recursion-depth)))
|
|
|
681
|
|
|
682 ;; --><-- point will be left between the two arrows
|
|
|
683 (setq debug-on-error nil)
|
|
|
684 (setq edebug-on-signal '(bogus))
|
|
|
685
|
|
|
686 (testing-function)
|
|
|
687 (defun testing-function ()
|
|
|
688 (interactive)
|
|
|
689 (message "YYY")
|
|
|
690 (error-generating-function)
|
|
|
691 (message "ZZZ"))
|
|
|
692
|
|
|
693
|
|
|
694 (let ((debug-on-error t))
|
|
|
695 xyzzyz)
|
|
|
696
|
|
|
697 ;;====================
|
|
|
698 ;; Quitting with unwind-protect
|
|
|
699
|
|
|
700 (defun unwind-test ()
|
|
|
701 (prog1
|
|
|
702 (unwind-protect
|
|
|
703 (unwind-protect
|
|
|
704 (message "testing")
|
|
|
705 (message "unwinding1"))
|
|
|
706 (message "unwinding2")
|
|
|
707 (sit-for 1)
|
|
|
708 )
|
|
|
709 ))
|
|
|
710 (unwind-test)
|
|
|
711
|
|
|
712 (defmacro save-buffer-points (&rest body)
|
|
|
713 (` (let ((buffer-points
|
|
|
714 (mapcar (function (lambda (buf)
|
|
|
715 (set-buffer buf)
|
|
|
716 (cons buf (point))))
|
|
|
717 (buffer-list))))
|
|
|
718 (unwind-protect
|
|
|
719 (progn
|
|
|
720 (,@ body))
|
|
|
721 (mapcar (function (lambda (buf-point)
|
|
|
722 (if (buffer-name (car buf-point))
|
|
|
723 (progn
|
|
|
724 (set-buffer (car buf-point))
|
|
|
725 (goto-char (cdr buf-point))))))
|
|
|
726 buffer-points)))))
|
|
|
727
|
|
|
728 (defun testing4 ()
|
|
|
729 (with-output-to-temp-buffer "*testing*"
|
|
|
730 (princ "Line 1\n")
|
|
|
731 (save-buffer-points
|
|
|
732 (recursive-edit)
|
|
|
733 )
|
|
|
734 (princ "Line 2\n")
|
|
|
735 ))
|
|
|
736
|
|
|
737 (testing4)
|
|
|
738 test!
|
|
|
739
|
|
|
740
|
|
|
741 ;;====================
|
|
|
742 ;; edebug-form-specs for Guido Bosch's flavors
|
|
|
743
|
|
|
744 (def-edebug-spec defmethod defun) ; same as defun
|
|
|
745 (def-edebug-spec defwhopper defun) ; same as defun
|
|
|
746
|
|
|
747 ;;======================
|
|
|
748 ;; Check syntax errors.
|
|
|
749
|
|
|
750 (defun test-too-many-arguments ()
|
|
|
751 (mapcar 'test one two))
|
|
|
752
|
|
|
753 (mapcar 'not-enough)
|
|
|
754
|
|
|
755 (defun test-not-enough-arguments ()
|
|
|
756 (mapcar 'test))
|
|
|
757
|
|
|
758 (defun test-bad-function ()
|
|
|
759 (function))
|
|
|
760
|
|
|
761 (defun test-bad-function ()
|
|
|
762 (function
|
|
|
763 (bad () )))
|
|
|
764
|
|
|
765 (defun test-bad-lambda-arguments ()
|
|
|
766 (function (lambda "bad" )))
|
|
|
767
|
|
|
768 (defun test-bad-defun-arguments "bad"
|
|
|
769 (function (lambda "bad" )))
|
|
|
770
|
|
|
771 (defun test-bad-defun-arguments (arg "bad") ;; wrong error
|
|
|
772 (function (lambda "bad" )))
|
|
|
773
|
|
|
774 (defun test-bad-defun-arguments (&optional)
|
|
|
775 (function (lambda "bad" )))
|
|
|
776
|
|
|
777 (defun test-bad-let-in-lambda ()
|
|
|
778 (function (lambda ()
|
|
|
779 (let ((something one bad)))))) ;; wrong error
|
|
|
780
|
|
|
781 (defun test-bad-interactive ()
|
|
|
782 (interactive one bad))
|
|
|
783
|
|
|
784 (defun test-bad-defvar ()
|
|
|
785 (defvar test-defvar nil [bad]))
|
|
|
786
|
|
|
787 (defun test-bad-let1 ()
|
|
|
788 (let bad))
|
|
|
789
|
|
|
790 (defun test-bad-let2 ()
|
|
|
791 (let ((something one bad))))
|
|
|
792
|
|
|
793 (defun test-good-let ()
|
|
|
794 (let ((a b))))
|
|
|
795
|
|
|
796 (defun test-bad-let3 ()
|
|
|
797 (let (((bad)))))
|
|
|
798
|
|
|
799 (defun test-bad-let4 ()
|
|
|
800 (let ("bad")))
|
|
|
801
|
|
|
802 (let ((good (list 'one))) good)
|
|
|
803
|
|
|
804 (defun test-bad-setq ()
|
|
|
805 (setq "bad" ))
|
|
|
806
|
|
|
807 (setq good ok
|
|
|
808 "bad")
|
|
|
809
|
|
|
810 (defun test-bad-cond ()
|
|
|
811 (cond "bad"))
|
|
|
812
|
|
|
813 (cond ())
|
|
|
814
|
|
|
815 (defun test-bad-cond ()
|
|
|
816 (cond () [] "bad"))
|
|
|
817
|
|
|
818 (defun test-bad-condition-case1 ()
|
|
|
819 (condition-case "bad"))
|
|
|
820
|
|
|
821 (defun test-bad-condition-case2 ()
|
|
|
822 (condition-case err
|
|
|
823 nil
|
|
|
824 "bad"))
|
|
|
825
|
|
|
826 (defun test-bad-condition-case3 ()
|
|
|
827 (condition-case err
|
|
|
828 (error "messages")
|
|
|
829 ;; ()
|
|
|
830 ((error quit) (message "%s" err))))
|
|
|
831
|
|
|
832
|
|
|
833 (def-edebug-spec do
|
|
|
834 ((&rest &or symbolp
|
|
|
835 (fence symbolp &optional form form))
|
|
|
836 (form body) body))
|
|
|
837
|
|
|
838 (defun bad-do (list)
|
|
|
839
|
|
|
840 (do ( x
|
|
|
841 (x list (cdr x))
|
|
|
842 (y nil (cons (car x) y))
|
|
|
843 (x list (cdr x) bad)
|
|
|
844 "bad"
|
|
|
845 )
|
|
|
846 ((endp x) y)
|
|
|
847 ))
|
|
|
848
|
|
|
849 (defun ok ()
|
|
|
850 test
|
|
|
851 )
|
|
|
852
|
|
|
853 (defun "bad" () )
|
|
|
854 (defun)
|
|
|
855
|
|
|
856 ;;=========================
|
|
|
857
|
|
|
858 ;; Test printing.
|
|
|
859
|
|
|
860 (defun test-window-buffer-change (arg)
|
|
|
861 "testing"
|
|
|
862 (interactive arg)
|
|
|
863 (save-window-excursion
|
|
|
864 (set-window-buffer (selected-window) (get-buffer "*scratch*"))
|
|
|
865 (get-buffer-window (current-buffer))))
|
|
|
866 (test-window-buffer-change 'test)
|
|
|
867
|
|
|
868
|
|
|
869 (defun test-window-buffer-change ()
|
|
|
870 (selected-window))
|
|
|
871
|
|
|
872 (test-window-buffer-change 1)
|
|
|
873
|
|
|
874 arg
|
|
|
875
|
|
|
876
|
|
|
877 (def-edebug-spec edebug-forms
|
|
|
878 (&rest edebug-form))
|
|
|
879
|
|
|
880 (def-edebug-spec edebug-form
|
|
|
881 (&or (edebug-function-symbolp edebug-forms)
|
|
|
882 (anonymous-function edebug-forms)
|
|
|
883 (edebug-macro-symbolp
|
|
|
884 sexp)))
|
|
|
885
|
|
|
886
|
|
|
887 (defun test-mapatoms () )
|
|
|
888
|
|
|
889 (mapatoms (function (lambda (arg)
|
|
|
890 (princ
|
|
|
891 arg)
|
|
|
892 )))
|
|
|
893
|
|
|
894
|
|
|
895 (test-mapatoms)
|
|
|
896
|
|
|
897 ;; Test embedded &rest
|
|
|
898 (def-edebug-spec symbol-list
|
|
|
899 ([&rest "a" symbolp] form))
|
|
|
900
|
|
|
901 (defun test ()
|
|
|
902 (symbol-list a b a (+ c d)))
|
|
|
903 (test)
|
|
|
904
|
|
|
905 (def-edebug-spec group-alternates-test
|
|
|
906 (&or ["foo" "bar"] "baz"))
|
|
|
907
|
|
|
908 (group-alternates-test foo bar)
|
|
|
909 (group-alternates-test baz )
|
|
|
910
|
|
|
911 ;;---------------------
|
|
|
912
|
|
|
913 (defun test ()
|
|
|
914 (dolist (f (list 1 2))
|
|
|
915 (message f)))
|
|
|
916
|
|
|
917 (defun test ()
|
|
|
918 (dolist (el (list 'a 'b 'c))
|
|
|
919 (print el)))
|
|
|
920
|
|
|
921
|
|
|
922 ;; (of-type (type (more type)))
|
|
|
923
|
|
|
924 (def-edebug-spec test-nil
|
|
|
925 (&or symbolp "nil"))
|
|
|
926 (test-nil () )
|
|
|
927
|
|
|
928 (defun test ()
|
|
|
929 ((lambda (arg) arg) two)
|
|
|
930 )
|
|
|
931
|
|
|
932
|
|
|
933 ;; Dot notation testing
|
|
|
934
|
|
|
935 (def-edebug-spec test-dot
|
|
|
936 (symbolp . [&or symbolp (stringp)]))
|
|
|
937 (test-dot xyz . jk)
|
|
|
938 (test-dot xyz "jk")
|
|
|
939
|
|
|
940 (def-edebug-spec test-dot
|
|
|
941 (&or symbolp (test-dot1)))
|
|
|
942
|
|
|
943 (def-edebug-spec test-dot1
|
|
|
944 (test-dot2 . test-dot2))
|
|
|
945
|
|
|
946 (def-edebug-spec test-dot2
|
|
|
947 (symbolp))
|
|
|
948
|
|
|
949 (def-edebug-spec test-dot2
|
|
|
950 ([&or test-dot1 nil]))
|
|
|
951
|
|
|
952 (def-edebug-spec test-dot1
|
|
|
953 (symbolp))
|
|
|
954
|
|
|
955 (&or symbolp (test-dot)))
|
|
|
956
|
|
|
957
|
|
|
958 (defun test ()
|
|
|
959 (test-dot (a . b)))
|
|
|
960
|
|
|
961 (def-edebug-spec edebug-specs
|
|
|
962 (symbolp . symbolp))
|
|
|
963
|
|
|
964 (def-edebug-spec edebug-specs1
|
|
|
965 (&or symbolp))
|
|
|
966
|
|
|
967 (def-edebug-spec edebug-spec
|
|
|
968 (&or
|
|
|
969 symbolp))
|
|
|
970
|
|
|
971
|
|
|
972 (def-edebug-spec test-not
|
|
|
973 (symbolp . [¬ symbolp form]))
|
|
|
974 (test-not "string")
|
|
|
975
|
|
|
976 ;;--------------------------
|
|
|
977 ;; Loop macro testing
|
|
|
978
|
|
|
979 (defun test ()
|
|
|
980 (loop-var (((var1 (var2 var4) . (var3 var5)) . var1))
|
|
|
981 ))
|
|
|
982
|
|
|
983 (loop-var (var1 var2 . var3))
|
|
|
984 (loop-var (var1 ["bad"] . "bad"))
|
|
|
985
|
|
|
986 ' (var2 var3 . var4))
|
|
|
987
|
|
|
988 (loop for ((a . b) (c . d))
|
|
|
989 of-type ((float . float) (integer. integer))
|
|
|
990 )
|
|
|
991
|
|
|
992 (defun test ()
|
|
|
993 (loop if some-test
|
|
|
994 collect a-form into var
|
|
|
995 else minimize x ;; of-type some-type
|
|
|
996 and append x
|
|
|
997 end))
|
|
|
998
|
|
|
999 (defun test ()
|
|
|
1000 (loop for x from 1 to 9
|
|
|
1001 and y = nil then x
|
|
|
1002 collect (list x y)))
|
|
|
1003
|
|
|
1004 (defun test ()
|
|
|
1005 (loop for i from 10 downto 1 by 3
|
|
|
1006 do (print i)))
|
|
|
1007
|
|
|
1008
|
|
|
1009 (defun test ()
|
|
|
1010 (loop for item = 1 then (+ item 10)
|
|
|
1011 repeat 5
|
|
|
1012 collect item))
|
|
|
1013
|
|
|
1014 (defun test ()
|
|
|
1015 (loop for z upfrom 2
|
|
|
1016 thereis
|
|
|
1017 (loop for n upfrom 3 below (+ z 2) ;; + was log
|
|
|
1018 thereis
|
|
|
1019 (loop for x below z
|
|
|
1020 thereis
|
|
|
1021 (loop for y below z
|
|
|
1022 thereis (= (+ (* x n) ;; * was expt
|
|
|
1023 (* y n))
|
|
|
1024 (* z n)))))))
|
|
|
1025
|
|
|
1026 (defun test ()
|
|
|
1027 (loop for name in '(fred sue alice joe june)
|
|
|
1028 as age in '(22 26 19 20 10)
|
|
|
1029 append (list name age) into name-and-age-list
|
|
|
1030 count name into name-count
|
|
|
1031 sum age into total-age
|
|
|
1032 finally
|
|
|
1033 (return (values (round* total-age name-count)
|
|
|
1034 name-and-age-list))))
|
|
|
1035
|
|
|
1036 (defun test ()
|
|
|
1037 (loop for x from 0 to 3
|
|
|
1038 do (print x)
|
|
|
1039 if (zerop (mod x 2))
|
|
|
1040 do (princ " a")
|
|
|
1041 and if (zerop (floor* x 2))
|
|
|
1042 do (princ " b")
|
|
|
1043 end
|
|
|
1044 and do (princ " c")))
|
|
|
1045
|
|
|
1046
|
|
|
1047 (defun test ()
|
|
|
1048 (loop initially do (message x)
|
|
|
1049 do (dispatch-event event)))
|
|
|
1050
|
|
|
1051 (defun test ()
|
|
|
1052 (loop initially do (popup-menu menu) ;; do is an error here.
|
|
|
1053 with event = (allocate-event)
|
|
|
1054 do (dispatch-event event)))
|
|
|
1055
|
|
|
1056 (defun popup-menu-synchronously (menu)
|
|
|
1057 (loop initially (popup-menu menu)
|
|
|
1058 with event = (allocate-event)
|
|
|
1059 until (button-release-event-p (next-event event))
|
|
|
1060 do (dispatch-event event)
|
|
|
1061 finally do (deallocate-event event)))
|
|
|
1062
|
|
|
1063 (defun test ()
|
|
|
1064 (loop with list = '(1 2 3 4)
|
|
|
1065 for item in list
|
|
|
1066 sum item into summation
|
|
|
1067 collect (list item)))
|
|
|
1068
|
|
|
1069 ;;----------
|
|
|
1070
|
|
|
1071 (defun test-catch (n)
|
|
|
1072 (if (> n 0)
|
|
|
1073 (let* ((test
|
|
|
1074 (catch 'test
|
|
|
1075 (test-catch (1- n)))))
|
|
|
1076 (if test
|
|
|
1077 (do-throw)))
|
|
|
1078 (do-throw)))
|
|
|
1079
|
|
|
1080 (defun do-throw ()
|
|
|
1081 (funcall 'throw 'test 'here))
|
|
|
1082
|
|
|
1083 (test-catch 3)
|
|
|
1084
|
|
|
1085
|
|
|
1086 ;;------------
|
|
|
1087
|
|
|
1088 (defun* foo (a &optional b &key c d (e 17)))
|
|
|
1089
|
|
|
1090 (def-edebug-spec test-vector
|
|
|
1091 ((vector form)))
|
|
|
1092
|
|
|
1093 (defun test ()
|
|
|
1094
|
|
|
1095 (test-vector [one]))
|
|
|
1096
|
|
|
1097 [testing one two three]
|
|
|
1098 (testing one two three)
|
|
|
1099
|
|
|
1100 (def-edebug-spec test
|
|
|
1101 (&optional &or ["something" keywordp] symbolp))
|
|
|
1102
|
|
|
1103 (test something :somekey)
|
|
|
1104
|
|
|
1105 ;;----------
|
|
|
1106
|
|
|
1107
|
|
|
1108
|
|
|
1109 (defun find-faq (filename)
|
|
|
1110 "Hmtar en faq."
|
|
|
1111 (interactive
|
|
|
1112
|
|
|
1113 (list
|
|
|
1114 (all-faq-a-valid-ftp
|
|
|
1115 (intern-soft
|
|
|
1116 (let ((minibuffer-help-form
|
|
|
1117 (function
|
|
|
1118 (let* ((partial (buffer-string))
|
|
|
1119 (soft (intern-soft partial all-faq-known-files)))
|
|
|
1120 (if soft
|
|
|
1121 (set soft (append (cdr (symbol-value soft))
|
|
|
1122 (list (car (symbol-value soft))))))
|
|
|
1123 (if (and soft (all-faq-a-valid-ftp soft))
|
|
|
1124 (mapconcat
|
|
|
1125 (function
|
|
|
1126 (lambda (apair)
|
|
|
1127 (car apair)))
|
|
|
1128 (symbol-value soft)
|
|
|
1129 "\n"))))))
|
|
|
1130 (completing-read "What faq? "
|
|
|
1131 all-faq-known-files
|
|
|
1132 (function all-faq-a-valid-ftp)
|
|
|
1133 t ""))
|
|
|
1134 all-faq-known-files)))
|
|
|
1135 )
|
|
|
1136 (find-file filename))
|
|
|
1137
|
|
|
1138
|
|
|
1139 ;;===============
|
|
|
1140
|
|
|
1141 ;; Keyword testing
|
|
|
1142
|
|
|
1143 (def-edebug-spec test
|
|
|
1144 (&key (bad "one") (good "thing")))
|
|
|
1145 (defun test-key ()
|
|
|
1146 (test :bad one)
|
|
|
1147 (test1 :bad one))
|
|
|
1148
|
|
|
1149 (def-edebug-spec test
|
|
|
1150 (("one")))
|
|
|
1151
|
|
|
1152 (&rest ["one" "two"]))
|
|
|
1153
|
|
|
1154 (test (one))
|
|
|
1155
|
|
|
1156 (progn (message "one" ) )
|
|
|
1157 (testet xxx)
|
|
|
1158 (progn (message "one" ) )
|
|
|
1159
|
|
|
1160 (let ((a (+ 1 1)))
|
|
|
1161 (1+ a))
|
|
|
1162
|
|
|
1163 (mapcar 'test (list 1 2 3))
|
|
|
1164 (defun test (testing) testing)
|
|
|
1165
|
|
|
1166 ;;==================
|
|
|
1167 ;; Test defstruct.
|
|
|
1168
|
|
|
1169 (defun test ()
|
|
|
1170 (defstruct
|
|
|
1171 (test (:constructor construct (args)))
|
|
|
1172 a
|
|
|
1173 (b (+ a c))
|
|
|
1174 c))
|
|
|
1175
|
|
|
1176 ;;================
|
|
|
1177 ;; advice
|
|
|
1178
|
|
|
1179 (defun foo (x)
|
|
|
1180 "Add 1 to x."
|
|
|
1181 (1+ x))
|
|
|
1182
|
|
|
1183 (require 'advice)
|
|
|
1184
|
|
|
1185 (defadvice foo (before add2 first activate)
|
|
|
1186 " Add 2 to x"
|
|
|
1187 (setq x (1+ x)))
|
|
|
1188
|
|
|
1189 (foo 3)
|
