Mercurial > hg > xemacs-beta

comparison lisp/edebug/edebug-test.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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 . [&not 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)