1 ;;;_ debug-klink.el --- Help debugging Klink
5 ;; Copyright (C) 2010,2011 Tom Breton (Tehom)
7 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
8 ;; Keywords: convenience,tools,local
10 ;; This file is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This file is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
32 (require 'emtest
/editing
/expect nil t
)
33 (require 'emtest
/testhelp
/standard
)
34 (require 'emtest
/testhelp
/persist
)
35 (require 'emtest
/main
/define
)
38 ;;;_ , debug-klink-executable
39 (defconst debug-klink-executable
40 (emt:expand-filename-here
"klink")
41 "Absolute path to the klink executable" )
43 (defconst debug-klink
:th
:db
44 (emt:expand-filename-here
"db")
45 "File where presisting results are stored" )
46 ;;;_ , debug-klink-insert-print-type
47 (defun debug-klink-insert-print-type (obj)
48 "Insert a statement to print an pko's type"
50 (interactive "sObject: ")
52 "p (enum klink_types)_get_type("obj
")"))
53 ;;;_ , debug-klink-read-C-type
54 (defun debug-klink-read-C-type (prompt)
79 ;;;_ , debug-klink-insert-print-obj
80 (defun debug-klink-insert-print-obj (obj type
)
81 "Insert a statement to print an pko's value"
85 (read-string "Object: ")
86 (debug-klink-read-C-type "Type: ")))
88 "p *("type
" *)(((enum klink_types*)"obj
")+1)"))
89 ;;;_ , debug-klink-send-line
91 (defun debug-klink-send-line (string)
92 "Pass a line to gdb as special input
93 For (eg) setting breakpoint commands, setting trace collects, etc"
95 (interactive "sString: ")
96 (comint-send-string (get-buffer-process (current-buffer))
101 ;;;_ , debug-klink-send-end
102 (defun debug-klink-send-end ()
103 "Tell gdb the current special input is done"
106 ;;$$IMPROVE ME Make sure it's gdb buffer.
107 (comint-send-string (get-buffer-process (current-buffer)) "end\n"))
109 ;;;_ , debug-klink-prompt
110 (defconst debug-klink-prompt
"\nklink> "
115 (db-id `(persist ,debug-klink
:th
:db
)))
117 ((exec+args
(list debug-klink-executable
))
122 ;;Clean out header stuff
125 (emt:doc
"Communicating at all")
131 ((exec+args
(list debug-klink-executable
))
136 ;;Clean out header stuff
138 (t "(eval 12 (get-current-environment))"
146 (t "(eval ''(1 2 3 4)(get-current-environment))"
147 (emt:doc
"Eval in current environment")
149 (equal answer
"(1 2 3 4)")
151 (t "(eval ''(1 2 . #(3 4))(get-current-environment))"
152 (emt:doc
"Eval in current environment")
154 (equal answer
"(1 2 . #( 3 4))")
156 (t "(eval (get-current-environment)(get-current-environment))"
157 (emt:doc
"Eval in current environment")
164 (emt:doc
"Wrap behavior")
171 (emt:doc
"$define! behavior")
178 (emt:doc
"Result: a is now define 12")
184 (t "($define! b (eval ''(1 . #(2 3)) (get-current-environment)))"
185 (emt:doc
"Define b, passing a form")
192 (emt:doc
"Result: b is now defined as what the form evaluated to")
198 (t "($define! (c d e) '(1 2 3))"
199 (emt:doc
"Define c, d, and e")
206 (emt:doc
"c is defined")
213 (emt:doc
"d is defined")
220 (emt:doc
"e is defined")
226 (t "($set! (get-current-environment) f 14)"
227 (emt:doc
"$set! behavior")
228 (emt:doc
"Operation: set f in the current environment")
235 (emt:doc
"Result: f is now defined")
241 (t "($set! (get-current-environment) f 15)"
242 (emt:doc
"Operation: set f to something else")
249 (emt:doc
"Result: f now has the new definition")
255 (t "($set! (get-current-environment) (g h) '(16 157))"
256 (emt:doc
"Operation: set g and h")
263 (emt:doc
"Result: g is defined")
270 (emt:doc
"Result: h is defined")
276 (t "($define! i ($vau (a) e (eval a e)))"
277 (emt:doc
"$vau behavior")
284 (emt:doc
"$vau behavior")
290 (t "(i (i '(12 14)))"
291 (emt:doc
"$vau behavior")
297 (t "(i (car '(12 14)))"
298 (emt:doc
"$vau behavior")
304 (t "($define! j ($vau () e 12))"
305 (emt:doc
"$vau behavior")
312 (emt:doc
"$vau behavior")
318 (t "($define! k ($vau (a) e a))"
319 (emt:doc
"$vau behavior")
326 (emt:doc
"$vau behavior")
333 (emt:doc
"$vau behavior")
338 (t "($define! l ($vau (a b) e a))"
339 (emt:doc
"$vau behavior")
346 (emt:doc
"$vau behavior")
352 (t "($define! (bi ac) (make-keyed-static-variable))"
353 (emt:doc
"Keyed static variables")
360 (emt:doc
"Keyed static variables")
366 (t "(bi 4 (get-current-environment))"
367 (emt:doc
"Keyed static variables")
373 (t "(eval '(ac) (bi 4 (get-current-environment)))"
374 (emt:doc
"Keyed static variables")
381 ((exec+args
(list debug-klink-executable
))
386 ;;Clean out header stuff
390 (equal answer
"#t")))
393 (equal answer
"#t")))
395 (emt:doc
"Double-quoted nils are not `eq?' because both could \
396 conceivably be mutated")
398 (equal answer
"#f")))
399 (t "(eq? (cdr '(1)) '())"
400 (emt:doc
"nil generated by finding a tail is `eq?' to explicit nil")
402 (equal answer
"#t"))))
406 ((exec+args
(list debug-klink-executable
))
411 ;;Clean out header stuff
414 (t "(list-tail '(0 1 2) 0)"
415 (emt:doc
"Behavior of list-tail")
417 (equal answer
"(0 1 2)")))
418 (t "(list-tail '(0 1 2) 1)"
420 (equal answer
"(1 2)")))
421 (t "(list-tail '(0 1 2) 2)"
423 (equal answer
"(2)")))
424 (t "(list-tail '(0 1 2) 3)"
426 (equal answer
"()"))))
429 ((exec+args
(list debug-klink-executable
))
434 ;;Clean out header stuff
436 (t "($define! a (list 0 1 2))"
437 (emt:doc
"Make a list object")
439 (equal answer
"#inert")))
440 (t "(encycle! a 0 3)"
441 (emt:doc
"Encycle it, no prefix, the whole object")
443 (equal answer
"#inert")))
445 (emt:doc
"Show the object")
447 (equal answer
"#0=(0 1 2 #0)")))
448 (t "($define! a (list 0 1 2))"
450 (equal answer
"#inert")))
451 (t "(encycle! a 1 2)"
452 (emt:doc
"Encycle it, the whole list, with prefix")
454 (equal answer
"#inert")))
457 (equal answer
"(0 #0=1 2 #0)")))
458 (t "($define! a (list 0 1 2))"
460 (equal answer
"#inert")))
461 (t "(encycle! a 0 2)"
462 (emt:doc
"Encycle it, no prefix, less than the list length")
464 (equal answer
"#inert")))
467 (equal answer
"#0=(0 1 #0)")))
468 (t "($define! a (list 0 1 2))"
470 (equal answer
"#inert")))
471 (t "(encycle! a 1 1)"
472 (emt:doc
"Encycle it, less than the list length")
474 (equal answer
"#inert")))
477 (equal answer
"(0 #0=1 #0)"))))
482 ((exec+args
(list debug-klink-executable
))
487 ;;Clean out header stuff
490 (emt:doc
"`apply' is recognized")
492 (equal answer
"#,apply")))
493 (t "(apply list '(1 2 3) (get-current-environment))"
494 (emt:doc
"Apply works on list argument")
496 (equal answer
"(1 2 3)")))
497 (t "(apply list '(1 2 3))"
498 (emt:doc
"Apply with default env works on list argument,
501 (equal answer
"(1 2 3)")))
502 (t "(apply list '(a 2 3))"
503 (emt:doc
"Apply doesn't re-eval args, so this works even \
504 though the symbol `a' is unbound in the empty environment.")
506 (equal answer
"(a 2 3)")))
507 (t "(apply list ''(1 2 3))"
508 (emt:doc
"Double-quoted gets single-quoted")
510 (equal answer
"(#,$quote (1 2 3))")))
512 (t "(apply list '''(1 2 3))"
513 (emt:doc
"Triple-quoted gets double-quoted")
515 (equal answer
"(#,$quote (#,$quote (1 2 3)))")))
517 (t "(apply (wrap list) '(list) (get-current-environment))"
518 (emt:doc
"In normal environment, we see bindings such as `list'")
520 (equal answer
"(#,list)")))
521 (t "(apply (wrap list) '(list) (make-environment))"
522 (emt:doc
"In blank environment, we see no bindings")
524 (equal answer
"Error: eval: unbound variable: list \n")))
525 (t "(apply (wrap $sequence) '(list) (get-current-environment))"
526 (emt:doc
"In normal environment, we see bindings such as `list'")
528 (equal answer
"#,list")))
529 (t "(apply (wrap $sequence) '(list) (make-environment))"
530 (emt:doc
"In blank environment, we see no bindings")
532 (equal answer
"Error: eval: unbound variable: list \n"))))
536 ((exec+args
(list debug-klink-executable
))
541 ;;Clean out header stuff
544 (emt:doc
"Predicate integer?")
550 (emt:doc
"Predicate integer?")
557 ((exec+args
(list debug-klink-executable
))
562 ;;Clean out header stuff
565 (emt:doc
"null? is recognized")
567 (equal answer
"#,null?")))
568 ;;Must eval, which right now we don't.
571 (equal answer
"#t")))
574 (equal answer
"#f"))))
576 ;;make-encapsulation-type
578 ((exec+args
(list debug-klink-executable
))
583 ;;Clean out header stuff
585 (t "($define! (e p? d) (make-encapsulation-type))"
586 (emt:doc
"Make an encapsulation type")
588 (equal answer
"#inert")))
589 (t "($define! a (e 12))"
590 (emt:doc
"Make an instance of it")
592 (equal answer
"#inert")))
594 (emt:doc
"The predicate returns true on the instance")
596 (equal answer
"#t")))
599 (equal answer
"#f")))
602 (equal answer
"#t")))
605 (equal answer
"#f")))
607 (emt:doc
"`d' retrieves the value")
609 (equal answer
"12"))))
613 ((exec+args
(list debug-klink-executable
))
618 ;;Clean out header stuff
621 (emt:doc
"$if is recognized")
623 (equal answer
"#,$if")))
625 (emt:doc
"On true, evaluates the CONSEQUENT argument")
629 (emt:doc
"On false, evaluates the ALTERNATIVE argument")
633 (emt:doc
"On non-boolean test, raises error")
637 "dbid:80eedbc8-efd5-47c4-9c3b-d0da6c48f768")))
639 (emt:doc
"On evaluated true, evaluates the CONSEQUENT argument")
643 (emt:doc
"On evaluated false, evaluates the ALTERNATIVE argument")
645 (equal answer
"2"))))
648 ((exec+args
(list debug-klink-executable
))
653 ;;Clean out header stuff
655 (t "($cond (#t 12)(#f 13))"
656 (emt:doc
"The first true claus is evalled")
658 (equal answer
"12")))
659 (t "($cond (#f 13)(#t 12))"
660 (emt:doc
"False clauses are skipped")
662 (equal answer
"12")))
663 (t "($cond ((integer? 'a) 13)(#t 12))"
664 (emt:doc
"Guard clauses are evalled")
666 (equal answer
"12")))
667 (t "($cond ((integer? 'a) 13)((integer? 1) 12))"
668 (emt:doc
"Guard clauses are evalled")
670 (equal answer
"12")))
671 (t "($let ((x 5)) ($cond (#t (list 1 2))))"
672 (emt:doc
"The selected clause body is evalled")
674 (equal answer
"(1 2)")))
676 (emt:doc
"$cond with no clauses gives #inert")
678 (equal answer
"#inert")))
684 (emt:doc
"Variables are accessible inside clauses")
686 (equal answer
"x=5\n#inert"))))
693 ((exec+args
(list debug-klink-executable
))
698 ;;Clean out header stuff
701 (emt:doc
"$sequence with no args gives inert")
703 (equal answer
"#inert")))
705 (emt:doc
"Sequence evaluates its args")
708 (t "($sequence '1 '2)"
709 (emt:doc
"Sequence returns the value of the last element")
712 (t "($define! my-lam ($lambda v (write v)(newline)))"
713 (emt:doc
"Define a lambda having a sequence"))
715 (emt:doc
"That lambda evals all the sequence")
717 (equal answer
"(12)\n#inert"))))
722 ((exec+args
(list debug-klink-executable
))
727 ;;Clean out header stuff
729 (t "($sequence (write \"abc\") (newline))"
730 (emt:doc
"`write' displays objects escaped for read-back")
732 (equal answer
"\"abc\"\n#inert")))
733 (t "($sequence (display \"abc\") (newline))"
734 (emt:doc
"`display' displays objects unescaped")
736 (equal answer
"abc\n#inert")))
737 (t "($sequence (display '(1 2 3)) (newline))"
738 (emt:doc
"`display' can display full objects")
740 (equal answer
"(1 2 3)\n#inert")))
741 (t "($sequence (write '(1 2 3)) (newline))"
742 (emt:doc
"`write' can display full objects")
744 (equal answer
"(1 2 3)\n#inert"))))
747 ((exec+args
(list debug-klink-executable
))
752 ;;Clean out header stuff
755 (emt:doc
"Reads numbers")
757 (equal answer
"12")))
759 (emt:doc
"Reads symbols")
761 (equal answer
"sym")))
763 (emt:doc
"Reads lists, no problem with nesting depth.")
765 (equal answer
"(1 2 3)"))))
770 ((exec+args
(list debug-klink-executable
))
775 ;;Clean out header stuff
778 (emt:doc
"true/o1 predicate is recognized")
780 (equal answer
"#,true/o1")
784 (emt:doc
"true/o1 predicate gives #t")
789 (emt:doc
"`type?' is recognized")
791 (equal answer
"#,type?")
794 (t "(type? 1 true/o1)"
795 (emt:doc
"`type?' can be called")
800 (emt:doc
"`listtype' ctor is recognized")
802 (equal answer
"#,listtype")
804 (t "(listtype true/o1)"
805 (emt:doc
"`listtype' makes an operative")
807 (equal answer
"#<OPERATIVE>")
809 (t "(listtype true/o1 true/o1)"
810 (emt:doc
"`listtype' takes a list of args")
812 (equal answer
"#<OPERATIVE>")
814 (t "(type? 1 (listtype true/o1))"
815 (emt:doc
"`listtype' makes one that expects a list")
819 (t "(type? '(1) (listtype integer?))"
820 (emt:doc
"Second-level listtypes work OK")
824 (t "(type? '(#t) (listtype integer?))"
825 (emt:doc
"Second-level listtype discriminate (non)match")
829 (t "(type? '(1) (listtype true/o1 true/o1))"
830 (emt:doc
"Situation: Too few elements")
831 (emt:doc
"Result: false")
835 (t "(type? '(1) (listtype))"
836 (emt:doc
"Situation: Objects has too many elements")
837 (emt:doc
"Result: false")
841 (t "(type? '(1) (listtype true/o1 'optional true/o1))"
842 (emt:doc
"Situation: Optional elements")
843 (emt:doc
"Result: true")
847 (t "(type? '(1 2 3) (listtype true/o1 'optional true/o1))"
848 (emt:doc
"Situation: Number of items outruns number of optional elements")
849 (emt:doc
"Result: false")
853 (t "(type? '(1) (listtype true/o1 'optional 'optional))"
854 (emt:doc
"Situation: Two optional keys given")
855 (emt:doc
"Result: error")
860 "dbid:e144f830-d6a5-4240-94f0-b0b8a9890d42")))
861 (t "(type? '(1) (listtype true/o1 'DOT))"
862 (emt:doc
"Situation: Dot spec has no spec after it")
863 (emt:doc
"Result: error")
865 (emt:eq-persist-p
#'equal
867 "dbid:37a39a99-8b11-4d6f-9e31-033af8d73d41")))
868 (t "(type? '(1) (listtype true/o1 'DOT true/o1 true/o1))"
869 (emt:doc
"Situation: Dot spec has more than 1 spec after it")
870 (emt:doc
"Result: error")
872 (emt:eq-persist-p
#'equal
874 "dbid:7f057673-3b94-4e4c-a25c-b09ed5239af2")))
875 (t "(type? '(1 2 3) (listtype true/o1 'DOT true/o1))"
876 (emt:doc
"Situation: Dot spec is satisfied")
877 (emt:doc
"Result: true")
881 (t "(type? '(1 2 3) (listtype true/o1 'DOT integer?))"
882 (emt:doc
"Situation: Dot spec is reached but doesn't match")
883 (emt:doc
"Result: false")
887 (t "(type? '(1 2 3) (listtype true/o1 'REPEAT integer?))"
888 (emt:doc
"Situation: Repeat spec is used and matches")
889 (emt:doc
"Result: true")
893 (t "(type? '(1 2 #t) (listtype true/o1 'REPEAT integer?))"
894 (emt:doc
"Situation: Repeat spec is used but doesn't match")
895 (emt:doc
"Result: false")
899 (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT integer? true/o1))"
900 (emt:doc
"Situation: Repeat spec is used, has 2 items, matches")
901 (emt:doc
"Result: true")
905 (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT true/o1 integer?))"
906 (emt:doc
"Situation: Repeat spec is used, has 2 items, but doesn't match")
907 (emt:doc
"Result: false")
911 (t "(type? '(1) (listtype true/o1 'REPEAT integer?))"
912 (emt:doc
"Situation: Repeat spec is used, zero items available")
913 (emt:doc
"Result: true")
917 ;; $$IMPROVE ME Test circularity, use encycle!
922 ((exec+args
(list debug-klink-executable
))
927 ;;Clean out header stuff
930 (t "destructure-list"
931 (emt:doc
"Test `destructure-list'")
932 (emt:doc
"ctor is recognized")
934 (equal answer
"#,destructure-list")
936 (t "(destructure-list true/o1)"
937 (emt:doc
"It makes an operative")
939 (equal answer
"#<OPERATIVE>")
941 (t "(destructure-list true/o1 true/o1)"
942 (emt:doc
"It takes a list of args")
944 (equal answer
"#<OPERATIVE>")
946 (t "(do-destructure 1 (destructure-list true/o1))"
947 (emt:doc
"It makes one that expects a list")
948 (emt:doc
"Result: Error")
950 (emt:eq-persist-p
#'equal
952 "dbid:3e113873-73a0-46f5-8e14-f41034780317")))
953 (t "(do-destructure '(1) (destructure-list integer?))"
954 (emt:doc
"Second-level destructures work OK")
956 (equal answer
"#( 1)")
958 (t "(do-destructure '(#t) (destructure-list integer?))"
959 (emt:doc
"Second-level destructure discriminate (non)match")
960 (emt:doc
"Result: Error")
962 (emt:eq-persist-p
#'equal
964 "dbid:dc2648ef-22cb-41c2-8f9b-67548b0a3b7a")))
965 (t "(do-destructure '(1) (destructure-list true/o1 true/o1))"
966 (emt:doc
"Situation: Too few elements")
967 (emt:doc
"Result: Error")
972 "dbid:b50e8f78-6652-418d-9b44-1ff676946970")))
973 (t "(do-destructure '(1) (destructure-list))"
974 (emt:doc
"Situation: Objects has too many elements")
975 (emt:doc
"Result: Error")
980 "dbid:ee168f5d-5d87-4792-9dba-0fd0ac7c14a4")))
982 (t "(do-destructure '(1) (destructure-list true/o1 'optional true/o1))"
983 (emt:doc
"Situation: Optional elements")
984 (emt:doc
"Result: true")
986 (equal answer
"#( 1 #inert)")
989 (t "(do-destructure '(1 2 3) (destructure-list true/o1 'optional true/o1))"
990 (emt:doc
"Situation: Number of items outruns number of optional elements")
991 (emt:doc
"Result: Error")
993 (emt:eq-persist-p
#'equal answer
994 "dbid:a1bd1321-532e-4187-af64-278c009a7f97")))
996 (t "(do-destructure '(1) (destructure-list true/o1 'optional 'optional))"
997 (emt:doc
"Situation: Two optional keys given")
998 (emt:doc
"Result: Error")
1003 "dbid:ece901d5-4ac0-496e-a9e2-83423a933522")))
1005 (t "(do-destructure '(1) (destructure-list true/o1 'dot))"
1006 (emt:doc
"Situation: Dot spec has no spec after it")
1007 (emt:doc
"Result: Error")
1009 (emt:eq-persist-p
#'equal
1011 "dbid:8e8711ba-bada-4223-a212-3256d6a2e497")))
1013 (t "(do-destructure '(1) (destructure-list true/o1 'dot true/o1 true/o1))"
1014 (emt:doc
"Situation: Dot spec has more than 1 spec after it")
1015 (emt:doc
"Result: Error")
1017 (emt:eq-persist-p
#'equal
1019 "dbid:4d68ceb6-f450-4218-b222-c10019a39819")))
1021 (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot true/o1))"
1022 (emt:doc
"Situation: Dot spec is satisfied")
1023 (emt:doc
"Result: true")
1025 (equal answer
"#( 1 (2 3))")
1028 (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot integer?))"
1029 (emt:doc
"Situation: Dot spec is reached but doesn't match")
1030 (emt:doc
"Result: Error")
1032 (emt:eq-persist-p
#'equal answer
1033 "dbid:266cbd1e-734c-4a81-bac6-e9d9a3424e79"))))
1037 ((exec+args
(list debug-klink-executable
))
1039 (prompt "\nklink> ")
1042 ;;Clean out header stuff
1045 (t "(where-typemiss 1 (listtype true/o1))"
1046 (emt:doc
"`listtype' makes one that expects a list")
1048 (equal answer
"(0 too-few)")
1050 (t "(where-typemiss '(#t) (listtype integer?))"
1051 (emt:doc
"Second-level listtype discriminate (non)match")
1052 ;;Use persist because the form of the printout changes.
1054 (emt:eq-persist-p
#'equal answer
1055 "dbid:cc211ae0-718b-4462-9062-7f0077cdf162")))
1056 (t "(where-typemiss '(1) (listtype true/o1 true/o1))"
1057 (emt:doc
"Situation: Too few elements")
1059 (equal answer
"(1 too-few)")
1061 (t "(where-typemiss '(1) (listtype))"
1062 (emt:doc
"Situation: Objects has too many elements")
1064 (equal answer
"(0 too-many)")
1066 (t "(where-typemiss '(1 2 3) (listtype true/o1 'optional true/o1))"
1067 (emt:doc
"Situation: Number of items outruns number of optional elements")
1069 (equal answer
"(2 too-many)")
1071 (t "(where-typemiss '(1 2 3) (listtype true/o1 'dot integer?))"
1072 (emt:doc
"Situation: Dot spec is reached but doesn't match")
1074 (emt:eq-persist-p
#'equal answer
1075 "dbid:2f83b114-6bdf-4c7d-9a76-0d3e8b43483c")))
1076 (t "(where-typemiss '(1 2 #t) (listtype true/o1 'repeat integer?))"
1077 (emt:doc
"Situation: Repeat spec is used but doesn't match")
1079 (emt:eq-persist-p
#'equal answer
1080 "dbid:f90a1f49-9180-4817-8095-6422ee058745")))
1081 (t "(where-typemiss '(1 2 #t 4 #t) (listtype true/o1 'repeat true/o1 integer?))"
1082 (emt:doc
"Situation: Repeat spec is used, has 2 items, but doesn't match")
1084 (emt:eq-persist-p
#'equal answer
1085 "dbid:374c6ab3-7907-4ff5-b14d-e41584593296")))
1086 ;; $$IMPROVE ME Test circularity, use encycle!
1089 ;;On get-list-metrics
1091 ((exec+args
(list debug-klink-executable
))
1093 (prompt "\nklink> ")
1096 ;;Clean out header stuff
1098 (t "(length '(0 1))"
1100 (equal answer
"2")))
1101 (t "(finite-list? '(0 1))"
1103 (equal answer
"#t")))
1104 (t "(finite-list? #f)"
1106 (equal answer
"#f")))
1107 (t "(get-list-metrics '(0 1))"
1109 (equal answer
"(2 1 2 0)")))
1110 (t "(get-list-metrics #f)"
1112 (equal answer
"(0 0 0 0)")))
1113 (t "(get-list-metrics '(0 . 1))"
1115 (equal answer
"(1 0 1 0)")))
1116 (t "($define! a (list 12))"
1117 (emt:doc
"Make a circular object"))
1118 (t "(set-cdr! a a)")
1119 (t "(get-list-metrics a)"
1120 (emt:doc
"List metrics of a circular object")
1122 (equal answer
"(1 0 0 1)")))
1127 ;;On making environment
1129 ((exec+args
(list debug-klink-executable
))
1131 (prompt "\nklink> ")
1134 ;;Clean out header stuff
1136 (t "(make-environment (get-current-environment))"
1137 (emt:doc
"Can make an environment")
1139 (equal answer
"#<ENVIRONMENT>")))
1140 (t "(make-environment)"
1141 (emt:doc
"Can make an empty environment")
1143 (equal answer
"#<ENVIRONMENT>")))
1145 (t "(eval 'make-environment (make-environment))"
1146 (emt:doc
"Empty environment does not bind things")
1149 #'equal answer
"dbid:930c9cb4-c8e3-446a-9d0f-80a7a01edf2e")))
1151 (t "($define! env1 (make-environment))"
1152 (emt:doc
"Define example environments")
1154 (equal answer
"#inert")))
1155 (t "($define! env2 (make-environment))"
1157 (equal answer
"#inert")))
1158 (t "($set! env1 a 12)"
1159 (emt:doc
"Define things in those example environments")
1161 (equal answer
"#inert")))
1162 (t "($set! env2 b 144)"
1164 (equal answer
"#inert")))
1166 (emt:doc
"The respective bindings are available in the environments")
1168 (equal answer
"12")))
1171 (equal answer
"144")))
1172 (t "($define! env1+2 (make-environment env1 env2))"
1173 (emt:doc
"Can make an environment from multiple parents")
1175 (equal answer
"#inert")))
1176 (t "(eval 'a env1+2)"
1177 (emt:doc
"It contains the bindings of both environments")
1179 (equal answer
"12")))
1180 (t "(eval 'b env1+2)"
1182 (equal answer
"144"))))
1185 ((exec+args
(list debug-klink-executable
))
1187 (prompt "\nklink> ")
1191 (t "(reverse-lookup get-current-environment (get-current-environment))"
1192 (emt:doc
"Operation: look up an object we know is bound")
1193 (emt:doc
"Result: We find it")
1195 (equal answer
"get-current-environment")))
1196 (t "(reverse-lookup reverse-lookup (get-current-environment))"
1197 (emt:doc
"Same on another object")
1199 (equal answer
"reverse-lookup")))
1200 (t "(reverse-lookup 'example-unsymboled-object (get-current-environment))"
1201 (emt:doc
"Operation: look up an object we know is not bound")
1202 (emt:doc
"Result: Error")
1204 (emt:eq-persist-p
#'equal answer
1205 "dbid:c3ec8dcc-39b2-4885-b4f3-f6e5f018c11e")))
1206 (t "($define! a (list))"
1207 (emt:doc
"Make an object we will look for"))
1208 (t "($define! my-env (make-environment))")
1209 (t "($set! my-env b a)"
1210 (emt:doc
"In my-env, define b as that object"))
1211 (t "($set! my-env b 13)"
1212 (emt:doc
"Now define b as something else"))
1213 (t "(reverse-lookup a my-env)"
1214 (emt:doc
"Look up the original object")
1218 "dbid:673c63c9-1844-4c7f-b67d-22c6ef88fc66")))
1219 (t "($define! my-env2 (make-environment))"
1220 (emt:doc
"Make another empty environment"))
1221 (t "($set! my-env2 c a)"
1222 (emt:doc
"In my-env2, define c as that object"))
1223 (t "($set! my-env2 b a)"
1224 (emt:doc
"In my-env2, define b as that object"))
1225 (t "($set! my-env2 b 13)"
1226 (emt:doc
"Now define b as something else"))
1227 (t "(reverse-lookup a my-env2)"
1228 (emt:doc
"Operation: Look up the original object")
1229 (emt:doc
"Result: We find its binding, c")
1231 (equal answer
"c")))
1232 (t "($set! my-env2 b a)"
1233 (emt:doc
"Define b as that object again"))
1234 (t "($define! my-env3 (make-environment my-env2))"
1235 (emt:doc
"Make an environment derived from my-env2"))
1236 (t "($set! my-env3 b 13)"
1237 (emt:doc
"There set b to be something else"))
1238 (t "(reverse-lookup a my-env3)"
1239 (emt:doc
"Operation: Look up the original object")
1240 (emt:doc
"Result: We find its binding")
1242 (equal answer
"c"))))
1244 ;;On printing, esp circular objects
1246 ((exec+args
(list debug-klink-executable
))
1248 (prompt "\nklink> ")
1253 (t "print-lookup-env"
1255 (equal answer
"#,print-lookup-env"))
1258 (emt:doc
"Lists print OK")
1260 (equal answer
"(1 2)")))
1262 (emt:doc
"Bound objects print a lowquote and their binding")
1264 (equal answer
"#,wrap")))
1267 (equal answer
"#,list")))
1269 (emt:doc
"These objects are actual working combiners.")
1271 (equal answer
"(#,list)")))
1275 ;;On get-recurrences
1277 ((exec+args
(list debug-klink-executable
))
1279 (prompt "\nklink> ")
1284 (t "($define! cycles-nil (get-recurrences '()))"
1285 (emt:doc
"`cycles-nil' is the recurrences of object '()"))
1286 (t "(recurrence-table? cycles-nil)"
1288 (equal answer
"#t")))
1290 (t "(recurrences-get-object-count cycles-nil '())"
1291 (emt:doc
"Nils are not counted")
1293 (equal answer
"0")))
1294 (t "($define! cycles-list (get-recurrences (list 12 144)))"
1295 (emt:doc
"`cycles-list' is the recurrences of an ordinary list"))
1296 (t "(recurrence-table? cycles-list)"
1298 (equal answer
"#t")))
1299 (t "($define! cycles-many-nils (get-recurrences '()))"
1300 (emt:doc
"`cycles-many-nils' is the recurrences of object of
1302 (t "(recurrence-table? cycles-many-nils)"
1304 (equal answer
"#t")))
1305 (t "(recurrences-get-object-count cycles-many-nils '())"
1306 (emt:doc
"Nils do not constitute shared objects")
1308 (equal answer
"0")))
1309 (t "($define! cycles-f (get-recurrences '(#f #f)))"
1310 (emt:doc
"Get the recurrences of any object with repeated objects"))
1311 (t "(recurrence-table? cycles-f)"
1313 (equal answer
"#t")))
1314 (t "(recurrences-get-object-count cycles-f #f)"
1316 (equal answer
"2")))
1317 (t "($define! a (list 12))"
1318 (emt:doc
"Define a circular object"))
1319 (t "(set-cdr! a a)")
1320 (t "($define! cycles-a (get-recurrences a))")
1321 (t "(recurrence-table? cycles-a)"
1323 (equal answer
"#t")))
1324 (t "(recurrences-get-object-count cycles-a a)"
1326 (equal answer
"2"))))
1328 ;;On lists and wrapping
1330 ((exec+args
(list debug-klink-executable
))
1332 (prompt "\nklink> ")
1337 (emt:doc
"List works")
1339 (equal answer
"(1 2)")))
1340 (t "(reverse (list 1 2))"
1341 (emt:doc
"Reverse works")
1343 (equal answer
"(2 1)")))
1344 (t "((wrap list) 1 2)"
1345 (emt:doc
"Wrap wrapped over an applicative works (wrap^2)")
1347 (equal answer
"(1 2)")))
1348 (t "((wrap list) '1 '2)"
1349 (emt:doc
"Wrap^2 eliminates at least one level of quoting")
1351 (equal answer
"(1 2)")))
1352 (t "((wrap list) ''1 ''2)"
1353 (emt:doc
"Wrap^2 eliminates two levels of quoting")
1355 (equal answer
"(1 2)")))
1356 (t "((wrap list) '''1 '''2)"
1357 (emt:doc
"Wrap^2 leaves one of three levels of quoting")
1359 (equal answer
"((#,$quote 1) (#,$quote 2))")))
1360 (t "((wrap (wrap list)) '''1 '''2)"
1361 (emt:doc
"Wrap^3 eliminates three levels of quoting")
1363 (equal answer
"(1 2)"))))
1365 ;;On map, map1, counted-map/4
1367 ((exec+args
(list debug-klink-executable
))
1369 (prompt "\nklink> ")
1373 (t "(map1 list '(1 2 3))"
1374 (emt:doc
"It works")
1376 (equal answer
"((1) (2) (3))")))
1377 (t "(map1 (unwrap list) '(1 2 3))"
1378 (emt:doc
"It wants an applicative argument")
1380 (emt:eq-persist-p
#'equal
1382 "dbid:bf93cc1e-534c-4a1f-8762-3072e59dcb3c")))
1383 (t "(counted-map/4 2 1 list '((1 2)))"
1384 (emt:doc
"Generally behaves like `map'")
1386 (equal answer
"((1) (2))")))
1387 (t "(counted-map/4 1 1 list '((1 2)))"
1388 (emt:doc
"Stops after N elements")
1390 (equal answer
"((1))")))
1391 (t "(counted-map/4 2 2 list '((1 2) (11 12)))"
1392 (emt:doc
"Can treat multiple lists")
1394 (equal answer
"((1 11) (2 12))")))
1395 (t "(map list '(1 2))"
1396 (emt:doc
"Check full `map'")
1398 (equal answer
"((1) (2))")))
1399 (t "(map list '(1 2) '(11 12))"
1401 (equal answer
"((1 11) (2 12))"))))
1405 ((exec+args
(list debug-klink-executable
))
1407 (prompt "\nklink> ")
1411 (t "($define! my-con-list (call/cc list))"
1412 (emt:doc
"Make an object containing a continuation"))
1414 (emt:doc
"Check what we got")
1416 (equal answer
"(#<CONTINUATION>)")))
1417 (t "($define! my-con (car my-con-list))"
1418 (emt:doc
"Extract that continuation"))
1420 (emt:doc
"Check what we got")
1422 (equal answer
"#<CONTINUATION>")))
1423 (t "(continuation->applicative my-con)"
1424 (emt:doc
"Try a simple call")
1426 (equal answer
"#<APPLICATIVE>")))
1427 (t "((continuation->applicative my-con) 12)"
1428 (emt:doc
"Use the continuation")
1430 (equal answer
"#inert")))
1432 (emt:doc
"my-con-list got redefined by the continuation")
1434 (equal answer
"(12)")))
1435 (t "(apply (continuation->applicative (extend-continuation my-con
1437 (display \"arrived at the continuation with \")
1439 (newline)))) '(144))"
1442 "arrived at the continuation with (144)\n#inert")))
1443 (t "($define! my-unguarded-con (guard-continuation '() my-con '()))"
1444 (emt:doc
"Make a continuation that has empty list of guards")
1446 (equal answer
"#inert")))
1447 (t "(apply (continuation->applicative my-unguarded-con) '(145))"
1448 (emt:doc
"Applies without problem")
1450 (equal answer
"#inert")))
1452 (emt:doc
"The continuation got called")
1454 (equal answer
"(145)")))
1456 (t "($define! my-guarded-con (guard-continuation
1457 (list (list root-continuation
1458 ($lambda (v %ignore)
1459 (display \"entering the continuation with \")
1464 (list (list root-continuation
1465 ($lambda (v %ignore)
1466 (display \"exiting the continuation with \")
1470 (emt:doc
"Create a guarded continuation")
1472 (equal answer
"#inert")))
1474 (emt:doc
"Type is correct")
1476 (equal answer
"#<CONTINUATION>")))
1477 (t "(continuation->applicative my-guarded-con)"
1478 (emt:doc
"Type is correct")
1480 (equal answer
"#<APPLICATIVE>")))
1481 (t "(apply (continuation->applicative my-guarded-con) '(146))"
1482 (emt:doc
"We see it calls the guard and continues")
1484 (equal answer
"entering the continuation with (146)\n#inert")))
1486 (emt:doc
"The continuation got called")
1488 (equal answer
"(146)")))
1489 (t "(guard-dynamic-extent
1491 ($lambda () (display \"Got here\")(newline))
1493 (emt:doc
"Calls the combiner arg with no variables")
1495 (equal answer
"Got here\n#inert")))
1496 (t "(guard-dynamic-extent
1497 (list (list root-continuation ($lambda (v %ignore)
1498 (display \"Abnormally entering dynamic extent.\")
1501 ($lambda () (display \"Got here\")(newline))
1503 (emt:doc
"Does not initially call the entry guards")
1505 (equal answer
"Got here\n#inert")))
1506 (t "(guard-dynamic-extent
1508 ($lambda () (display \"Got here\")(newline))
1509 (list (list root-continuation ($lambda (v %ignore)
1510 (display \"Abnormally entering dynamic extent.\")
1513 (emt:doc
"Does not initially call the exit guards")
1515 (equal answer
"Got here\n#inert"))))
1521 ((exec+args
(list debug-klink-executable
))
1523 (prompt "\nklink> ")
1528 (emt:doc
"Is recognized")
1530 (equal answer
"#,and?")))
1532 (emt:doc
"Given no args, returns true")
1534 (equal answer
"#t")))
1536 (emt:doc
"Accepts 1 arg")
1538 (equal answer
"#t")))
1540 (emt:doc
"Accepts 2 args")
1542 (equal answer
"#t")))
1544 (emt:doc
"If an arg is false, returns false")
1546 (equal answer
"#f")))
1547 (t "(and? #t (integer? 1))"
1548 (emt:doc
"Arguments are evaluated")
1550 (equal answer
"#t")))
1551 (t "(and? #t (integer? \"11\"))"
1552 (emt:doc
"The evaluated value is used")
1554 (equal answer
"#f")))
1556 (emt:doc
"If there are only false clauses, returns false")
1558 (equal answer
"#f")))
1560 (emt:doc
"If there is any true clause, return true")
1562 (equal answer
"#t")))
1565 (equal answer
"#t")))
1567 (emt:doc
"The evaluating variant")
1569 (equal answer
"#t")))
1572 (equal answer
"#f")))
1575 (equal answer
"#f")))
1576 (t "($and? ($sequence (display \"One\")(newline) #f))"
1577 (emt:doc
"Evaluates some of its args, at least the first one")
1579 (equal answer
"One\n#f")))
1580 (t "($and? ($sequence (display \"One\")(newline) #t)($sequence (display \"Two\")(newline) #f))"
1582 (equal answer
"One\nTwo\n#f")))
1583 (t "($and? ($sequence (display \"One\")(newline) #f)($sequence (display \"Two\")(newline) #f))"
1585 (equal answer
"One\n#f")))
1586 (t "(every?/2-xary and? '())"
1587 (emt:doc
"xary-1 `every?/2-xary' is available (in `simple' environment)")
1589 (equal answer
"#t")))
1590 (t "(every?/2-xary and? '(()))"
1591 (emt:doc
"No elements")
1593 (equal answer
"#t")))
1594 (t "(every?/2-xary and? '((#f)))"
1595 (emt:doc
"One element containing one element (for `and?')")
1597 (equal answer
"#f")))
1598 (t "(every?/2-xary and? '((#t #t)))"
1599 (emt:doc
"More elements")
1601 (equal answer
"#t")))
1602 (t "(every?/2-xary and? '((#t #t)(#t)))"
1604 (equal answer
"#t")))
1605 (t "(every?/2-xary and? '((#t #t)(#f)))"
1607 (equal answer
"#f"))))
1611 ((exec+args
(list debug-klink-executable
))
1613 (prompt "\nklink> ")
1618 (emt:doc
"Test that comparisons work as expected")
1620 (equal answer
"#t")))
1623 (equal answer
"#f")))
1626 (equal answer
"#f")))
1629 (equal answer
"#f")))
1632 (equal answer
"#f")))
1635 (equal answer
"#t")))
1638 (equal answer
"#t")))
1641 (equal answer
"#t")))
1644 (equal answer
"#f")))
1647 (equal answer
"#f")))
1650 (equal answer
"#t")))
1653 (equal answer
"#t")))
1654 (t "(compare-neighbors <? '(0 1 2))"
1656 (equal answer
"#t")))
1657 (t "(compare-neighbors <? '(0))"
1659 (equal answer
"#t")))
1660 (t "(compare-neighbors <=? '(0 1 2))"
1662 (equal answer
"#t")))
1663 (t "(compare-neighbors <? '(0 1 1 2))"
1665 (equal answer
"#f")))
1666 (t "(compare-neighbors <=? '(0 1 1 2))"
1668 (equal answer
"#t"))))
1672 ((exec+args
(list debug-klink-executable
))
1674 (prompt "\nklink> ")
1679 (emt:doc
"N-ary addition works")
1681 (equal answer
"6")))
1682 (t "(+ 1 2 (+ 3 0))"
1683 (emt:doc
"N-ary addition evaluates its arguments")
1685 (equal answer
"6")))
1687 (emt:doc
"N-ary addition gives 0 on no operands")
1689 (equal answer
"0")))
1691 (emt:doc
"N-ary addition with 1 operand works")
1693 (equal answer
"3")))
1696 (emt:doc
"N-ary multiplication works")
1698 (equal answer
"60")))
1699 (t "(* 1 2 (* 3 10))"
1700 (emt:doc
"N-ary multiplication evaluates its arguments")
1702 (equal answer
"60")))
1704 (emt:doc
"N-ary multiplication gives 0 on no operands")
1706 (equal answer
"1")))
1708 (emt:doc
"N-ary multiplication with 1 operand works")
1710 (equal answer
"3")))
1712 (emt:doc
"Dividing an integer by itself gives 1")
1714 (equal answer
"1")))
1716 (emt:doc
"Dividing an integer by 1 gives itself")
1718 (equal answer
"2")))
1720 (emt:doc
"For real division, it doesn't floor")
1722 (equal answer
"0.5")))
1725 (equal answer
"2")))
1728 (equal answer
"1")))
1731 (equal answer
"0.5")))
1734 (equal answer
"80")))
1737 (equal answer
"75")))
1739 (emt:doc
"`-' with no subtrahends raises error")
1741 (emt:eq-persist-p
#'equal answer
1742 "dbid:d0afc822-58f7-4921-b37d-57d45cd6b5e0")))
1744 (emt:doc
"`/' with no divisors raises error")
1746 (emt:eq-persist-p
#'equal answer
1747 "dbid:2afbb9f8-3016-46a5-bb93-9d9d2fdd0e98"))))
1750 ((exec+args
(list debug-klink-executable
))
1752 (prompt "\nklink> ")
1757 (emt:doc
"Compares numbers correctly")
1759 (equal answer
"#t")))
1762 (equal answer
"#f")))
1763 (t "(equal?/2 3 '(1 2))"
1765 (equal answer
"#f")))
1766 (t "(equal?/2 'a 'a)"
1767 (emt:doc
"Compares symbols correctly")
1769 (equal answer
"#t")))
1770 (t "(equal?/2 'a 'b)"
1772 (equal answer
"#f")))
1773 (t "(equal?/2 '(1 2) '(1 2))"
1774 (emt:doc
"Compares lists correctly")
1776 (equal answer
"#t")))
1777 (t "(equal?/2 '(1 2) '(1 3))"
1778 (emt:doc
"Compares lists correctly")
1780 (equal answer
"#f")))
1781 (t "(equal?/2 \"meet\" \"meet\")"
1782 (emt:doc
"Compares strings correctly")
1784 (equal answer
"#t")))
1785 (t "(equal?/2 \"meet\" \"not\")"
1786 (emt:doc
"Compares strings correctly")
1788 (equal answer
"#f")))
1790 (emt:doc
"Given the empty list, is true")
1792 (equal answer
"#t")))
1799 ((exec+args
(list debug-klink-executable
))
1801 (prompt "\nklink> ")
1805 (t "($define! a #f)")
1806 (t "($define! b #f)")
1807 (t "($provide! (b c) ($define! a 13) ($define! b 12) ($define! c 144))"
1808 (emt:doc
"`$provide!' b and c but not a")
1810 (equal answer
"#inert")))
1812 (emt:doc
"`a' is what it was")
1814 (equal answer
"#f")))
1816 (emt:doc
"b has been changed")
1818 (equal answer
"12")))
1820 (emt:doc
"c is available")
1822 (equal answer
"144")))
1823 (t "((wrap $binds?/2) (get-current-environment) 'wrap)"
1824 (emt:doc
"Test the simple version")
1825 (emt:doc
"We know `wrap' should be bound")
1827 (equal answer
"#t")))
1828 (t "((wrap $binds?/2) (get-current-environment) '$binds?/2)"
1829 (emt:doc
"We know `$binds?/2' should be bound")
1831 (equal answer
"#t")))
1832 (t "((wrap $binds?/2) (make-environment) '$binds?/2)"
1833 (emt:doc
"`make-environment' should bind nothing.")
1835 (equal answer
"#f")))
1836 (t "((wrap $binds?/2) (make-environment) 'unlikely-to-be-bound)"
1837 (emt:doc
"In case the preceding test worked for the wrong \
1838 reason, ie that `make-environment' leaked")
1840 (equal answer
"#f")))
1841 (t "($binds? (get-current-environment) $binds?)"
1842 (emt:doc
"The N-ary version works")
1844 (equal answer
"#t")))
1845 (t "($binds? (make-environment) $binds?)"
1846 (emt:doc
"Discriminates")
1848 (equal answer
"#f")))
1849 (t "($binds? (get-current-environment) list wrap)"
1850 (emt:doc
"Takes more than 1 arg")
1852 (equal answer
"#t"))))
1855 ((exec+args
(list debug-klink-executable
))
1857 (prompt "\nklink> ")
1861 (t "($define! a (open-input-file \"test-m1.krn\"))"
1862 (emt:doc
"Open an input port from a known file")
1864 (equal answer
"#inert")))
1866 (emt:doc
"We got a port")
1868 (equal answer
"#<PORT>")))
1870 (emt:doc
"Check the first few characters against known values")
1872 (equal answer
"#\\;")))
1875 (equal answer
"#\\newline")))
1878 (equal answer
"#\\;"))))
1881 ((exec+args
(list debug-klink-executable
))
1883 (prompt "\nklink> ")
1887 (t "($binds? (get-current-environment) not-bound-in-ground)"
1888 (emt:doc
"Validate that `not-bound-in-ground' is not already bound")
1890 (equal answer
"#f")))
1891 (t "($define! a (make-kernel-standard-environment))"
1892 (emt:doc
"Create a standard environment")
1894 (equal answer
"#inert")))
1895 (t "($binds? a $binds?)"
1896 (emt:doc
"The ground bindings are available")
1898 (equal answer
"#t")))
1899 (t "($set! a not-bound-in-ground 12)"
1900 (emt:doc
"set `not-bound-in-ground' in a")
1902 (equal answer
"#inert")))
1903 (t "($binds? a not-bound-in-ground)"
1904 (emt:doc
"It's bound in `a'")
1906 (equal answer
"#t")))
1907 (t "(eval 'not-bound-in-ground a)"
1908 (emt:doc
"It has the right value in `a'")
1910 (equal answer
"12")))
1911 (t "($binds? (get-current-environment) not-bound-in-ground)"
1912 (emt:doc
"It's not bound in current environment")
1914 (equal answer
"#f")))
1915 (t "($define! x (get-module \"test-m1.krn\"))"
1916 (emt:doc
"In `x', no parameters are defined")
1917 (emt:doc
(concat "Answer: " answer
)))
1918 (t "($define! y (get-module \"test-m1.krn\"
1919 ($bindings->environment (baz \"quux\"))))"
1920 (emt:doc
"In `y', `baz' is defined")
1921 (emt:doc
(concat "Answer: " answer
)))
1922 (t "($define! z (get-module \"test-m1.krn\"
1923 ($bindings->environment (quux \"baz\"))))"
1924 (emt:doc
"In `z', quux' is defined")
1925 (emt:doc
(concat "Answer: " answer
)))
1926 (t "(write (($remote-eval foo x)))"
1927 (emt:doc
"Query `x'")
1929 (equal answer
"no parameters\n#inert#inert")))
1930 (t "(write (($remote-eval foo y)))"
1931 (emt:doc
"Query `y'")
1933 (equal answer
"parameters, but no quux\n#inert#inert")))
1934 (t "(write (($remote-eval foo z)))"
1935 (emt:doc
"Query `z'")
1937 (equal answer
"parameters\n\"baz\"#inert"))))
1940 ((exec+args
(list debug-klink-executable
))
1942 (prompt "\nklink> ")
1946 (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
1947 ((x . y)) x) (force low-promise))))) (force p1))"
1948 (emt:doc
"WRITE ME")
1950 (equal answer
"1")))
1951 (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
1952 ((x . y)) y) (force low-promise))))) (force p1))"
1953 (emt:doc
"WRITE ME")
1955 (equal answer
"2"))))
1957 ((exec+args
(list debug-klink-executable
))
1959 (prompt "\nklink> ")
1964 (emt:doc
"Turn profiling on, and it should not have been on before")
1966 (equal answer
"0")))
1968 (emt:doc
"Now it's on, and this is our first profiled call")
1970 (equal answer
"1")))
1971 (t "(get-profiling-data)"
1972 (emt:doc
"We see the profiling data from just the earlier call")
1973 (emt:doc
"All profiling data may change, we're interested in
1974 its general behavior and in including the functions we just called")
1976 (emt:eq-persist-p
#'equal
1978 "dbid:787cceb2-39a0-46c3-97a7-a23a3de3da4b")))
1980 (emt:doc
"Run this call again")
1982 (equal answer
"1")))
1983 (t "(get-profiling-data)"
1984 (emt:doc
"Now profiling data shows 2 calls to `profiling', 1
1985 to `get-profiling-data'")
1987 (emt:eq-persist-p
#'equal
1989 "dbid:26b534dc-b589-4d2c-9026-7c5ea9b8a858")))
1990 (t "(get-profiling-data)"
1993 (emt:eq-persist-p
#'equal
1995 "dbid:3c018d05-1938-4af6-8ad3-5325b9d16fd6"))))
1999 ;;;_ , debug-klink-capture-form
2001 (defun debug-klink-capture-form ()
2002 "Push entries for an `emtr:expect' script onto the kill ring.
2003 Basically `emtr:expect:buffer-capture-form' specialized for klink.
2005 Current buffer should contain a transcript of a klink session."
2009 (emtr:expect
:buffer-capture-form debug-klink-prompt t t
))
2014 (provide 'debug-klink
)
2016 ;;;_ * Local emacs vars.
2017 ;;;_ + Local variables:
2022 ;;; debug-klink.el ends here