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)"))))
481 ((exec+args
(list debug-klink-executable
))
486 ;;Clean out header stuff
488 (t "(stream->list '())"
489 (emt:doc
"Works on null")
491 (equal answer
"()")))
492 (t "(stream->list ($lazy '()))"
493 (emt:doc
"Works on promised null")
495 (equal answer
"()")))
496 (t "(stream->list ($lazy '(1)))"
498 (equal answer
"(1)")))
499 (t "(stream->list (list* 1 ($lazy '())))"
500 (emt:doc
"Works on lazy empty tail")
502 (equal answer
"(1)")))
503 (t "(stream->list (list* 1 ($lazy '(2))))"
505 (equal answer
"(1 2)")))
506 (t "(stream->list (list* 1 2 ($lazy '())))"
508 (equal answer
"(1 2)"))))
513 ((exec+args
(list debug-klink-executable
))
518 ;;Clean out header stuff
521 (emt:doc
"`apply' is recognized")
523 (equal answer
"#,apply")))
524 (t "(apply list '(1 2 3) (get-current-environment))"
525 (emt:doc
"Apply works on list argument")
527 (equal answer
"(1 2 3)")))
528 (t "(apply list '(1 2 3))"
529 (emt:doc
"Apply with default env works on list argument,
532 (equal answer
"(1 2 3)")))
533 (t "(apply list '(a 2 3))"
534 (emt:doc
"Apply doesn't re-eval args, so this works even \
535 though the symbol `a' is unbound in the empty environment.")
537 (equal answer
"(a 2 3)")))
538 (t "(apply list ''(1 2 3))"
539 (emt:doc
"Double-quoted gets single-quoted")
541 (equal answer
"(#,$quote (1 2 3))")))
543 (t "(apply list '''(1 2 3))"
544 (emt:doc
"Triple-quoted gets double-quoted")
546 (equal answer
"(#,$quote (#,$quote (1 2 3)))")))
548 (t "(apply (wrap list) '(list) (get-current-environment))"
549 (emt:doc
"In normal environment, we see bindings such as `list'")
551 (equal answer
"(#,list)")))
552 (t "(apply (wrap list) '(list) (make-environment))"
553 (emt:doc
"In blank environment, we see no bindings")
555 (equal answer
"Error: eval: unbound variable: list \n")))
556 (t "(apply (wrap $sequence) '(list) (get-current-environment))"
557 (emt:doc
"In normal environment, we see bindings such as `list'")
559 (equal answer
"#,list")))
560 (t "(apply (wrap $sequence) '(list) (make-environment))"
561 (emt:doc
"In blank environment, we see no bindings")
563 (equal answer
"Error: eval: unbound variable: list \n"))))
567 ((exec+args
(list debug-klink-executable
))
572 ;;Clean out header stuff
575 (emt:doc
"Predicate integer?")
581 (emt:doc
"Predicate integer?")
588 ((exec+args
(list debug-klink-executable
))
593 ;;Clean out header stuff
596 (emt:doc
"null? is recognized")
598 (equal answer
"#,null?")))
599 ;;Must eval, which right now we don't.
602 (equal answer
"#t")))
605 (equal answer
"#f"))))
607 ;;make-encapsulation-type
609 ((exec+args
(list debug-klink-executable
))
614 ;;Clean out header stuff
616 (t "($define! (e p? d) (make-encapsulation-type))"
617 (emt:doc
"Make an encapsulation type")
619 (equal answer
"#inert")))
620 (t "($define! a (e 12))"
621 (emt:doc
"Make an instance of it")
623 (equal answer
"#inert")))
625 (emt:doc
"The predicate returns true on the instance")
627 (equal answer
"#t")))
630 (equal answer
"#f")))
633 (equal answer
"#t")))
636 (equal answer
"#f")))
638 (emt:doc
"`d' retrieves the value")
640 (equal answer
"12"))))
644 ((exec+args
(list debug-klink-executable
))
649 ;;Clean out header stuff
652 (emt:doc
"$if is recognized")
654 (equal answer
"#,$if")))
656 (emt:doc
"On true, evaluates the CONSEQUENT argument")
660 (emt:doc
"On false, evaluates the ALTERNATIVE argument")
664 (emt:doc
"On non-boolean test, raises error")
668 "dbid:80eedbc8-efd5-47c4-9c3b-d0da6c48f768")))
670 (emt:doc
"On evaluated true, evaluates the CONSEQUENT argument")
674 (emt:doc
"On evaluated false, evaluates the ALTERNATIVE argument")
676 (equal answer
"2"))))
679 ((exec+args
(list debug-klink-executable
))
684 ;;Clean out header stuff
686 (t "($cond (#t 12)(#f 13))"
687 (emt:doc
"The first true claus is evalled")
689 (equal answer
"12")))
690 (t "($cond (#f 13)(#t 12))"
691 (emt:doc
"False clauses are skipped")
693 (equal answer
"12")))
694 (t "($cond ((integer? 'a) 13)(#t 12))"
695 (emt:doc
"Guard clauses are evalled")
697 (equal answer
"12")))
698 (t "($cond ((integer? 'a) 13)((integer? 1) 12))"
699 (emt:doc
"Guard clauses are evalled")
701 (equal answer
"12")))
702 (t "($let ((x 5)) ($cond (#t (list 1 2))))"
703 (emt:doc
"The selected clause body is evalled")
705 (equal answer
"(1 2)")))
707 (emt:doc
"$cond with no clauses gives #inert")
709 (equal answer
"#inert")))
715 (emt:doc
"Variables are accessible inside clauses")
717 (equal answer
"x=5\n#inert"))))
721 ((exec+args
(list debug-klink-executable
))
726 ;;Clean out header stuff
728 (t "(listloop listloop-style-neighbors '(1 2 3) 2)"
729 (emt:doc
"Validate that listloop normally works")
731 (equal answer
"#<OPERATIVE>")))
732 (t "(listloop listloop-style-neighbors ($lazy '(1 2 3)) #f)"
733 (emt:doc
"Validate that listloop will error if it gets the wrong type")
735 (emt:eq-persist-p
#'equal answer
736 "dbid:0488e533-76ef-4720-93d5-bfab229c9079")))
737 (t "(listloop listloop-style-neighbors '(1 2 3) ($lazy 2))"
738 (emt:doc
"It accepts lazy style arguments")
740 (equal answer
"#<OPERATIVE>")))
741 (t "(listloop listloop-style-neighbors ($lazy '(1 2 3)) ($lazy 2))"
742 (emt:doc
"It accepts lazy lists")
744 (equal answer
"#<OPERATIVE>"))))
748 ((exec+args
(list debug-klink-executable
))
753 ;;Clean out header stuff
756 (emt:doc
"$sequence with no args gives inert")
758 (equal answer
"#inert")))
760 (emt:doc
"Sequence evaluates its args")
763 (t "($sequence '1 '2)"
764 (emt:doc
"Sequence returns the value of the last element")
767 (t "($define! my-lam ($lambda v (write v)(newline)))"
768 (emt:doc
"Define a lambda having a sequence"))
770 (emt:doc
"That lambda evals all the sequence")
772 (equal answer
"(12)\n#inert"))))
777 ((exec+args
(list debug-klink-executable
))
782 ;;Clean out header stuff
784 (t "($sequence (write \"abc\") (newline))"
785 (emt:doc
"`write' displays objects escaped for read-back")
787 (equal answer
"\"abc\"\n#inert")))
788 (t "($sequence (display \"abc\") (newline))"
789 (emt:doc
"`display' displays objects unescaped")
791 (equal answer
"abc\n#inert")))
792 (t "($sequence (display '(1 2 3)) (newline))"
793 (emt:doc
"`display' can display full objects")
795 (equal answer
"(1 2 3)\n#inert")))
796 (t "($sequence (write '(1 2 3)) (newline))"
797 (emt:doc
"`write' can display full objects")
799 (equal answer
"(1 2 3)\n#inert"))))
802 ((exec+args
(list debug-klink-executable
))
807 ;;Clean out header stuff
810 (emt:doc
"Reads numbers")
812 (equal answer
"12")))
814 (emt:doc
"Reads symbols")
816 (equal answer
"sym")))
818 (emt:doc
"Reads lists, no problem with nesting depth.")
820 (equal answer
"(1 2 3)"))))
825 ((exec+args
(list debug-klink-executable
))
830 ;;Clean out header stuff
833 (emt:doc
"true/o1 predicate is recognized")
835 (equal answer
"#,true/o1")
839 (emt:doc
"true/o1 predicate gives #t")
844 (emt:doc
"`type?' is recognized")
846 (equal answer
"#,type?")
849 (t "(type? 1 true/o1)"
850 (emt:doc
"`type?' can be called")
855 (emt:doc
"`listtype' ctor is recognized")
857 (equal answer
"#,listtype")
859 (t "(listtype true/o1)"
860 (emt:doc
"`listtype' makes an operative")
862 (equal answer
"#<OPERATIVE>")
864 (t "(listtype true/o1 true/o1)"
865 (emt:doc
"`listtype' takes a list of args")
867 (equal answer
"#<OPERATIVE>")
869 (t "(type? 1 (listtype true/o1))"
870 (emt:doc
"`listtype' makes one that expects a list")
874 (t "(type? '(1) (listtype integer?))"
875 (emt:doc
"Second-level listtypes work OK")
879 (t "(type? '(#t) (listtype integer?))"
880 (emt:doc
"Second-level listtype discriminate (non)match")
884 (t "(type? '(1) (listtype true/o1 true/o1))"
885 (emt:doc
"Situation: Too few elements")
886 (emt:doc
"Result: false")
890 (t "(type? '(1) (listtype))"
891 (emt:doc
"Situation: Objects has too many elements")
892 (emt:doc
"Result: false")
896 (t "(type? '(1) (listtype true/o1 'optional true/o1))"
897 (emt:doc
"Situation: Optional elements")
898 (emt:doc
"Result: true")
902 (t "(type? '(1 2 3) (listtype true/o1 'optional true/o1))"
903 (emt:doc
"Situation: Number of items outruns number of optional elements")
904 (emt:doc
"Result: false")
908 (t "(type? '(1) (listtype true/o1 'optional 'optional))"
909 (emt:doc
"Situation: Two optional keys given")
910 (emt:doc
"Result: error")
915 "dbid:e144f830-d6a5-4240-94f0-b0b8a9890d42")))
916 (t "(type? '(1) (listtype true/o1 'DOT))"
917 (emt:doc
"Situation: Dot spec has no spec after it")
918 (emt:doc
"Result: error")
920 (emt:eq-persist-p
#'equal
922 "dbid:37a39a99-8b11-4d6f-9e31-033af8d73d41")))
923 (t "(type? '(1) (listtype true/o1 'DOT true/o1 true/o1))"
924 (emt:doc
"Situation: Dot spec has more than 1 spec after it")
925 (emt:doc
"Result: error")
927 (emt:eq-persist-p
#'equal
929 "dbid:7f057673-3b94-4e4c-a25c-b09ed5239af2")))
930 (t "(type? '(1 2 3) (listtype true/o1 'DOT true/o1))"
931 (emt:doc
"Situation: Dot spec is satisfied")
932 (emt:doc
"Result: true")
936 (t "(type? '(1 2 3) (listtype true/o1 'DOT integer?))"
937 (emt:doc
"Situation: Dot spec is reached but doesn't match")
938 (emt:doc
"Result: false")
942 (t "(type? '(1 2 3) (listtype true/o1 'REPEAT integer?))"
943 (emt:doc
"Situation: Repeat spec is used and matches")
944 (emt:doc
"Result: true")
948 (t "(type? '(1 2 #t) (listtype true/o1 'REPEAT integer?))"
949 (emt:doc
"Situation: Repeat spec is used but doesn't match")
950 (emt:doc
"Result: false")
954 (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT integer? true/o1))"
955 (emt:doc
"Situation: Repeat spec is used, has 2 items, matches")
956 (emt:doc
"Result: true")
960 (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT true/o1 integer?))"
961 (emt:doc
"Situation: Repeat spec is used, has 2 items, but doesn't match")
962 (emt:doc
"Result: false")
966 (t "(type? '(1) (listtype true/o1 'REPEAT integer?))"
967 (emt:doc
"Situation: Repeat spec is used, zero items available")
968 (emt:doc
"Result: true")
972 ;; $$IMPROVE ME Test circularity, use encycle!
977 ((exec+args
(list debug-klink-executable
))
982 ;;Clean out header stuff
985 (t "destructure-list"
986 (emt:doc
"Test `destructure-list'")
987 (emt:doc
"ctor is recognized")
989 (equal answer
"#,destructure-list")
991 (t "(destructure-list true/o1)"
992 (emt:doc
"It makes an operative")
994 (equal answer
"#<OPERATIVE>")
996 (t "(destructure-list true/o1 true/o1)"
997 (emt:doc
"It takes a list of args")
999 (equal answer
"#<OPERATIVE>")
1001 (t "(do-destructure 1 true/o1)"
1002 (emt:doc
"do-destructure can take just a combiner as arg")
1004 (equal answer
"#( 1)")))
1005 (t "(do-destructure 1 (destructure-list true/o1))"
1006 (emt:doc
"It makes one that expects a list")
1007 (emt:doc
"Result: Error")
1009 (emt:eq-persist-p
#'equal
1011 "dbid:3e113873-73a0-46f5-8e14-f41034780317")))
1012 (t "(do-destructure '(1) (destructure-list integer?))"
1013 (emt:doc
"Second-level destructures work OK")
1015 (equal answer
"#( 1)")
1017 (t "(do-destructure '(#t) (destructure-list integer?))"
1018 (emt:doc
"Second-level destructure discriminate (non)match")
1019 (emt:doc
"Result: Error")
1021 (emt:eq-persist-p
#'equal
1023 "dbid:dc2648ef-22cb-41c2-8f9b-67548b0a3b7a")))
1024 (t "(do-destructure '(1) (destructure-list true/o1 true/o1))"
1025 (emt:doc
"Situation: Too few elements")
1026 (emt:doc
"Result: Error")
1031 "dbid:b50e8f78-6652-418d-9b44-1ff676946970")))
1032 (t "(do-destructure '(1) (destructure-list))"
1033 (emt:doc
"Situation: Objects has too many elements")
1034 (emt:doc
"Result: Error")
1039 "dbid:ee168f5d-5d87-4792-9dba-0fd0ac7c14a4")))
1041 (t "(do-destructure '(1) (destructure-list true/o1 'optional true/o1))"
1042 (emt:doc
"Situation: Optional elements")
1043 (emt:doc
"Result: true")
1045 (equal answer
"#( 1 #inert)")
1048 (t "(do-destructure '(1 2 3) (destructure-list true/o1 'optional true/o1))"
1049 (emt:doc
"Situation: Number of items outruns number of optional elements")
1050 (emt:doc
"Result: Error")
1052 (emt:eq-persist-p
#'equal answer
1053 "dbid:a1bd1321-532e-4187-af64-278c009a7f97")))
1055 (t "(do-destructure '(1) (destructure-list true/o1 'optional 'optional))"
1056 (emt:doc
"Situation: Two optional keys given")
1057 (emt:doc
"Result: Error")
1062 "dbid:ece901d5-4ac0-496e-a9e2-83423a933522")))
1064 (t "(do-destructure '(1) (destructure-list true/o1 'dot))"
1065 (emt:doc
"Situation: Dot spec has no spec after it")
1066 (emt:doc
"Result: Error")
1068 (emt:eq-persist-p
#'equal
1070 "dbid:8e8711ba-bada-4223-a212-3256d6a2e497")))
1072 (t "(do-destructure '(1) (destructure-list true/o1 'dot true/o1 true/o1))"
1073 (emt:doc
"Situation: Dot spec has more than 1 spec after it")
1074 (emt:doc
"Result: Error")
1076 (emt:eq-persist-p
#'equal
1078 "dbid:4d68ceb6-f450-4218-b222-c10019a39819")))
1080 (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot true/o1))"
1081 (emt:doc
"Situation: Dot spec is satisfied")
1082 (emt:doc
"Result: true")
1084 (equal answer
"#( 1 (2 3))")
1087 (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot integer?))"
1088 (emt:doc
"Situation: Dot spec is reached but doesn't match")
1089 (emt:doc
"Result: Error")
1091 (emt:eq-persist-p
#'equal answer
1092 "dbid:266cbd1e-734c-4a81-bac6-e9d9a3424e79")))
1094 (t "(do-destructure '(1) 13)"
1095 (emt:doc
"Fails gracefully when given a non-combiner")
1099 "dbid:2492173b-e70f-460d-87a0-da1aff73d22e")))
1100 (t "(do-destructure 1 ($lambda (x) (true/o1 x)))"
1101 (emt:doc
"Accepts combiners that use the main loop")
1103 (equal answer
"#( 1)")))
1104 (t "(do-destructure '(1) (destructure-list ($vau (x) #ignore (true/o1 x))))"
1106 (equal answer
"#( 1)"))))
1108 ;;On define-type destructuring
1110 ((exec+args
(list debug-klink-executable
))
1112 (prompt "\nklink> ")
1115 ;;Clean out header stuff
1117 (t "($define! (a b) ($lazy '(12 144)))"
1118 (emt:doc
"Define with a lazy value")
1120 (equal answer
"#inert")))
1122 (emt:doc
"A has been defined")
1124 (equal answer
"12")))
1126 (emt:doc
"B has been defined")
1128 (equal answer
"144")))
1129 (t "($define! ((a b)(c d)) (list ($lazy '(20736 1728))($lazy '(144 12))))"
1130 (emt:doc
"Define with multiple lazy values")
1132 (equal answer
"#inert")))
1134 (emt:doc
"A has been changed")
1136 (equal answer
"20736")))
1139 (equal answer
"1728")))
1142 (equal answer
"144")))
1145 (equal answer
"12")))
1146 (t "((wrap ($vau ((a b)) #ignore (list a b))) '(144 12))"
1147 (emt:doc
"Validate: Without laziness, vau works as expected")
1149 (equal answer
"(144 12)")))
1150 (t "((wrap ($vau ((a b)) #ignore (list a b))) ($lazy '(144 12)))"
1151 (emt:doc
"Handles laziness too")
1153 (equal answer
"(144 12)")))
1154 (t "((wrap ($vau ((a b)(c d)) #ignore (list a b c d))) '(20736 1728) '(144 12))"
1156 (equal answer
"(20736 1728 144 12)")))
1157 (t "((wrap ($vau ((a b)(c d)) #ignore (list a b c d)))
1158 ($lazy '(20736 1728))
1160 (emt:doc
"Handles nested and double-lazy too")
1162 (equal answer
"(20736 1728 144 12)")))
1163 (t "((wrap ($vau ((a b)) #ignore (list a b))) ($lazy 144))"
1164 (emt:doc
"Error on values that don't fit even when forced")
1166 (emt:eq-persist-p
#'equal answer
1167 "dbid:6928bebb-0876-448c-9a9b-f72410c94422")))
1168 (t "((wrap ($vau ((a b (c d))) #ignore (list a b c d)))
1169 ($lazy (list 20736 1728 ($lazy '(144 12)))))"
1170 (emt:doc
"Works even on nested promises")
1172 (equal answer
"(20736 1728 144 12)"))))
1177 ((exec+args
(list debug-klink-executable
))
1179 (prompt "\nklink> ")
1182 ;;Clean out header stuff
1185 (t "(where-typemiss 1 (listtype true/o1))"
1186 (emt:doc
"`listtype' makes one that expects a list")
1188 (equal answer
"(0 too-few)")
1190 (t "(where-typemiss '(#t) (listtype integer?))"
1191 (emt:doc
"Second-level listtype discriminate (non)match")
1192 ;;Use persist because the form of the printout changes.
1194 (emt:eq-persist-p
#'equal answer
1195 "dbid:cc211ae0-718b-4462-9062-7f0077cdf162")))
1196 (t "(where-typemiss '(1) (listtype true/o1 true/o1))"
1197 (emt:doc
"Situation: Too few elements")
1199 (equal answer
"(1 too-few)")
1201 (t "(where-typemiss '(1) (listtype))"
1202 (emt:doc
"Situation: Objects has too many elements")
1204 (equal answer
"(0 too-many)")
1206 (t "(where-typemiss '(1 2 3) (listtype true/o1 'optional true/o1))"
1207 (emt:doc
"Situation: Number of items outruns number of optional elements")
1209 (equal answer
"(2 too-many)")
1211 (t "(where-typemiss '(1 2 3) (listtype true/o1 'dot integer?))"
1212 (emt:doc
"Situation: Dot spec is reached but doesn't match")
1214 (emt:eq-persist-p
#'equal answer
1215 "dbid:2f83b114-6bdf-4c7d-9a76-0d3e8b43483c")))
1216 (t "(where-typemiss '(1 2 #t) (listtype true/o1 'repeat integer?))"
1217 (emt:doc
"Situation: Repeat spec is used but doesn't match")
1219 (emt:eq-persist-p
#'equal answer
1220 "dbid:f90a1f49-9180-4817-8095-6422ee058745")))
1221 (t "(where-typemiss '(1 2 #t 4 #t) (listtype true/o1 'repeat true/o1 integer?))"
1222 (emt:doc
"Situation: Repeat spec is used, has 2 items, but doesn't match")
1224 (emt:eq-persist-p
#'equal answer
1225 "dbid:374c6ab3-7907-4ff5-b14d-e41584593296")))
1226 ;; $$IMPROVE ME Test circularity, use encycle!
1229 ;;On get-list-metrics
1231 ((exec+args
(list debug-klink-executable
))
1233 (prompt "\nklink> ")
1236 ;;Clean out header stuff
1238 (t "(length '(0 1))"
1240 (equal answer
"2")))
1241 (t "(finite-list? '(0 1))"
1243 (equal answer
"#t")))
1244 (t "(finite-list? #f)"
1246 (equal answer
"#f")))
1247 (t "(get-list-metrics '(0 1))"
1249 (equal answer
"(2 1 2 0)")))
1250 (t "(get-list-metrics #f)"
1252 (equal answer
"(0 0 0 0)")))
1253 (t "(get-list-metrics '(0 . 1))"
1255 (equal answer
"(1 0 1 0)")))
1256 (t "($define! a (list 12))"
1257 (emt:doc
"Make a circular object"))
1258 (t "(set-cdr! a a)")
1259 (t "(get-list-metrics a)"
1260 (emt:doc
"List metrics of a circular object")
1262 (equal answer
"(1 0 0 1)")))
1267 ;;On making environment
1269 ((exec+args
(list debug-klink-executable
))
1271 (prompt "\nklink> ")
1274 ;;Clean out header stuff
1276 (t "(make-environment (get-current-environment))"
1277 (emt:doc
"Can make an environment")
1279 (equal answer
"#<ENVIRONMENT>")))
1280 (t "(make-environment)"
1281 (emt:doc
"Can make an empty environment")
1283 (equal answer
"#<ENVIRONMENT>")))
1285 (t "(eval 'make-environment (make-environment))"
1286 (emt:doc
"Empty environment does not bind things")
1289 #'equal answer
"dbid:930c9cb4-c8e3-446a-9d0f-80a7a01edf2e")))
1291 (t "($define! env1 (make-environment))"
1292 (emt:doc
"Define example environments")
1294 (equal answer
"#inert")))
1295 (t "($define! env2 (make-environment))"
1297 (equal answer
"#inert")))
1298 (t "($set! env1 a 12)"
1299 (emt:doc
"Define things in those example environments")
1301 (equal answer
"#inert")))
1302 (t "($set! env2 b 144)"
1304 (equal answer
"#inert")))
1306 (emt:doc
"The respective bindings are available in the environments")
1308 (equal answer
"12")))
1311 (equal answer
"144")))
1312 (t "($define! env1+2 (make-environment env1 env2))"
1313 (emt:doc
"Can make an environment from multiple parents")
1315 (equal answer
"#inert")))
1316 (t "(eval 'a env1+2)"
1317 (emt:doc
"It contains the bindings of both environments")
1319 (equal answer
"12")))
1320 (t "(eval 'b env1+2)"
1322 (equal answer
"144"))))
1325 ((exec+args
(list debug-klink-executable
))
1327 (prompt "\nklink> ")
1331 (t "(reverse-lookup get-current-environment (get-current-environment))"
1332 (emt:doc
"Operation: look up an object we know is bound")
1333 (emt:doc
"Result: We find it")
1335 (equal answer
"get-current-environment")))
1336 (t "(reverse-lookup reverse-lookup (get-current-environment))"
1337 (emt:doc
"Same on another object")
1339 (equal answer
"reverse-lookup")))
1340 (t "(reverse-lookup 'example-unsymboled-object (get-current-environment))"
1341 (emt:doc
"Operation: look up an object we know is not bound")
1342 (emt:doc
"Result: Error")
1344 (emt:eq-persist-p
#'equal answer
1345 "dbid:c3ec8dcc-39b2-4885-b4f3-f6e5f018c11e")))
1346 (t "($define! a (list))"
1347 (emt:doc
"Make an object we will look for"))
1348 (t "($define! my-env (make-environment))")
1349 (t "($set! my-env b a)"
1350 (emt:doc
"In my-env, define b as that object"))
1351 (t "($set! my-env b 13)"
1352 (emt:doc
"Now define b as something else"))
1353 (t "(reverse-lookup a my-env)"
1354 (emt:doc
"Look up the original object")
1358 "dbid:673c63c9-1844-4c7f-b67d-22c6ef88fc66")))
1359 (t "($define! my-env2 (make-environment))"
1360 (emt:doc
"Make another empty environment"))
1361 (t "($set! my-env2 c a)"
1362 (emt:doc
"In my-env2, define c as that object"))
1363 (t "($set! my-env2 b a)"
1364 (emt:doc
"In my-env2, define b as that object"))
1365 (t "($set! my-env2 b 13)"
1366 (emt:doc
"Now define b as something else"))
1367 (t "(reverse-lookup a my-env2)"
1368 (emt:doc
"Operation: Look up the original object")
1369 (emt:doc
"Result: We find its binding, c")
1371 (equal answer
"c")))
1372 (t "($set! my-env2 b a)"
1373 (emt:doc
"Define b as that object again"))
1374 (t "($define! my-env3 (make-environment my-env2))"
1375 (emt:doc
"Make an environment derived from my-env2"))
1376 (t "($set! my-env3 b 13)"
1377 (emt:doc
"There set b to be something else"))
1378 (t "(reverse-lookup a my-env3)"
1379 (emt:doc
"Operation: Look up the original object")
1380 (emt:doc
"Result: We find its binding")
1382 (equal answer
"c"))))
1384 ;;On printing, esp circular objects
1386 ((exec+args
(list debug-klink-executable
))
1388 (prompt "\nklink> ")
1393 (t "print-lookup-env"
1395 (equal answer
"#,print-lookup-env"))
1398 (emt:doc
"Lists print OK")
1400 (equal answer
"(1 2)")))
1402 (emt:doc
"Bound objects print a lowquote and their binding")
1404 (equal answer
"#,wrap")))
1407 (equal answer
"#,list")))
1409 (emt:doc
"These objects are actual working combiners.")
1411 (equal answer
"(#,list)")))
1415 ;;On get-recurrences
1417 ((exec+args
(list debug-klink-executable
))
1419 (prompt "\nklink> ")
1424 (t "($define! cycles-nil (get-recurrences '()))"
1425 (emt:doc
"`cycles-nil' is the recurrences of object '()"))
1426 (t "(recurrence-table? cycles-nil)"
1428 (equal answer
"#t")))
1430 (t "(recurrences-get-object-count cycles-nil '())"
1431 (emt:doc
"Nils are not counted")
1433 (equal answer
"0")))
1434 (t "($define! cycles-list (get-recurrences (list 12 144)))"
1435 (emt:doc
"`cycles-list' is the recurrences of an ordinary list"))
1436 (t "(recurrence-table? cycles-list)"
1438 (equal answer
"#t")))
1439 (t "($define! cycles-many-nils (get-recurrences '()))"
1440 (emt:doc
"`cycles-many-nils' is the recurrences of object of
1442 (t "(recurrence-table? cycles-many-nils)"
1444 (equal answer
"#t")))
1445 (t "(recurrences-get-object-count cycles-many-nils '())"
1446 (emt:doc
"Nils do not constitute shared objects")
1448 (equal answer
"0")))
1449 (t "($define! cycles-f (get-recurrences '(#f #f)))"
1450 (emt:doc
"Get the recurrences of any object with repeated objects"))
1451 (t "(recurrence-table? cycles-f)"
1453 (equal answer
"#t")))
1454 (t "(recurrences-get-object-count cycles-f #f)"
1456 (equal answer
"2")))
1457 (t "($define! a (list 12))"
1458 (emt:doc
"Define a circular object"))
1459 (t "(set-cdr! a a)")
1460 (t "($define! cycles-a (get-recurrences a))")
1461 (t "(recurrence-table? cycles-a)"
1463 (equal answer
"#t")))
1464 (t "(recurrences-get-object-count cycles-a a)"
1466 (equal answer
"2"))))
1468 ;;On lists and wrapping
1470 ((exec+args
(list debug-klink-executable
))
1472 (prompt "\nklink> ")
1477 (emt:doc
"List works")
1479 (equal answer
"(1 2)")))
1480 (t "(reverse (list 1 2))"
1481 (emt:doc
"Reverse works")
1483 (equal answer
"(2 1)")))
1484 (t "((wrap list) 1 2)"
1485 (emt:doc
"Wrap wrapped over an applicative works (wrap^2)")
1487 (equal answer
"(1 2)")))
1488 (t "((wrap list) '1 '2)"
1489 (emt:doc
"Wrap^2 eliminates at least one level of quoting")
1491 (equal answer
"(1 2)")))
1492 (t "((wrap list) ''1 ''2)"
1493 (emt:doc
"Wrap^2 eliminates two levels of quoting")
1495 (equal answer
"(1 2)")))
1496 (t "((wrap list) '''1 '''2)"
1497 (emt:doc
"Wrap^2 leaves one of three levels of quoting")
1499 (equal answer
"((#,$quote 1) (#,$quote 2))")))
1500 (t "((wrap (wrap list)) '''1 '''2)"
1501 (emt:doc
"Wrap^3 eliminates three levels of quoting")
1503 (equal answer
"(1 2)"))))
1505 ;;On map, map1, counted-map/4
1507 ((exec+args
(list debug-klink-executable
))
1509 (prompt "\nklink> ")
1513 (t "(map1 list '(1 2 3))"
1514 (emt:doc
"It works")
1516 (equal answer
"((1) (2) (3))")))
1517 (t "(map1 (unwrap list) '(1 2 3))"
1518 (emt:doc
"It wants an applicative argument")
1520 (emt:eq-persist-p
#'equal
1522 "dbid:bf93cc1e-534c-4a1f-8762-3072e59dcb3c")))
1523 (t "(counted-map/4 2 1 list '((1 2)))"
1524 (emt:doc
"Generally behaves like `map'")
1526 (equal answer
"((1) (2))")))
1527 (t "(counted-map/4 1 1 list '((1 2)))"
1528 (emt:doc
"Stops after N elements")
1530 (equal answer
"((1))")))
1531 (t "(counted-map/4 2 2 list '((1 2) (11 12)))"
1532 (emt:doc
"Can treat multiple lists")
1534 (equal answer
"((1 11) (2 12))")))
1535 (t "(map list '(1 2))"
1536 (emt:doc
"Check full `map'")
1538 (equal answer
"((1) (2))")))
1539 (t "(map list '(1 2) '(11 12))"
1541 (equal answer
"((1 11) (2 12))"))))
1545 ((exec+args
(list debug-klink-executable
))
1547 (prompt "\nklink> ")
1551 (t "($define! my-con-list (call/cc list))"
1552 (emt:doc
"Make an object containing a continuation"))
1554 (emt:doc
"Check what we got")
1556 (equal answer
"(#<CONTINUATION>)")))
1557 (t "($define! my-con (car my-con-list))"
1558 (emt:doc
"Extract that continuation"))
1560 (emt:doc
"Check what we got")
1562 (equal answer
"#<CONTINUATION>")))
1563 (t "(continuation->applicative my-con)"
1564 (emt:doc
"Try a simple call")
1566 (equal answer
"#<APPLICATIVE>")))
1567 (t "((continuation->applicative my-con) 12)"
1568 (emt:doc
"Use the continuation")
1570 (equal answer
"#inert")))
1572 (emt:doc
"my-con-list got redefined by the continuation")
1574 (equal answer
"(12)")))
1575 (t "(apply (continuation->applicative (extend-continuation my-con
1577 (display \"arrived at the continuation with \")
1579 (newline)))) '(144))"
1582 "arrived at the continuation with (144)\n#inert")))
1583 (t "($define! my-unguarded-con (guard-continuation '() my-con '()))"
1584 (emt:doc
"Make a continuation that has empty list of guards")
1586 (equal answer
"#inert")))
1587 (t "(apply (continuation->applicative my-unguarded-con) '(145))"
1588 (emt:doc
"Applies without problem")
1590 (equal answer
"#inert")))
1592 (emt:doc
"The continuation got called")
1594 (equal answer
"(145)")))
1596 (t "($define! my-guarded-con (guard-continuation
1597 (list (list root-continuation
1598 ($lambda (v %ignore)
1599 (display \"entering the continuation with \")
1604 (list (list root-continuation
1605 ($lambda (v %ignore)
1606 (display \"exiting the continuation with \")
1610 (emt:doc
"Create a guarded continuation")
1612 (equal answer
"#inert")))
1614 (emt:doc
"Type is correct")
1616 (equal answer
"#<CONTINUATION>")))
1617 (t "(continuation->applicative my-guarded-con)"
1618 (emt:doc
"Type is correct")
1620 (equal answer
"#<APPLICATIVE>")))
1621 (t "(apply (continuation->applicative my-guarded-con) '(146))"
1622 (emt:doc
"We see it calls the guard and continues")
1624 (equal answer
"entering the continuation with (146)\n#inert")))
1626 (emt:doc
"The continuation got called")
1628 (equal answer
"(146)")))
1629 (t "(guard-dynamic-extent
1631 ($lambda () (display \"Got here\")(newline))
1633 (emt:doc
"Calls the combiner arg with no variables")
1635 (equal answer
"Got here\n#inert")))
1636 (t "(guard-dynamic-extent
1637 (list (list root-continuation ($lambda (v %ignore)
1638 (display \"Abnormally entering dynamic extent.\")
1641 ($lambda () (display \"Got here\")(newline))
1643 (emt:doc
"Does not initially call the entry guards")
1645 (equal answer
"Got here\n#inert")))
1646 (t "(guard-dynamic-extent
1648 ($lambda () (display \"Got here\")(newline))
1649 (list (list root-continuation ($lambda (v %ignore)
1650 (display \"Abnormally entering dynamic extent.\")
1653 (emt:doc
"Does not initially call the exit guards")
1655 (equal answer
"Got here\n#inert"))))
1661 ((exec+args
(list debug-klink-executable
))
1663 (prompt "\nklink> ")
1668 (emt:doc
"Is recognized")
1670 (equal answer
"#,and?")))
1672 (emt:doc
"Given no args, returns true")
1674 (equal answer
"#t")))
1676 (emt:doc
"Accepts 1 arg")
1678 (equal answer
"#t")))
1680 (emt:doc
"Accepts 2 args")
1682 (equal answer
"#t")))
1684 (emt:doc
"If an arg is false, returns false")
1686 (equal answer
"#f")))
1687 (t "(and? #t (integer? 1))"
1688 (emt:doc
"Arguments are evaluated")
1690 (equal answer
"#t")))
1691 (t "(and? #t (integer? \"11\"))"
1692 (emt:doc
"The evaluated value is used")
1694 (equal answer
"#f")))
1696 (emt:doc
"If there are only false clauses, returns false")
1698 (equal answer
"#f")))
1700 (emt:doc
"If there is any true clause, return true")
1702 (equal answer
"#t")))
1705 (equal answer
"#t")))
1707 (emt:doc
"The evaluating variant")
1709 (equal answer
"#t")))
1712 (equal answer
"#f")))
1715 (equal answer
"#f")))
1716 (t "($and? ($sequence (display \"One\")(newline) #f))"
1717 (emt:doc
"Evaluates some of its args, at least the first one")
1719 (equal answer
"One\n#f")))
1720 (t "($and? ($sequence (display \"One\")(newline) #t)($sequence (display \"Two\")(newline) #f))"
1722 (equal answer
"One\nTwo\n#f")))
1723 (t "($and? ($sequence (display \"One\")(newline) #f)($sequence (display \"Two\")(newline) #f))"
1725 (equal answer
"One\n#f")))
1726 (t "(every?/2-xary and? '())"
1727 (emt:doc
"xary-1 `every?/2-xary' is available (in `simple' environment)")
1729 (equal answer
"#t")))
1730 (t "(every?/2-xary and? '(()))"
1731 (emt:doc
"No elements")
1733 (equal answer
"#t")))
1734 (t "(every?/2-xary and? '((#f)))"
1735 (emt:doc
"One element containing one element (for `and?')")
1737 (equal answer
"#f")))
1738 (t "(every?/2-xary and? '((#t #t)))"
1739 (emt:doc
"More elements")
1741 (equal answer
"#t")))
1742 (t "(every?/2-xary and? '((#t #t)(#t)))"
1744 (equal answer
"#t")))
1745 (t "(every?/2-xary and? '((#t #t)(#f)))"
1747 (equal answer
"#f"))))
1751 ((exec+args
(list debug-klink-executable
))
1753 (prompt "\nklink> ")
1758 (emt:doc
"Test that comparisons work as expected")
1760 (equal answer
"#t")))
1763 (equal answer
"#f")))
1766 (equal answer
"#f")))
1769 (equal answer
"#f")))
1772 (equal answer
"#f")))
1775 (equal answer
"#t")))
1778 (equal answer
"#t")))
1781 (equal answer
"#t")))
1784 (equal answer
"#f")))
1787 (equal answer
"#f")))
1790 (equal answer
"#t")))
1793 (equal answer
"#t")))
1794 (t "(compare-neighbors <? '(0 1 2))"
1796 (equal answer
"#t")))
1797 (t "(compare-neighbors <? '(0))"
1799 (equal answer
"#t")))
1800 (t "(compare-neighbors <=? '(0 1 2))"
1802 (equal answer
"#t")))
1803 (t "(compare-neighbors <? '(0 1 1 2))"
1805 (equal answer
"#f")))
1806 (t "(compare-neighbors <=? '(0 1 1 2))"
1808 (equal answer
"#t"))))
1812 ((exec+args
(list debug-klink-executable
))
1814 (prompt "\nklink> ")
1819 (emt:doc
"N-ary addition works")
1821 (equal answer
"6")))
1822 (t "(+ 1 2 (+ 3 0))"
1823 (emt:doc
"N-ary addition evaluates its arguments")
1825 (equal answer
"6")))
1827 (emt:doc
"N-ary addition gives 0 on no operands")
1829 (equal answer
"0")))
1831 (emt:doc
"N-ary addition with 1 operand works")
1833 (equal answer
"3")))
1836 (emt:doc
"N-ary multiplication works")
1838 (equal answer
"60")))
1839 (t "(* 1 2 (* 3 10))"
1840 (emt:doc
"N-ary multiplication evaluates its arguments")
1842 (equal answer
"60")))
1844 (emt:doc
"N-ary multiplication gives 0 on no operands")
1846 (equal answer
"1")))
1848 (emt:doc
"N-ary multiplication with 1 operand works")
1850 (equal answer
"3")))
1852 (emt:doc
"Dividing an integer by itself gives 1")
1854 (equal answer
"1")))
1856 (emt:doc
"Dividing an integer by 1 gives itself")
1858 (equal answer
"2")))
1860 (emt:doc
"For real division, it doesn't floor")
1862 (equal answer
"0.5")))
1865 (equal answer
"2")))
1868 (equal answer
"1")))
1871 (equal answer
"0.5")))
1874 (equal answer
"80")))
1877 (equal answer
"75")))
1879 (emt:doc
"`-' with no subtrahends raises error")
1881 (emt:eq-persist-p
#'equal answer
1882 "dbid:d0afc822-58f7-4921-b37d-57d45cd6b5e0")))
1884 (emt:doc
"`/' with no divisors raises error")
1886 (emt:eq-persist-p
#'equal answer
1887 "dbid:2afbb9f8-3016-46a5-bb93-9d9d2fdd0e98"))))
1890 ((exec+args
(list debug-klink-executable
))
1892 (prompt "\nklink> ")
1897 (emt:doc
"Compares numbers correctly")
1899 (equal answer
"#t")))
1902 (equal answer
"#f")))
1903 (t "(equal?/2 3 '(1 2))"
1905 (equal answer
"#f")))
1906 (t "(equal?/2 'a 'a)"
1907 (emt:doc
"Compares symbols correctly")
1909 (equal answer
"#t")))
1910 (t "(equal?/2 'a 'b)"
1912 (equal answer
"#f")))
1913 (t "(equal?/2 '(1 2) '(1 2))"
1914 (emt:doc
"Compares lists correctly")
1916 (equal answer
"#t")))
1917 (t "(equal?/2 '(1 2) '(1 3))"
1918 (emt:doc
"Compares lists correctly")
1920 (equal answer
"#f")))
1921 (t "(equal?/2 \"meet\" \"meet\")"
1922 (emt:doc
"Compares strings correctly")
1924 (equal answer
"#t")))
1925 (t "(equal?/2 \"meet\" \"not\")"
1926 (emt:doc
"Compares strings correctly")
1928 (equal answer
"#f")))
1930 (emt:doc
"Given the empty list, is true")
1932 (equal answer
"#t")))
1939 ((exec+args
(list debug-klink-executable
))
1941 (prompt "\nklink> ")
1945 (t "($define! a #f)")
1946 (t "($define! b #f)")
1947 (t "($provide! (b c) ($define! a 13) ($define! b 12) ($define! c 144))"
1948 (emt:doc
"`$provide!' b and c but not a")
1950 (equal answer
"#inert")))
1952 (emt:doc
"`a' is what it was")
1954 (equal answer
"#f")))
1956 (emt:doc
"b has been changed")
1958 (equal answer
"12")))
1960 (emt:doc
"c is available")
1962 (equal answer
"144")))
1963 (t "((wrap $binds?/2) (get-current-environment) 'wrap)"
1964 (emt:doc
"Test the simple version")
1965 (emt:doc
"We know `wrap' should be bound")
1967 (equal answer
"#t")))
1968 (t "((wrap $binds?/2) (get-current-environment) '$binds?/2)"
1969 (emt:doc
"We know `$binds?/2' should be bound")
1971 (equal answer
"#t")))
1972 (t "((wrap $binds?/2) (make-environment) '$binds?/2)"
1973 (emt:doc
"`make-environment' should bind nothing.")
1975 (equal answer
"#f")))
1976 (t "((wrap $binds?/2) (make-environment) 'unlikely-to-be-bound)"
1977 (emt:doc
"In case the preceding test worked for the wrong \
1978 reason, ie that `make-environment' leaked")
1980 (equal answer
"#f")))
1981 (t "($binds? (get-current-environment) $binds?)"
1982 (emt:doc
"The N-ary version works")
1984 (equal answer
"#t")))
1985 (t "($binds? (make-environment) $binds?)"
1986 (emt:doc
"Discriminates")
1988 (equal answer
"#f")))
1989 (t "($binds? (get-current-environment) list wrap)"
1990 (emt:doc
"Takes more than 1 arg")
1992 (equal answer
"#t"))))
1995 ((exec+args
(list debug-klink-executable
))
1997 (prompt "\nklink> ")
2001 (t "($define! a (open-input-file \"test-m1.krn\"))"
2002 (emt:doc
"Open an input port from a known file")
2004 (equal answer
"#inert")))
2006 (emt:doc
"We got a port")
2008 (equal answer
"#<PORT>")))
2010 (emt:doc
"Check the first few characters against known values")
2012 (equal answer
"#\\;")))
2015 (equal answer
"#\\newline")))
2018 (equal answer
"#\\;"))))
2021 ((exec+args
(list debug-klink-executable
))
2023 (prompt "\nklink> ")
2027 (t "($binds? (get-current-environment) not-bound-in-ground)"
2028 (emt:doc
"Validate that `not-bound-in-ground' is not already bound")
2030 (equal answer
"#f")))
2031 (t "($define! a (make-kernel-standard-environment))"
2032 (emt:doc
"Create a standard environment")
2034 (equal answer
"#inert")))
2035 (t "($binds? a $binds?)"
2036 (emt:doc
"The ground bindings are available")
2038 (equal answer
"#t")))
2039 (t "($set! a not-bound-in-ground 12)"
2040 (emt:doc
"set `not-bound-in-ground' in a")
2042 (equal answer
"#inert")))
2043 (t "($binds? a not-bound-in-ground)"
2044 (emt:doc
"It's bound in `a'")
2046 (equal answer
"#t")))
2047 (t "(eval 'not-bound-in-ground a)"
2048 (emt:doc
"It has the right value in `a'")
2050 (equal answer
"12")))
2051 (t "($binds? (get-current-environment) not-bound-in-ground)"
2052 (emt:doc
"It's not bound in current environment")
2054 (equal answer
"#f")))
2055 (t "($define! x (get-module \"test-m1.krn\"))"
2056 (emt:doc
"In `x', no parameters are defined")
2057 (emt:doc
(concat "Answer: " answer
)))
2058 (t "($define! y (get-module \"test-m1.krn\"
2059 ($bindings->environment (baz \"quux\"))))"
2060 (emt:doc
"In `y', `baz' is defined")
2061 (emt:doc
(concat "Answer: " answer
)))
2062 (t "($define! z (get-module \"test-m1.krn\"
2063 ($bindings->environment (quux \"baz\"))))"
2064 (emt:doc
"In `z', quux' is defined")
2065 (emt:doc
(concat "Answer: " answer
)))
2066 (t "(write (($remote-eval foo x)))"
2067 (emt:doc
"Query `x'")
2069 (equal answer
"no parameters\n#inert#inert")))
2070 (t "(write (($remote-eval foo y)))"
2071 (emt:doc
"Query `y'")
2073 (equal answer
"parameters, but no quux\n#inert#inert")))
2074 (t "(write (($remote-eval foo z)))"
2075 (emt:doc
"Query `z'")
2077 (equal answer
"parameters\n\"baz\"#inert"))))
2080 ((exec+args
(list debug-klink-executable
))
2082 (prompt "\nklink> ")
2086 (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
2087 ((x . y)) x) (force low-promise))))) (force p1))"
2088 (emt:doc
"WRITE ME")
2090 (equal answer
"1")))
2091 (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
2092 ((x . y)) y) (force low-promise))))) (force p1))"
2093 (emt:doc
"WRITE ME")
2095 (equal answer
"2"))))
2097 ;;Automatically forcing promises
2099 ((exec+args
(list debug-klink-executable
))
2101 (prompt "\nklink> ")
2105 (t "(car ($lazy '(1)))"
2106 (emt:doc
"Car can force a promise")
2108 (equal answer
"1")))
2109 (t "(car ($lazy '(2 3)))"
2111 (equal answer
"2")))
2112 (t "((wrap $binds?/2) (get-current-environment) '$binds?/2)"
2113 (emt:doc
"Validate that this call works")
2115 (equal answer
"#t")))
2116 (t "((wrap $binds?/2) ($lazy (get-current-environment)) '$binds?/2)"
2117 (emt:doc
"And validate that it works with one arg")
2119 (equal answer
"#t")))
2121 (t "((wrap $binds?/2) ($lazy (get-current-environment)) ($lazy '$binds?/2))"
2122 (emt:doc
"We can force two arguments")
2124 (equal answer
"#t")))
2125 (t "(every?/2-xary integer? '((1) (2)))"
2126 (emt:doc
"Validate that this call works")
2128 (equal answer
"#t")))
2129 (t "(every?/2-xary integer? '((1) (#f)))"
2130 (emt:doc
"False works too")
2132 (equal answer
"#f")))
2134 (t "(every?/2-xary ($lazy integer?) '((1) (2)))"
2135 (emt:doc
"Arguments after the forced argument work")
2137 (equal answer
"#t")))
2139 (t "(every?/2-xary ($lazy integer?) '((1) (#f)))"
2141 (equal answer
"#f")))
2143 (t "(every?/2-xary ($lazy integer?) ($lazy '((1) (2))))"
2144 (emt:doc
"Arguments after the forced argument work")
2146 (equal answer
"#t")))
2148 (t "(every?/2-xary ($lazy integer?) ($lazy '((1) (#f))))"
2150 (equal answer
"#f"))))
2154 ((exec+args
(list debug-klink-executable
))
2156 (prompt "\nklink> ")
2161 (emt:doc
"Turn profiling on, and it should not have been on before")
2163 (equal answer
"0")))
2165 (emt:doc
"Now it's on, and this is our first profiled call")
2167 (equal answer
"1")))
2168 (t "(get-profiling-data)"
2169 (emt:doc
"We see the profiling data from just the earlier call")
2170 (emt:doc
"All profiling data may change, we're interested in
2171 its general behavior and in including the functions we just called")
2173 (emt:eq-persist-p
#'equal
2175 "dbid:787cceb2-39a0-46c3-97a7-a23a3de3da4b")))
2177 (emt:doc
"Run this call again")
2179 (equal answer
"1")))
2180 (t "(get-profiling-data)"
2181 (emt:doc
"Now profiling data shows 2 calls to `profiling', 1
2182 to `get-profiling-data'")
2184 (emt:eq-persist-p
#'equal
2186 "dbid:26b534dc-b589-4d2c-9026-7c5ea9b8a858")))
2187 (t "(get-profiling-data)"
2190 (emt:eq-persist-p
#'equal
2192 "dbid:3c018d05-1938-4af6-8ad3-5325b9d16fd6"))))
2196 ;;;_ , debug-klink-capture-form
2198 (defun debug-klink-capture-form ()
2199 "Push entries for an `emtr:expect' script onto the kill ring.
2200 Basically `emtr:expect:buffer-capture-form' specialized for klink.
2202 Current buffer should contain a transcript of a klink session."
2206 (emtr:expect
:buffer-capture-form debug-klink-prompt t t
))
2211 (provide 'debug-klink
)
2213 ;;;_ * Local emacs vars.
2214 ;;;_ + Local variables:
2219 ;;; debug-klink.el ends here