Added tests for stream->list

[Klink.git] / debug-klink.el

;;;_ debug-klink.el --- Help debugging Klink

;;;_. Headers
;;;_ , License
;; Copyright (C) 2010,2011  Tom Breton (Tehom)

;; Author: Tom Breton (Tehom) <tehom@panix.com>
;; Keywords: convenience,tools,local

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;;_ , Commentary:

;; 


;;;_ , Requires

(require 'emtest/editing/expect nil t)
(require 'emtest/testhelp/standard)
(require 'emtest/testhelp/persist)
(require 'emtest/main/define)

;;;_. Body
;;;_ , debug-klink-executable
(defconst debug-klink-executable
   (emt:expand-filename-here "klink")
   "Absolute path to the klink executable" )
;;;_ , DB file
(defconst debug-klink:th:db
   (emt:expand-filename-here "db") 
   "File where presisting results are stored" )
;;;_ , debug-klink-insert-print-type
(defun debug-klink-insert-print-type (obj)
   "Insert a statement to print an pko's type"
   
   (interactive "sObject: ")
   (insert
      "p (enum klink_types)_get_type("obj")"))
;;;_ , debug-klink-read-C-type
(defun debug-klink-read-C-type (prompt)
   ""
   
   (completing-read
      prompt
      '(
          "_kt_spagstack"
          "_kt_tag"
          "kt_boxed_void"
          "kt_cfunc"
          "kt_curried"
          "kt_encap"
          "kt_recur_tracker"
          "kt_recurrence_table"
          "kt_string"
          "kt_vec2"
          "kt_vector"
          "long"
          "num"
          "port"
          )
      nil
      t))


;;;_ , debug-klink-insert-print-obj
(defun debug-klink-insert-print-obj (obj type)
   "Insert a statement to print an pko's value"
   
   (interactive
      (list
         (read-string "Object: ")
         (debug-klink-read-C-type "Type: ")))
   (insert
      "p *("type" *)(((enum klink_types*)"obj")+1)"))
;;;_ , debug-klink-send-line
;;;###autoload
(defun debug-klink-send-line (string)
   "Pass a line to gdb as special input
For (eg) setting breakpoint commands, setting trace collects, etc"

   (interactive "sString: ")
   (comint-send-string (get-buffer-process (current-buffer)) 
      (concat
         string
         "\n")))

;;;_ , debug-klink-send-end
(defun debug-klink-send-end ()
   "Tell gdb the current special input is done"
   
   (interactive)
   ;;$$IMPROVE ME  Make sure it's gdb buffer.
   (comint-send-string (get-buffer-process (current-buffer)) "end\n"))

;;;_ , debug-klink-prompt
(defconst debug-klink-prompt "\nklink> " 
   "Klink's prompt" )
;;;_ , Test suite
(emt:deftest-3
   ((of 'klink)
      (db-id `(persist ,debug-klink:th:db)))
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "12"
         (emt:doc "Communicating at all")
         (emt:assert 
            (equal answer "12")
            t)))
   
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(eval 12 (get-current-environment))"
         (emt:assert 
            (equal answer "12")
            t))
      (t "(eval 12)"
         (emt:assert 
            (equal answer "12")
            t))      
      (t "(eval ''(1 2 3 4)(get-current-environment))"
         (emt:doc "Eval in current environment")
         (emt:assert 
            (equal answer "(1 2 3 4)")
            t))
      (t "(eval ''(1 2 . #(3 4))(get-current-environment))"
         (emt:doc "Eval in current environment")
         (emt:assert 
            (equal answer "(1 2 . #( 3 4))")
            t))
      (t "(eval (get-current-environment)(get-current-environment))"
         (emt:doc "Eval in current environment")
         (emt:assert 
            (equal answer 
               "#<ENVIRONMENT>"
               )
            t))
      (t "(wrap wrap)"
         (emt:doc "Wrap behavior")
         (emt:assert 
            (equal answer 
               "#<APPLICATIVE>"
               )
            t))
      (t "($define! a 12)"
         (emt:doc "$define! behavior")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "a"
         (emt:doc "Result: a is now define 12")
         (emt:assert 
            (equal answer 
               "12"
               )
            t))
      (t "($define! b (eval ''(1 . #(2 3)) (get-current-environment)))"
         (emt:doc "Define b, passing a form")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "b"
         (emt:doc "Result: b is now defined as what the form evaluated to")
         (emt:assert 
            (equal answer 
               "(1 . #( 2 3))"
               )
            t))
      (t "($define! (c d e) '(1 2 3))"
         (emt:doc "Define c, d, and e")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "c"
         (emt:doc "c is defined")
         (emt:assert 
            (equal answer 
               "1"
               )
            t))
      (t "d"
         (emt:doc "d is defined")
         (emt:assert 
            (equal answer 
               "2"
               )
            t))
      (t "e"
         (emt:doc "e is defined")
         (emt:assert 
            (equal answer 
               "3"
               )
            t))
      (t "($set! (get-current-environment) f 14)"
         (emt:doc "$set! behavior")
         (emt:doc "Operation: set f in the current environment")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "f"
         (emt:doc "Result: f is now defined")
         (emt:assert 
            (equal answer 
               "14"
               )
            t))
      (t "($set! (get-current-environment) f 15)"
         (emt:doc "Operation: set f to something else")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "f"
         (emt:doc "Result: f now has the new definition")
         (emt:assert 
            (equal answer 
               "15"
               )
            t))
      (t "($set! (get-current-environment) (g h) '(16 157))"
         (emt:doc "Operation: set g and h")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "g"
         (emt:doc "Result: g is defined")
         (emt:assert 
            (equal answer 
               "16"
               )
            t))
      (t "h"
         (emt:doc "Result: h is defined")
         (emt:assert 
            (equal answer 
               "157"
               )
            t))
      (t "($define! i ($vau (a) e (eval a e)))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "(i '(12 14))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "(12 14)"
               )
            t))
      (t "(i (i '(12 14)))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "(12 14)"
               )
            t))
      (t "(i (car '(12 14)))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "12"
               )
            t))
      (t "($define! j ($vau () e 12))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "(j)"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "12"
               )
            t))
      (t "($define! k ($vau (a) e a))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "(k 12)"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "12"
               )
            t))
      (t "(k '(1 2))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "(#,$quote (1 2))")
            t))
      (t "($define! l ($vau (a b) e a))"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "(l 12 13)"
         (emt:doc "$vau behavior")
         (emt:assert 
            (equal answer 
               "12"
               )
            t))
      (t "($define! (bi ac) (make-keyed-static-variable))"
         (emt:doc "Keyed static variables")
         (emt:assert 
            (equal answer 
               "#inert"
               )
            t))
      (t "ac"
         (emt:doc "Keyed static variables")
         (emt:assert 
            (equal answer 
               "#<APPLICATIVE>"
               )
            t))
      (t "(bi 4 (get-current-environment))"
         (emt:doc "Keyed static variables")
         (emt:assert 
            (equal answer 
               "#<ENVIRONMENT>"
               )
            t))
      (t "(eval '(ac) (bi 4 (get-current-environment)))"
         (emt:doc "Keyed static variables")
         (emt:assert 
            (equal answer 
               "4")
            t)))

   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(eq? () ())"
         (emt:assert
            (equal answer "#t")))
      (t "(eq? '() '())"
         (emt:assert
            (equal answer "#t")))
      (t "(eq? ''() ''())"
         (emt:doc "Double-quoted nils are not `eq?' because both could \
      conceivably be mutated")
         (emt:assert
            (equal answer "#f")))
      (t "(eq? (cdr '(1)) '())"
         (emt:doc "nil generated by finding a tail is `eq?' to explicit nil")
         (emt:assert
            (equal answer "#t"))))

   ;;list-tail
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      
      (t "(list-tail '(0 1 2) 0)"
         (emt:doc "Behavior of list-tail")
         (emt:assert
            (equal answer "(0 1 2)")))
      (t "(list-tail '(0 1 2) 1)"
       (emt:assert
          (equal answer "(1 2)")))
      (t "(list-tail '(0 1 2) 2)"
         (emt:assert
            (equal answer "(2)")))
      (t "(list-tail '(0 1 2) 3)"
         (emt:assert
            (equal answer "()"))))
   
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "($define! a (list 0 1 2))"
         (emt:doc "Make a list object")
         (emt:assert
            (equal answer "#inert")))
      (t "(encycle! a 0 3)"
         (emt:doc "Encycle it, no prefix, the whole object")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:doc "Show the object")
         (emt:assert
            (equal answer "#0=(0 1 2 #0)")))
      (t "($define! a (list 0 1 2))"
         (emt:assert
            (equal answer "#inert")))
      (t "(encycle! a 1 2)"
         (emt:doc "Encycle it, the whole list, with prefix")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:assert
            (equal answer "(0 #0=1 2 #0)")))
      (t "($define! a (list 0 1 2))"
         (emt:assert
            (equal answer "#inert")))
      (t "(encycle! a 0 2)"
         (emt:doc "Encycle it, no prefix, less than the list length")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:assert
            (equal answer "#0=(0 1 #0)")))
      (t "($define! a (list 0 1 2))"
         (emt:assert
            (equal answer "#inert")))
      (t "(encycle! a 1 1)"
         (emt:doc "Encycle it, less than the list length")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:assert
            (equal answer "(0 #0=1 #0)"))))
   
   ;;stream->list
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(stream->list '())"
         (emt:doc "Works on null")
         (emt:assert
            (equal answer "()")))
      (t "(stream->list ($lazy '()))"
         (emt:doc "Works on promised null")
         (emt:assert
            (equal answer "()")))
      (t "(stream->list ($lazy '(1)))"
         (emt:assert
            (equal answer "(1)")))
      (t "(stream->list (list* 1 ($lazy '())))"
         (emt:doc "Works on lazy empty tail")
         (emt:assert
            (equal answer "(1)")))
      (t "(stream->list (list* 1 ($lazy '(2))))"
         (emt:assert
            (equal answer "(1 2)")))
      (t "(stream->list (list* 1 2 ($lazy '())))"
         (emt:assert
            (equal answer "(1 2)"))))


   ;;apply
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "apply"
         (emt:doc "`apply' is recognized")
         (emt:assert
            (equal answer "#,apply")))
      (t "(apply list '(1 2 3) (get-current-environment))"
         (emt:doc "Apply works on list argument")
         (emt:assert
            (equal answer "(1 2 3)")))
      (t "(apply list '(1 2 3))"
         (emt:doc "Apply with default env works on list argument,
      evals each number")
         (emt:assert
            (equal answer "(1 2 3)")))
      (t "(apply list '(a 2 3))"
         (emt:doc "Apply doesn't re-eval args, so this works even \
though the symbol `a' is unbound in the empty environment.")
         (emt:assert
            (equal answer "(a 2 3)")))
      (t "(apply list ''(1 2 3))"
         (emt:doc "Double-quoted gets single-quoted")
         (emt:assert
            (equal answer "(#,$quote (1 2 3))")))

      (t "(apply list '''(1 2 3))"
         (emt:doc "Triple-quoted gets double-quoted")
         (emt:assert
            (equal answer "(#,$quote (#,$quote (1 2 3)))")))

      (t "(apply (wrap list) '(list) (get-current-environment))"
         (emt:doc "In normal environment, we see bindings such as `list'")
         (emt:assert
            (equal answer "(#,list)")))
      (t "(apply (wrap list) '(list) (make-environment))"
         (emt:doc "In blank environment, we see no bindings")
         (emt:assert
            (equal answer "Error: eval: unbound variable: list \n")))
      (t "(apply (wrap $sequence) '(list) (get-current-environment))"
         (emt:doc "In normal environment, we see bindings such as `list'")
         (emt:assert
            (equal answer "#,list")))
      (t "(apply (wrap $sequence) '(list) (make-environment))"
         (emt:doc "In blank environment, we see no bindings")
         (emt:assert
            (equal answer "Error: eval: unbound variable: list \n"))))
   
   ;;predicates
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(integer? 1)"
         (emt:doc "Predicate integer?")
         (emt:assert 
            (equal answer 
               "#t")
            t))
      (t "(integer? 'a)"
         (emt:doc "Predicate integer?")
         (emt:assert 
            (equal answer 
               "#f")
            t)))
   ;;null?
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "null?"
         (emt:doc "null? is recognized")
         (emt:assert
            (equal answer "#,null?")))
      ;;Must eval, which right now we don't.
      (t "(null? '())"
         (emt:assert
            (equal answer "#t")))
      (t "(null? 13)"
         (emt:assert
            (equal answer "#f"))))

   ;;make-encapsulation-type
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "($define! (e p? d) (make-encapsulation-type))"
         (emt:doc "Make an encapsulation type")
         (emt:assert
            (equal answer "#inert")))
      (t "($define! a (e 12))"
         (emt:doc "Make an instance of it")
         (emt:assert
            (equal answer "#inert")))
      (t "(p? a)"
         (emt:doc "The predicate returns true on the instance")
         (emt:assert
            (equal answer "#t")))
      (t "(p? 12)"
         (emt:assert
            (equal answer "#f")))
      (t "(p? a a)"
         (emt:assert
            (equal answer "#t")))
      (t "(p? a #f a)"
         (emt:assert
            (equal answer "#f")))
      (t "(d a)"
         (emt:doc "`d' retrieves the value")
         (emt:assert
            (equal answer "12"))))

   ;;$if
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "$if"
         (emt:doc "$if is recognized")
         (emt:assert
            (equal answer "#,$if")))
      (t "($if #t '1 '2)"
         (emt:doc "On true, evaluates the CONSEQUENT argument")
         (emt:assert
            (equal answer "1")))
      (t "($if #f '1 '2)"
         (emt:doc "On false, evaluates the ALTERNATIVE argument")
         (emt:assert
            (equal answer "2")))
      (t "($if 3 1 2)"
         (emt:doc "On non-boolean test, raises error")
         (emt:assert
            (emt:eq-persist-p 
               #'equal answer
               "dbid:80eedbc8-efd5-47c4-9c3b-d0da6c48f768")))
      (t "($if '#t '1 '2)"
         (emt:doc "On evaluated true, evaluates the CONSEQUENT argument")
         (emt:assert
            (equal answer "1")))
      (t "($if '#f '1 '2)"
         (emt:doc "On evaluated false, evaluates the ALTERNATIVE argument")
         (emt:assert
            (equal answer "2"))))
   ;;$cond
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "($cond (#t 12)(#f 13))"
         (emt:doc "The first true claus is evalled")
         (emt:assert
            (equal answer "12")))
      (t "($cond (#f 13)(#t 12))"
         (emt:doc "False clauses are skipped")
         (emt:assert
            (equal answer "12")))
      (t "($cond ((integer? 'a) 13)(#t 12))"
         (emt:doc "Guard clauses are evalled")
         (emt:assert
            (equal answer "12")))
      (t "($cond ((integer? 'a) 13)((integer? 1) 12))"
         (emt:doc "Guard clauses are evalled")
         (emt:assert
            (equal answer "12")))
      (t "($let ((x 5)) ($cond (#t (list 1 2))))"
         (emt:doc "The selected clause body is evalled")
         (emt:assert
            (equal answer "(1 2)")))
      (t "($cond)"
         (emt:doc "$cond with no clauses gives #inert")
         (emt:assert
            (equal answer "#inert")))
      (t "($let ((x 5)) 
    ($cond ((integer? x)
                   (display \"x=\")
                   (display x)
                   (newline))))"
         (emt:doc "Variables are accessible inside clauses")
         (emt:assert
            (equal answer "x=5\n#inert"))))
   
   
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(listloop listloop-style-neighbors '(1 2 3) 2)"
         (emt:doc "Validate that listloop normally works")
         (emt:assert
            (equal answer "#<OPERATIVE>")))
      (t "(listloop listloop-style-neighbors ($lazy '(1 2 3)) #f)"
         (emt:doc "Validate that listloop will error if it gets the wrong type")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:0488e533-76ef-4720-93d5-bfab229c9079")))
      (t "(listloop listloop-style-neighbors '(1 2 3) ($lazy 2))"
         (emt:doc "It accepts lazy style arguments")
         (emt:assert
            (equal answer "#<OPERATIVE>")))
      (t "(listloop listloop-style-neighbors ($lazy '(1 2 3)) ($lazy 2))"
         (emt:doc "It accepts lazy lists")
         (emt:assert
            (equal answer "#<OPERATIVE>"))))
   
   ;;$sequence
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "($sequence)"
         (emt:doc "$sequence with no args gives inert")
         (emt:assert
            (equal answer "#inert")))
      (t "($sequence '1)"
         (emt:doc "Sequence evaluates its args")
         (emt:assert
            (equal answer "1")))
      (t "($sequence '1 '2)"
         (emt:doc "Sequence returns the value of the last element")
         (emt:assert
            (equal answer "2")))
      (t "($define! my-lam ($lambda v (write v)(newline)))"
         (emt:doc "Define a lambda having a sequence"))
      (t "(my-lam 12)"
         (emt:doc "That lambda evals all the sequence")
         (emt:assert
            (equal answer "(12)\n#inert"))))
   
   
   ;;write and display
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "($sequence (write \"abc\") (newline))"
       (emt:doc "`write' displays objects escaped for read-back")
       (emt:assert
          (equal answer "\"abc\"\n#inert")))
      (t "($sequence (display \"abc\") (newline))"
         (emt:doc "`display' displays objects unescaped")
         (emt:assert
            (equal answer "abc\n#inert")))
      (t "($sequence (display '(1 2 3)) (newline))"
         (emt:doc "`display' can display full objects")
         (emt:assert
            (equal answer "(1 2 3)\n#inert")))
      (t "($sequence (write '(1 2 3)) (newline))"
         (emt:doc "`write' can display full objects")
         (emt:assert
            (equal answer "(1 2 3)\n#inert"))))

   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(read)\n12"
         (emt:doc "Reads numbers")
         (emt:assert
            (equal answer "12")))
      (t "(read)\nsym"
         (emt:doc "Reads symbols")
         (emt:assert
            (equal answer "sym")))
      (t "(read)\n(1 2 3)"
         (emt:doc "Reads lists, no problem with nesting depth.")
         (emt:assert
            (equal answer "(1 2 3)"))))

   
   ;;On typechecking
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "true/o1"
         (emt:doc "true/o1 predicate is recognized")
         (emt:assert
            (equal answer "#,true/o1")
            t))
         
      (t "(true/o1 1)"
         (emt:doc "true/o1 predicate gives #t")
         (emt:assert
            (equal answer "#t")
            t))
      (t "type?"
         (emt:doc "`type?' is recognized")
         (emt:assert
            (equal answer "#,type?")
            t))

      (t "(type? 1 true/o1)"
         (emt:doc "`type?' can be called")
         (emt:assert
            (equal answer "#t")
            t))
      (t "listtype"
         (emt:doc "`listtype' ctor is recognized")
         (emt:assert
            (equal answer "#,listtype")
            t))
      (t "(listtype true/o1)"
         (emt:doc "`listtype' makes an operative")
         (emt:assert
            (equal answer "#<OPERATIVE>")
            t))
      (t "(listtype true/o1 true/o1)"
         (emt:doc "`listtype' takes a list of args")
         (emt:assert
            (equal answer "#<OPERATIVE>")
            t))
      (t "(type? 1 (listtype true/o1))"
         (emt:doc "`listtype' makes one that expects a list")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1) (listtype integer?))"
         (emt:doc "Second-level listtypes work OK")
         (emt:assert
            (equal answer "#t")
            t))
      (t "(type? '(#t) (listtype integer?))"
         (emt:doc "Second-level listtype discriminate (non)match")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1) (listtype true/o1 true/o1))"
         (emt:doc "Situation: Too few elements")
         (emt:doc "Result: false")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1) (listtype))"
         (emt:doc "Situation: Objects has too many elements")
         (emt:doc "Result: false")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1) (listtype true/o1 'optional true/o1))"
         (emt:doc "Situation: Optional elements")
         (emt:doc "Result: true")
         (emt:assert
            (equal answer "#t")
            t))
      (t "(type? '(1 2 3) (listtype true/o1 'optional true/o1))"
         (emt:doc "Situation: Number of items outruns number of optional elements")
         (emt:doc "Result: false")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1) (listtype true/o1 'optional 'optional))"
         (emt:doc "Situation: Two optional keys given")
         (emt:doc "Result: error")
         (emt:assert
            (emt:eq-persist-p
               #'equal 
               answer
               "dbid:e144f830-d6a5-4240-94f0-b0b8a9890d42")))
      (t "(type? '(1) (listtype true/o1 'DOT))"
         (emt:doc "Situation: Dot spec has no spec after it")
         (emt:doc "Result: error")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer 
               "dbid:37a39a99-8b11-4d6f-9e31-033af8d73d41")))
      (t "(type? '(1) (listtype true/o1 'DOT true/o1 true/o1))"
         (emt:doc "Situation: Dot spec has more than 1 spec after it")
         (emt:doc "Result: error")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer 
               "dbid:7f057673-3b94-4e4c-a25c-b09ed5239af2")))
      (t "(type? '(1 2 3) (listtype true/o1 'DOT true/o1))"
         (emt:doc "Situation: Dot spec is satisfied")
         (emt:doc "Result: true")
         (emt:assert
            (equal answer "#t")
            t))
      (t "(type? '(1 2 3) (listtype true/o1 'DOT integer?))"
         (emt:doc "Situation: Dot spec is reached but doesn't match")
         (emt:doc "Result: false")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1 2 3) (listtype true/o1 'REPEAT integer?))"
         (emt:doc "Situation: Repeat spec is used and matches")
         (emt:doc "Result: true")
         (emt:assert
            (equal answer "#t")
            t))
      (t "(type? '(1 2 #t) (listtype true/o1 'REPEAT integer?))"
         (emt:doc "Situation: Repeat spec is used but doesn't match")
         (emt:doc "Result: false")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT integer? true/o1))"
         (emt:doc "Situation: Repeat spec is used, has 2 items, matches")
         (emt:doc "Result: true")
         (emt:assert
            (equal answer "#t")
            t))
      (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT true/o1 integer?))"
         (emt:doc "Situation: Repeat spec is used, has 2 items, but doesn't match")
         (emt:doc "Result: false")
         (emt:assert
            (equal answer "#f")
            t))
      (t "(type? '(1) (listtype true/o1 'REPEAT integer?))"
         (emt:doc "Situation: Repeat spec is used, zero items available")
         (emt:doc "Result: true")
         (emt:assert
            (equal answer "#t")
            t))
      ;; $$IMPROVE ME Test circularity, use encycle!
      )

   ;;On destructuring
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")

      (t "destructure-list"
         (emt:doc "Test `destructure-list'")
         (emt:doc "ctor is recognized")
         (emt:assert
            (equal answer "#,destructure-list")
            t))
      (t "(destructure-list true/o1)"
         (emt:doc "It makes an operative")
         (emt:assert
            (equal answer "#<OPERATIVE>")
            t))
      (t "(destructure-list true/o1 true/o1)"
         (emt:doc "It takes a list of args")
         (emt:assert
            (equal answer "#<OPERATIVE>")
            t))
      (t "(do-destructure 1 true/o1)"
         (emt:doc "do-destructure can take just a combiner as arg")
         (emt:assert
            (equal answer "#( 1)")))
      (t "(do-destructure 1 (destructure-list true/o1))"
         (emt:doc "It makes one that expects a list")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer 
               "dbid:3e113873-73a0-46f5-8e14-f41034780317")))
      (t "(do-destructure '(1) (destructure-list integer?))"
         (emt:doc "Second-level destructures work OK")
         (emt:assert
            (equal answer "#( 1)")
            t))
      (t "(do-destructure '(#t) (destructure-list integer?))"
         (emt:doc "Second-level destructure discriminate (non)match")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer
               "dbid:dc2648ef-22cb-41c2-8f9b-67548b0a3b7a")))
      (t "(do-destructure '(1) (destructure-list true/o1 true/o1))"
         (emt:doc "Situation: Too few elements")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p
               #'equal
               answer
               "dbid:b50e8f78-6652-418d-9b44-1ff676946970")))
      (t "(do-destructure '(1) (destructure-list))"
         (emt:doc "Situation: Objects has too many elements")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p
               #'equal 
               answer
               "dbid:ee168f5d-5d87-4792-9dba-0fd0ac7c14a4")))
      
      (t "(do-destructure '(1) (destructure-list true/o1 'optional true/o1))"
         (emt:doc "Situation: Optional elements")
         (emt:doc "Result: true")
         (emt:assert
            (equal answer "#( 1 #inert)")
            t))

      (t "(do-destructure '(1 2 3) (destructure-list true/o1 'optional true/o1))"
         (emt:doc "Situation: Number of items outruns number of optional elements")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:a1bd1321-532e-4187-af64-278c009a7f97")))

      (t "(do-destructure '(1) (destructure-list true/o1 'optional 'optional))"
         (emt:doc "Situation: Two optional keys given")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p
               #'equal 
               answer
               "dbid:ece901d5-4ac0-496e-a9e2-83423a933522")))

      (t "(do-destructure '(1) (destructure-list true/o1 'dot))"
         (emt:doc "Situation: Dot spec has no spec after it")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer 
               "dbid:8e8711ba-bada-4223-a212-3256d6a2e497")))

      (t "(do-destructure '(1) (destructure-list true/o1 'dot true/o1 true/o1))"
         (emt:doc "Situation: Dot spec has more than 1 spec after it")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer 
               "dbid:4d68ceb6-f450-4218-b222-c10019a39819")))

      (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot true/o1))"
         (emt:doc "Situation: Dot spec is satisfied")
         (emt:doc "Result: true")
         (emt:assert
            (equal answer "#( 1 (2 3))")
            t))

      (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot integer?))"
         (emt:doc "Situation: Dot spec is reached but doesn't match")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:266cbd1e-734c-4a81-bac6-e9d9a3424e79")))
      
      (t "(do-destructure  '(1) 13)"
         (emt:doc "Fails gracefully when given a non-combiner")
         (emt:assert
            (emt:eq-persist-p
               #'equal answer 
               "dbid:2492173b-e70f-460d-87a0-da1aff73d22e")))
      (t "(do-destructure 1 ($lambda (x) (true/o1 x)))"
         (emt:doc "Accepts combiners that use the main loop")
         (emt:assert
            (equal answer "#( 1)")))
      (t "(do-destructure '(1) (destructure-list ($vau (x) #ignore (true/o1 x))))"
         (emt:assert
            (equal answer "#( 1)"))))
   
   ;;On define-type destructuring
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "($define! (a b) ($lazy '(12 144)))"
         (emt:doc "Define with a lazy value")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:doc "A has been defined")
         (emt:assert
            (equal answer "12")))
      (t "b"
         (emt:doc "B has been defined")
         (emt:assert
            (equal answer "144")))
      (t "($define! ((a b)(c d)) (list ($lazy '(20736 1728))($lazy '(144 12))))"
         (emt:doc "Define with multiple lazy values")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:doc "A has been changed")
         (emt:assert
            (equal answer "20736")))
      (t "b"
         (emt:assert
            (equal answer "1728")))
      (t "c"
         (emt:assert
            (equal answer "144")))
      (t "d"
         (emt:assert
            (equal answer "12")))
      (t "((wrap ($vau ((a b)) #ignore (list a b))) '(144 12))"
         (emt:doc "Validate: Without laziness, vau works as expected")
         (emt:assert
            (equal answer "(144 12)")))
      (t "((wrap ($vau ((a b)) #ignore (list a b))) ($lazy '(144 12)))"
         (emt:doc "Handles laziness too")
         (emt:assert
            (equal answer "(144 12)")))
      (t "((wrap ($vau ((a b)(c d)) #ignore (list a b c d))) '(20736 1728) '(144 12))"
         (emt:assert
            (equal answer "(20736 1728 144 12)")))
      (t "((wrap ($vau ((a b)(c d)) #ignore (list a b c d))) 
            ($lazy '(20736 1728)) 
            ($lazy '(144 12)))"
         (emt:doc "Handles nested and double-lazy too")
         (emt:assert
            (equal answer "(20736 1728 144 12)")))
      (t "((wrap ($vau ((a b)) #ignore (list a b))) ($lazy 144))"
         (emt:doc "Error on values that don't fit even when forced")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:6928bebb-0876-448c-9a9b-f72410c94422")))
      (t "((wrap ($vau ((a b (c d))) #ignore (list a b c d))) 
                ($lazy (list 20736 1728 ($lazy '(144 12)))))"
         (emt:doc "Works even on nested promises")
         (emt:assert
            (equal answer "(20736 1728 144 12)"))))


   ;;On where-typemiss
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")

      (t "(where-typemiss 1 (listtype true/o1))"
         (emt:doc "`listtype' makes one that expects a list")
         (emt:assert
            (equal answer "(0 too-few)")
            t))
      (t "(where-typemiss '(#t) (listtype integer?))"
         (emt:doc "Second-level listtype discriminate (non)match")
         ;;Use persist because the form of the printout changes.
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:cc211ae0-718b-4462-9062-7f0077cdf162")))
      (t "(where-typemiss '(1) (listtype true/o1 true/o1))"
         (emt:doc "Situation: Too few elements")
         (emt:assert
            (equal answer "(1 too-few)")
            t))
      (t "(where-typemiss '(1) (listtype))"
         (emt:doc "Situation: Objects has too many elements")
         (emt:assert
            (equal answer "(0 too-many)")
            t))
      (t "(where-typemiss '(1 2 3) (listtype true/o1 'optional true/o1))"
         (emt:doc "Situation: Number of items outruns number of optional elements")
         (emt:assert
            (equal answer "(2 too-many)")
            t))
      (t "(where-typemiss '(1 2 3) (listtype true/o1 'dot integer?))"
         (emt:doc "Situation: Dot spec is reached but doesn't match")
         (emt:assert
            (emt:eq-persist-p #'equal answer 
               "dbid:2f83b114-6bdf-4c7d-9a76-0d3e8b43483c")))
      (t "(where-typemiss '(1 2 #t) (listtype true/o1 'repeat integer?))"
         (emt:doc "Situation: Repeat spec is used but doesn't match")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:f90a1f49-9180-4817-8095-6422ee058745")))
      (t "(where-typemiss '(1 2 #t 4 #t) (listtype true/o1 'repeat true/o1 integer?))"
         (emt:doc "Situation: Repeat spec is used, has 2 items, but doesn't match")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:374c6ab3-7907-4ff5-b14d-e41584593296")))
      ;; $$IMPROVE ME Test circularity, use encycle!

      )
   ;;On get-list-metrics
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(length '(0 1))"
         (emt:assert
            (equal answer "2")))
      (t "(finite-list? '(0 1))"
         (emt:assert
            (equal answer "#t")))
      (t "(finite-list? #f)"
         (emt:assert
            (equal answer "#f")))
      (t "(get-list-metrics '(0 1))"
         (emt:assert
            (equal answer "(2 1 2 0)")))
      (t "(get-list-metrics #f)"
         (emt:assert
            (equal answer "(0 0 0 0)")))
      (t "(get-list-metrics '(0 . 1))"
         (emt:assert
            (equal answer "(1 0 1 0)")))
      (t "($define! a (list 12))"
         (emt:doc "Make a circular object"))
      (t "(set-cdr! a a)")
      (t "(get-list-metrics a)"
         (emt:doc "List metrics of a circular object")
         (emt:assert
            (equal answer "(1 0 0 1)")))
   

      )

   ;;On making environment
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      ;;Clean out header stuff
      (t "")
      (t "(make-environment (get-current-environment))"
         (emt:doc "Can make an environment")
         (emt:assert
            (equal answer "#<ENVIRONMENT>")))
      (t "(make-environment)"
         (emt:doc "Can make an empty environment")
         (emt:assert
            (equal answer "#<ENVIRONMENT>")))

      (t "(eval 'make-environment (make-environment))"
         (emt:doc "Empty environment does not bind things")
         (emt:assert
            (emt:eq-persist-p
               #'equal answer "dbid:930c9cb4-c8e3-446a-9d0f-80a7a01edf2e")))

      (t "($define! env1 (make-environment))"
         (emt:doc "Define example environments")
         (emt:assert
            (equal answer "#inert")))
      (t "($define! env2 (make-environment))"
         (emt:assert
            (equal answer "#inert")))
      (t "($set! env1 a 12)"
         (emt:doc "Define things in those example environments")
         (emt:assert
            (equal answer "#inert")))
      (t "($set! env2 b 144)"
         (emt:assert
            (equal answer "#inert")))
      (t "(eval 'a env1)"
         (emt:doc "The respective bindings are available in the environments")
         (emt:assert
            (equal answer "12")))
      (t "(eval 'b env2)"
         (emt:assert
            (equal answer "144")))
      (t "($define! env1+2 (make-environment env1 env2))"
         (emt:doc "Can make an environment from multiple parents")
         (emt:assert
            (equal answer "#inert")))
      (t "(eval 'a env1+2)"
         (emt:doc "It contains the bindings of both environments")
         (emt:assert
            (equal answer "12")))
      (t "(eval 'b env1+2)"
         (emt:assert
            (equal answer "144"))))

   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(reverse-lookup get-current-environment (get-current-environment))"
         (emt:doc "Operation: look up an object we know is bound")
         (emt:doc "Result: We find it")
         (emt:assert
            (equal answer "get-current-environment")))
      (t "(reverse-lookup reverse-lookup (get-current-environment))"
         (emt:doc "Same on another object")
         (emt:assert
            (equal answer "reverse-lookup")))
      (t "(reverse-lookup 'example-unsymboled-object (get-current-environment))"
         (emt:doc "Operation: look up an object we know is not bound")
         (emt:doc "Result: Error")
         (emt:assert
            (emt:eq-persist-p #'equal answer 
               "dbid:c3ec8dcc-39b2-4885-b4f3-f6e5f018c11e")))
      (t "($define! a (list))"
         (emt:doc "Make an object we will look for"))
      (t "($define! my-env (make-environment))")
      (t "($set! my-env b a)"
         (emt:doc "In my-env, define b as that object"))
      (t "($set! my-env b 13)"
         (emt:doc "Now define b as something else"))
      (t "(reverse-lookup a my-env)"
         (emt:doc "Look up the original object")
         (emt:assert
            (emt:eq-persist-p
               #'equal answer 
               "dbid:673c63c9-1844-4c7f-b67d-22c6ef88fc66")))
      (t "($define! my-env2 (make-environment))"
         (emt:doc "Make another empty environment"))
      (t "($set! my-env2 c a)"
         (emt:doc "In my-env2, define c as that object"))      
      (t "($set! my-env2 b a)"
         (emt:doc "In my-env2, define b as that object"))
      (t "($set! my-env2 b 13)"
         (emt:doc "Now define b as something else"))
      (t "(reverse-lookup a my-env2)"
         (emt:doc "Operation: Look up the original object")
         (emt:doc "Result: We find its binding, c")
         (emt:assert
            (equal answer "c")))
      (t "($set! my-env2 b a)"
         (emt:doc "Define b as that object again"))
      (t "($define! my-env3 (make-environment my-env2))"
         (emt:doc "Make an environment derived from my-env2"))
      (t "($set! my-env3 b 13)"
         (emt:doc "There set b to be something else"))
      (t "(reverse-lookup a my-env3)"
         (emt:doc "Operation: Look up the original object")
         (emt:doc "Result: We find its binding")
         (emt:assert
            (equal answer "c"))))

   ;;On printing, esp circular objects
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))

      (t "")
      (t "print-lookup-env"
         (emt:assert
            (equal answer "#,print-lookup-env"))
         )
      (t "(list 1 2)"
         (emt:doc "Lists print OK")
         (emt:assert
            (equal answer "(1 2)")))
      (t "wrap"
         (emt:doc "Bound objects print a lowquote and their binding")
         (emt:assert
            (equal answer "#,wrap")))
      (t "list"
         (emt:assert
            (equal answer "#,list")))
      (t "(list list)"
         (emt:doc "These objects are actual working combiners.")
         (emt:assert
            (equal answer "(#,list)")))

      )

   ;;On get-recurrences
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))

      (t "")
      (t "($define! cycles-nil (get-recurrences '()))"
         (emt:doc "`cycles-nil' is the recurrences of object '()"))
      (t "(recurrence-table? cycles-nil)"
         (emt:assert
            (equal answer "#t")))
      ;; $$RECONSIDER ME
      (t "(recurrences-get-object-count cycles-nil '())"
         (emt:doc "Nils are not counted")
         (emt:assert
            (equal answer "0")))
      (t "($define! cycles-list (get-recurrences (list 12 144)))"
         (emt:doc "`cycles-list' is the recurrences of an ordinary list"))
      (t "(recurrence-table? cycles-list)"
         (emt:assert
            (equal answer "#t")))
      (t "($define! cycles-many-nils (get-recurrences '()))"
         (emt:doc "`cycles-many-nils' is the recurrences of object of
      multiple nils"))
      (t "(recurrence-table? cycles-many-nils)"
         (emt:assert
            (equal answer "#t")))
      (t "(recurrences-get-object-count cycles-many-nils '())"
         (emt:doc "Nils do not constitute shared objects")
         (emt:assert
            (equal answer "0")))
      (t "($define! cycles-f (get-recurrences '(#f #f)))"
         (emt:doc "Get the recurrences of any object with repeated objects"))
      (t "(recurrence-table? cycles-f)"
         (emt:assert
            (equal answer "#t")))
      (t "(recurrences-get-object-count cycles-f #f)"
         (emt:assert
            (equal answer "2")))
      (t "($define! a (list 12))"
          (emt:doc "Define a circular object"))
      (t "(set-cdr! a a)")
      (t "($define! cycles-a (get-recurrences a))")
      (t "(recurrence-table? cycles-a)"
         (emt:assert
            (equal answer "#t")))
      (t "(recurrences-get-object-count cycles-a a)"
          (emt:assert
             (equal answer "2"))))

   ;;On lists and wrapping
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(list 1 2)"
         (emt:doc "List works")
         (emt:assert
            (equal answer "(1 2)")))
      (t "(reverse (list 1 2))"
         (emt:doc "Reverse works")
         (emt:assert
            (equal answer "(2 1)")))
      (t "((wrap list) 1 2)"
         (emt:doc "Wrap wrapped over an applicative works (wrap^2)")
         (emt:assert
            (equal answer "(1 2)")))
      (t "((wrap list) '1 '2)"
         (emt:doc "Wrap^2 eliminates at least one level of quoting")
         (emt:assert
            (equal answer "(1 2)")))
      (t "((wrap list) ''1 ''2)"
         (emt:doc "Wrap^2 eliminates two levels of quoting")
         (emt:assert
            (equal answer "(1 2)")))
      (t "((wrap list) '''1 '''2)"
         (emt:doc "Wrap^2 leaves one of three levels of quoting")
         (emt:assert
            (equal answer "((#,$quote 1) (#,$quote 2))")))
      (t "((wrap (wrap list)) '''1 '''2)"
         (emt:doc "Wrap^3 eliminates three levels of quoting")
         (emt:assert
            (equal answer "(1 2)"))))

   ;;On map, map1, counted-map/4
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(map1 list '(1 2 3))"
         (emt:doc "It works")
         (emt:assert
            (equal answer "((1) (2) (3))")))
      (t "(map1 (unwrap list) '(1 2 3))"
         (emt:doc "It wants an applicative argument")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer 
               "dbid:bf93cc1e-534c-4a1f-8762-3072e59dcb3c")))
      (t "(counted-map/4 2 1 list '((1 2)))"
         (emt:doc "Generally behaves like `map'")
         (emt:assert
            (equal answer "((1) (2))")))
      (t "(counted-map/4 1 1 list '((1 2)))"
         (emt:doc "Stops after N elements")
         (emt:assert
            (equal answer "((1))")))
      (t "(counted-map/4 2 2 list '((1 2) (11 12)))"
         (emt:doc "Can treat multiple lists")
         (emt:assert
            (equal answer "((1 11) (2 12))")))
      (t "(map list '(1 2))"
         (emt:doc "Check full `map'")
         (emt:assert
            (equal answer "((1) (2))")))
      (t "(map list '(1 2) '(11 12))"
         (emt:assert
            (equal answer "((1 11) (2 12))"))))

   ;;On continuations
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "($define! my-con-list (call/cc list))"
         (emt:doc "Make an object containing a continuation"))
      (t "my-con-list"
         (emt:doc "Check what we got")
         (emt:assert
            (equal answer "(#<CONTINUATION>)")))
      (t "($define! my-con (car my-con-list))"
         (emt:doc "Extract that continuation"))
      (t "my-con"
         (emt:doc "Check what we got")
         (emt:assert
            (equal answer "#<CONTINUATION>")))
      (t "(continuation->applicative my-con)"
         (emt:doc "Try a simple call")
         (emt:assert
            (equal answer "#<APPLICATIVE>")))
      (t "((continuation->applicative my-con) 12)"
         (emt:doc "Use the continuation")
         (emt:assert
            (equal answer "#inert")))
      (t "my-con-list"
         (emt:doc "my-con-list got redefined by the continuation")
         (emt:assert
            (equal answer "(12)")))
      (t "(apply (continuation->applicative (extend-continuation my-con
                    ($lambda v
                       (display \"arrived at the continuation with \")
                       (write v)
                       (newline)))) '(144))"
         (emt:assert
            (equal answer 
               "arrived at the continuation with (144)\n#inert")))
      (t "($define! my-unguarded-con (guard-continuation '() my-con '()))"
         (emt:doc "Make a continuation that has empty list of guards")
         (emt:assert
            (equal answer "#inert")))
      (t "(apply (continuation->applicative my-unguarded-con) '(145))"
         (emt:doc "Applies without problem")
         (emt:assert
            (equal answer "#inert")))
      (t "my-con-list"
         (emt:doc "The continuation got called")
         (emt:assert
            (equal answer "(145)")))

      (t "($define! my-guarded-con (guard-continuation
    (list (list root-continuation
                               ($lambda (v %ignore)
                                  (display \"entering the continuation with \")
                                  (write v)
                                  (newline)
                                  v)))
    my-con
    (list (list root-continuation
                               ($lambda (v %ignore)
                                  (display \"exiting the continuation with \")
                                  (write v)
                                  (newline)
                                  v)))))"
         (emt:doc "Create a guarded continuation")
         (emt:assert
            (equal answer "#inert")))
      (t "my-guarded-con"
         (emt:doc "Type is correct")
         (emt:assert
            (equal answer "#<CONTINUATION>")))
      (t "(continuation->applicative my-guarded-con)"
         (emt:doc "Type is correct")
         (emt:assert
            (equal answer "#<APPLICATIVE>")))
      (t "(apply (continuation->applicative my-guarded-con) '(146))"
         (emt:doc "We see it calls the guard and continues")
         (emt:assert
            (equal answer "entering the continuation with (146)\n#inert")))
      (t "my-con-list"
         (emt:doc "The continuation got called")
         (emt:assert
            (equal answer "(146)")))
      (t "(guard-dynamic-extent 
        '() 
        ($lambda () (display \"Got here\")(newline))
         '())"
         (emt:doc "Calls the combiner arg with no variables")
         (emt:assert
            (equal answer "Got here\n#inert")))
   (t "(guard-dynamic-extent 
        (list (list root-continuation               ($lambda (v %ignore)
                  (display \"Abnormally entering dynamic extent.\")
                  (newline)
                  v))) 
        ($lambda () (display \"Got here\")(newline)) 
        '())"
      (emt:doc "Does not initially call the entry guards")
      (emt:assert
            (equal answer "Got here\n#inert")))
   (t "(guard-dynamic-extent 
        '() 
        ($lambda () (display \"Got here\")(newline)) 
        (list (list root-continuation               ($lambda (v %ignore)
                  (display \"Abnormally entering dynamic extent.\")
                  (newline)
                  v))))"
      (emt:doc "Does not initially call the exit guards")
      (emt:assert
         (equal answer "Got here\n#inert"))))



   ;;On `and?' etc
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "and?"
         (emt:doc "Is recognized")
         (emt:assert
            (equal answer "#,and?")))
      (t "(and?)"
         (emt:doc "Given no args, returns true")
         (emt:assert
            (equal answer "#t")))
      (t "(and? #t)"
         (emt:doc "Accepts 1 arg")
         (emt:assert
            (equal answer "#t")))
      (t "(and? #t #t)"
         (emt:doc "Accepts 2 args")
         (emt:assert
            (equal answer "#t")))
      (t "(and? #t #f)"
         (emt:doc "If an arg is false, returns false")
         (emt:assert
            (equal answer "#f")))
      (t "(and? #t (integer? 1))"
         (emt:doc "Arguments are evaluated")
         (emt:assert
            (equal answer "#t")))
      (t "(and? #t (integer? \"11\"))"
         (emt:doc "The evaluated value is used")
         (emt:assert
            (equal answer "#f")))
      (t "(or? #f)"
         (emt:doc "If there are only false clauses, returns false")
         (emt:assert
            (equal answer "#f")))
      (t "(or? #f #t)"
         (emt:doc "If there is any true clause, return true")
         (emt:assert
            (equal answer "#t")))
      (t "(or? #f #t #f)"
         (emt:assert
            (equal answer "#t")))
      (t "($and?)"
         (emt:doc "The evaluating variant")
         (emt:assert
            (equal answer "#t")))
      (t "($and? #t #f)"
         (emt:assert
            (equal answer "#f")))
      (t "($and? #f #t)"
         (emt:assert
            (equal answer "#f")))
      (t "($and? ($sequence (display \"One\")(newline) #f))"
         (emt:doc "Evaluates some of its args, at least the first one")
         (emt:assert
            (equal answer "One\n#f")))
      (t "($and? ($sequence (display \"One\")(newline) #t)($sequence (display \"Two\")(newline) #f))"
         (emt:assert
            (equal answer "One\nTwo\n#f")))
      (t "($and? ($sequence (display \"One\")(newline) #f)($sequence (display \"Two\")(newline) #f))"
         (emt:assert
            (equal answer "One\n#f")))
      (t "(every?/2-xary and? '())"
         (emt:doc "xary-1 `every?/2-xary' is available (in `simple' environment)")
         (emt:assert
            (equal answer "#t")))
      (t "(every?/2-xary and? '(()))"
         (emt:doc "No elements")
         (emt:assert
            (equal answer "#t")))
      (t "(every?/2-xary and? '((#f)))"
         (emt:doc "One element containing one element (for `and?')")
         (emt:assert
            (equal answer "#f")))
      (t "(every?/2-xary and? '((#t #t)))"
         (emt:doc "More elements")
         (emt:assert
            (equal answer "#t")))
      (t "(every?/2-xary and? '((#t #t)(#t)))"
         (emt:assert
            (equal answer "#t")))
      (t "(every?/2-xary and? '((#t #t)(#f)))"
         (emt:assert
            (equal answer "#f"))))

   
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(>? 1 0)"
         (emt:doc "Test that comparisons work as expected")
         (emt:assert
            (equal answer "#t")))
      (t "(>? 1 1)"
         (emt:assert
            (equal answer "#f")))
      (t "(>? 1 2)"
         (emt:assert
            (equal answer "#f")))
      (t "(<? 1 0)"
         (emt:assert
            (equal answer "#f")))
      (t "(<? 1 1)"
         (emt:assert
            (equal answer "#f")))
      (t "(<? 1 2)"
         (emt:assert
            (equal answer "#t")))
      (t "(>=? 1 0)"
         (emt:assert
            (equal answer "#t")))
      (t "(>=? 1 1)"
         (emt:assert
            (equal answer "#t")))
      (t "(>=? 1 2)"
         (emt:assert
            (equal answer "#f")))
      (t "(<=? 1 0)"
         (emt:assert
            (equal answer "#f")))
      (t "(<=? 1 1)"
         (emt:assert
            (equal answer "#t")))
      (t "(<=? 1 2)"
         (emt:assert
            (equal answer "#t")))
      (t "(compare-neighbors <? '(0 1 2))"
         (emt:assert
            (equal answer "#t")))
      (t "(compare-neighbors <? '(0))"
         (emt:assert
            (equal answer "#t")))
      (t "(compare-neighbors <=? '(0 1 2))"
         (emt:assert
            (equal answer "#t")))
      (t "(compare-neighbors <? '(0 1 1 2))"
         (emt:assert
            (equal answer "#f")))
      (t "(compare-neighbors <=? '(0 1 1 2))"
         (emt:assert
            (equal answer "#t"))))


   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(+ 1 2 3)"
         (emt:doc "N-ary addition works")
         (emt:assert
            (equal answer "6")))
      (t "(+ 1 2 (+ 3 0))"
         (emt:doc "N-ary addition evaluates its arguments")
         (emt:assert
            (equal answer "6")))
      (t "(+)"
         (emt:doc "N-ary addition gives 0 on no operands")
         (emt:assert
            (equal answer "0")))
      (t "(+ 3)"
         (emt:doc "N-ary addition with 1 operand works")
         (emt:assert
            (equal answer "3")))

      (t "(* 1 2 30)"
         (emt:doc "N-ary multiplication works")
         (emt:assert
            (equal answer "60")))
      (t "(* 1 2 (* 3 10))"
         (emt:doc "N-ary multiplication evaluates its arguments")
         (emt:assert
            (equal answer "60")))
      (t "(*)"
         (emt:doc "N-ary multiplication gives 0 on no operands")
         (emt:assert
            (equal answer "1")))
      (t "(* 3)"
         (emt:doc "N-ary multiplication with 1 operand works")
         (emt:assert
            (equal answer "3")))
      (t "(/ 2 2)"
         (emt:doc "Dividing an integer by itself gives 1")
         (emt:assert
            (equal answer "1")))
      (t "(/ 2 1)"
         (emt:doc "Dividing an integer by 1 gives itself")
         (emt:assert
            (equal answer "2")))
      (t "(/ 1.0 2.0)"
         (emt:doc "For real division, it doesn't floor")
         (emt:assert
            (equal answer "0.5")))
      (t "(/ 6 3)"
         (emt:assert
            (equal answer "2")))
      (t "(/ 6 3 2)"
         (emt:assert
            (equal answer "1")))
      (t "(/ 6 3 2 2)"
         (emt:assert
            (equal answer "0.5")))
      (t "(- 100 20)"
         (emt:assert
            (equal answer "80")))
      (t "(- 100 20 5)"
         (emt:assert
            (equal answer "75")))
      (t "(- 100)"
         (emt:doc "`-' with no subtrahends raises error")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:d0afc822-58f7-4921-b37d-57d45cd6b5e0")))
      (t "(/ 6)"
         (emt:doc "`/' with no divisors raises error")
         (emt:assert
            (emt:eq-persist-p #'equal answer
               "dbid:2afbb9f8-3016-46a5-bb93-9d9d2fdd0e98"))))
   ;;equal?
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(equal?/2 3 3)"
         (emt:doc "Compares numbers correctly")
         (emt:assert
            (equal answer "#t")))
      (t "(equal?/2 3 2)"
         (emt:assert
            (equal answer "#f")))
      (t "(equal?/2 3 '(1 2))"
         (emt:assert
            (equal answer "#f")))
      (t "(equal?/2 'a 'a)"
         (emt:doc "Compares symbols correctly")
         (emt:assert
            (equal answer "#t")))
      (t "(equal?/2 'a 'b)"
         (emt:assert
            (equal answer "#f")))
      (t "(equal?/2 '(1 2) '(1 2))"
         (emt:doc "Compares lists correctly")
         (emt:assert
            (equal answer "#t")))
      (t "(equal?/2 '(1 2) '(1 3))"
         (emt:doc "Compares lists correctly")
         (emt:assert
            (equal answer "#f")))
      (t "(equal?/2 \"meet\" \"meet\")"
          (emt:doc "Compares strings correctly")
          (emt:assert
             (equal answer "#t")))
      (t "(equal?/2 \"meet\" \"not\")"
          (emt:doc "Compares strings correctly")
          (emt:assert
             (equal answer "#f")))
      (t "(equal?)"
          (emt:doc "Given the empty list, is true")
         (emt:assert
            (equal answer "#t")))
      
      )


   ;;$provide, $binds?
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "($define! a #f)")
      (t "($define! b #f)")
      (t "($provide! (b c) ($define! a 13) ($define! b 12) ($define! c 144))"
         (emt:doc "`$provide!' b and c but not a")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:doc "`a' is what it was")
         (emt:assert
            (equal answer "#f")))
      (t "b"
         (emt:doc "b has been changed")
         (emt:assert
            (equal answer "12")))
      (t "c"
         (emt:doc "c is available")
         (emt:assert
            (equal answer "144")))
      (t "((wrap $binds?/2) (get-current-environment) 'wrap)"
         (emt:doc "Test the simple version")
         (emt:doc "We know `wrap' should be bound")
         (emt:assert
            (equal answer "#t")))
      (t "((wrap $binds?/2) (get-current-environment) '$binds?/2)"
         (emt:doc "We know `$binds?/2' should be bound")
         (emt:assert
            (equal answer "#t")))
      (t "((wrap $binds?/2) (make-environment) '$binds?/2)"
         (emt:doc "`make-environment' should bind nothing.")
         (emt:assert
            (equal answer "#f")))
      (t "((wrap $binds?/2) (make-environment) 'unlikely-to-be-bound)"
         (emt:doc "In case the preceding test worked for the wrong \
reason, ie that `make-environment' leaked")
         (emt:assert
            (equal answer "#f")))
      (t "($binds? (get-current-environment) $binds?)"
         (emt:doc "The N-ary version works")
         (emt:assert
            (equal answer "#t")))
      (t "($binds? (make-environment) $binds?)"
         (emt:doc "Discriminates")
         (emt:assert
            (equal answer "#f")))
      (t "($binds? (get-current-environment) list wrap)"
         (emt:doc "Takes more than 1 arg")
         (emt:assert
            (equal answer "#t"))))

   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "($define! a (open-input-file \"test-m1.krn\"))"
         (emt:doc "Open an input port from a known file")
         (emt:assert
            (equal answer "#inert")))
      (t "a"
         (emt:doc "We got a port")
         (emt:assert
            (equal answer "#<PORT>")))
      (t "(get-char a)"
         (emt:doc "Check the first few characters against known values")
         (emt:assert
            (equal answer "#\\;")))
      (t "(get-char a)"
         (emt:assert
            (equal answer "#\\newline")))
      (t "(get-char a)"
         (emt:assert
            (equal answer "#\\;"))))

   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "($binds? (get-current-environment) not-bound-in-ground)"
         (emt:doc "Validate that `not-bound-in-ground' is not already bound")
         (emt:assert
            (equal answer "#f")))
      (t "($define! a (make-kernel-standard-environment))"
         (emt:doc "Create a standard environment")
         (emt:assert
            (equal answer "#inert")))
      (t "($binds? a $binds?)"
         (emt:doc "The ground bindings are available")
         (emt:assert
            (equal answer "#t")))
      (t "($set! a not-bound-in-ground 12)"
         (emt:doc "set `not-bound-in-ground' in a")
         (emt:assert
            (equal answer "#inert")))
      (t "($binds? a not-bound-in-ground)"
         (emt:doc "It's bound in `a'")
         (emt:assert
            (equal answer "#t")))
      (t "(eval 'not-bound-in-ground a)"
         (emt:doc "It has the right value in `a'")
         (emt:assert
            (equal answer "12")))
      (t "($binds? (get-current-environment) not-bound-in-ground)"
         (emt:doc "It's not bound in current environment")
         (emt:assert
            (equal answer "#f")))
      (t "($define! x (get-module \"test-m1.krn\"))"
         (emt:doc "In `x', no parameters are defined")
         (emt:doc (concat "Answer: " answer)))
      (t "($define! y (get-module \"test-m1.krn\"
      ($bindings->environment (baz  \"quux\"))))"
         (emt:doc "In `y', `baz' is defined")
         (emt:doc (concat "Answer: " answer)))
      (t "($define! z (get-module \"test-m1.krn\"
      ($bindings->environment (quux  \"baz\"))))"
         (emt:doc "In `z', quux' is defined")
         (emt:doc (concat "Answer: " answer)))
      (t "(write (($remote-eval foo x)))"
         (emt:doc "Query `x'")
         (emt:assert
            (equal answer "no parameters\n#inert#inert")))
      (t "(write (($remote-eval foo y)))"
         (emt:doc "Query `y'")
         (emt:assert
            (equal answer "parameters, but no quux\n#inert#inert")))
      (t "(write (($remote-eval foo z)))"
         (emt:doc "Query `z'")
         (emt:assert
            (equal answer "parameters\n\"baz\"#inert"))))

   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
      ((x . y)) x) (force low-promise))))) (force p1))"
         (emt:doc "WRITE ME")
         (emt:assert
            (equal answer "1")))
      (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
      ((x . y)) y) (force low-promise))))) (force p1))"
         (emt:doc "WRITE ME")
         (emt:assert
            (equal answer "2"))))

   ;;Automatically forcing promises
   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(car ($lazy '(1)))"
         (emt:doc "Car can force a promise")
         (emt:assert
            (equal answer "1")))
      (t "(car ($lazy '(2 3)))"
         (emt:assert
            (equal answer "2")))
      (t "((wrap $binds?/2) (get-current-environment) '$binds?/2)"
         (emt:doc "Validate that this call works")
         (emt:assert
            (equal answer "#t")))
      (t "((wrap $binds?/2) ($lazy (get-current-environment)) '$binds?/2)"
         (emt:doc "And validate that it works with one arg")
         (emt:assert
            (equal answer "#t")))

      (t "((wrap $binds?/2) ($lazy (get-current-environment)) ($lazy '$binds?/2))"
         (emt:doc "We can force two arguments")
         (emt:assert
            (equal answer "#t")))
      (t "(every?/2-xary integer? '((1) (2)))"
         (emt:doc "Validate that this call works")
         (emt:assert
            (equal answer "#t")))
      (t "(every?/2-xary integer? '((1) (#f)))"
         (emt:doc "False works too")
         (emt:assert
            (equal answer "#f")))
      
      (t "(every?/2-xary ($lazy integer?) '((1) (2)))"
         (emt:doc "Arguments after the forced argument work")
         (emt:assert
            (equal answer "#t")))
      
      (t "(every?/2-xary ($lazy integer?) '((1) (#f)))"
         (emt:assert
            (equal answer "#f")))
      
      (t "(every?/2-xary ($lazy integer?) ($lazy '((1) (2))))"
         (emt:doc "Arguments after the forced argument work")
         (emt:assert
            (equal answer "#t")))
      
      (t "(every?/2-xary ($lazy integer?) ($lazy '((1) (#f))))"
         (emt:assert
            (equal answer "#f"))))


   (expect
      ((exec+args (list debug-klink-executable))
         (shell t)
         (prompt "\nklink> ")
         (timeout 10)
         (append-newline t))
      (t "")
      (t "(profiling 1)"
         (emt:doc "Turn profiling on, and it should not have been on before")
         (emt:assert
            (equal answer "0")))
      (t "(profiling 1)"
         (emt:doc "Now it's on, and this is our first profiled call")
         (emt:assert
            (equal answer "1")))
      (t "(get-profiling-data)"
         (emt:doc "We see the profiling data from just the earlier call")
         (emt:doc "All profiling data may change, we're interested in
      its general behavior and in including the functions we just called")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer
               "dbid:787cceb2-39a0-46c3-97a7-a23a3de3da4b")))
      (t "(profiling 1)"
         (emt:doc "Run this call again")
         (emt:assert
            (equal answer "1")))
      (t "(get-profiling-data)"
         (emt:doc "Now profiling data shows 2 calls to `profiling', 1
      to `get-profiling-data'")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer
               "dbid:26b534dc-b589-4d2c-9026-7c5ea9b8a858")))
      (t "(get-profiling-data)"
         (emt:doc "Again")
         (emt:assert
            (emt:eq-persist-p #'equal 
               answer 
               "dbid:3c018d05-1938-4af6-8ad3-5325b9d16fd6"))))

   )

;;;_ , debug-klink-capture-form
;;;###autoload
(defun debug-klink-capture-form ()
   "Push entries for an `emtr:expect' script onto the kill ring.
Basically `emtr:expect:buffer-capture-form' specialized for klink.

Current buffer should contain a transcript of a klink session."

   
   (interactive)
   (emtr:expect:buffer-capture-form debug-klink-prompt t t))

;;;_. Footers
;;;_ , Provides

(provide 'debug-klink)

;;;_ * Local emacs vars.
;;;_  + Local variables:
;;;_  + mode: allout
;;;_  + End:

;;;_ , End
;;; debug-klink.el ends here