debug-klink.el

   1 ;;;_ debug-klink.el --- Help debugging Klink
   2
   3 ;;;_. Headers
   4 ;;;_ , License
   5 ;; Copyright (C) 2010,2011  Tom Breton (Tehom)
   6
   7 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
   8 ;; Keywords: convenience,tools,local
   9
  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)
  13 ;; any later version.
  14
  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.
  19
  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.
  24
  25 ;;;_ , Commentary:
  26
  27 ;;
  28
  29
  30 ;;;_ , Requires
  31
  32 (require 'emtest/editing/expect nil t)
  33 (require 'emtest/testhelp/standard)
  34 (require 'emtest/testhelp/persist)
  35 (require 'emtest/main/define)
  36
  37 ;;;_. Body
  38 ;;;_ , debug-klink-executable
  39 (defconst debug-klink-executable
  40    (emt:expand-filename-here "klink")
  41    "Absolute path to the klink executable" )
  42 ;;;_ , DB file
  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"
  49
  50    (interactive "sObject: ")
  51    (insert
  52       "p (enum klink_types)_get_type("obj")"))
  53 ;;;_ , debug-klink-read-C-type
  54 (defun debug-klink-read-C-type (prompt)
  55    ""
  56
  57    (completing-read
  58       prompt
  59       '(
  60           "_kt_spagstack"
  61           "_kt_tag"
  62           "kt_boxed_void"
  63           "kt_cfunc"
  64           "kt_curried"
  65           "kt_encap"
  66           "kt_recur_tracker"
  67           "kt_recurrence_table"
  68           "kt_string"
  69           "kt_vec2"
  70           "kt_vector"
  71           "long"
  72           "num"
  73           "port"
  74           )
  75       nil
  76       t))
  77
  78
  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"
  82
  83    (interactive
  84       (list
  85          (read-string "Object: ")
  86          (debug-klink-read-C-type "Type: ")))
  87    (insert
  88       "p *("type" *)(((enum klink_types*)"obj")+1)"))
  89 ;;;_ , debug-klink-send-line
  90 ;;;###autoload
  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"
  94
  95    (interactive "sString: ")
  96    (comint-send-string (get-buffer-process (current-buffer))
  97       (concat
  98          string
  99          "\n")))
 100
 101 ;;;_ , debug-klink-send-end
 102 (defun debug-klink-send-end ()
 103    "Tell gdb the current special input is done"
 104
 105    (interactive)
 106    ;;$$IMPROVE ME  Make sure it's gdb buffer.
 107    (comint-send-string (get-buffer-process (current-buffer)) "end\n"))
 108
 109 ;;;_ , debug-klink-prompt
 110 (defconst debug-klink-prompt "\nklink> "
 111    "Klink's prompt" )
 112 ;;;_ , Test suite
 113 (emt:deftest-3
 114    ((of 'klink)
 115       (db-id `(persist ,debug-klink:th:db)))
 116    (expect
 117       ((exec+args (list debug-klink-executable))
 118          (shell t)
 119          (prompt "\nklink> ")
 120          (timeout 10)
 121          (append-newline t))
 122       ;;Clean out header stuff
 123       (t "")
 124       (t "12"
 125          (emt:doc "Communicating at all")
 126          (emt:assert
 127             (equal answer "12")
 128             t)))
 129
 130    (expect
 131       ((exec+args (list debug-klink-executable))
 132          (shell t)
 133          (prompt "\nklink> ")
 134          (timeout 10)
 135          (append-newline t))
 136       ;;Clean out header stuff
 137       (t "")
 138       (t "(eval 12 (get-current-environment))"
 139          (emt:assert
 140             (equal answer "12")
 141             t))
 142       (t "(eval 12)"
 143          (emt:assert
 144             (equal answer "12")
 145             t))
 146       (t "(eval ''(1 2 3 4)(get-current-environment))"
 147          (emt:doc "Eval in current environment")
 148          (emt:assert
 149             (equal answer "(1 2 3 4)")
 150             t))
 151       (t "(eval ''(1 2 . #(3 4))(get-current-environment))"
 152          (emt:doc "Eval in current environment")
 153          (emt:assert
 154             (equal answer "(1 2 . #( 3 4))")
 155             t))
 156       (t "(eval (get-current-environment)(get-current-environment))"
 157          (emt:doc "Eval in current environment")
 158          (emt:assert
 159             (equal answer
 160                "#<ENVIRONMENT>"
 161                )
 162             t))
 163       (t "(wrap wrap)"
 164          (emt:doc "Wrap behavior")
 165          (emt:assert
 166             (equal answer
 167                "#<APPLICATIVE>"
 168                )
 169             t))
 170       (t "($define! a 12)"
 171          (emt:doc "$define! behavior")
 172          (emt:assert
 173             (equal answer
 174                "#inert"
 175                )
 176             t))
 177       (t "a"
 178          (emt:doc "Result: a is now define 12")
 179          (emt:assert
 180             (equal answer
 181                "12"
 182                )
 183             t))
 184       (t "($define! b (eval ''(1 . #(2 3)) (get-current-environment)))"
 185          (emt:doc "Define b, passing a form")
 186          (emt:assert
 187             (equal answer
 188                "#inert"
 189                )
 190             t))
 191       (t "b"
 192          (emt:doc "Result: b is now defined as what the form evaluated to")
 193          (emt:assert
 194             (equal answer
 195                "(1 . #( 2 3))"
 196                )
 197             t))
 198       (t "($define! (c d e) '(1 2 3))"
 199          (emt:doc "Define c, d, and e")
 200          (emt:assert
 201             (equal answer
 202                "#inert"
 203                )
 204             t))
 205       (t "c"
 206          (emt:doc "c is defined")
 207          (emt:assert
 208             (equal answer
 209                "1"
 210                )
 211             t))
 212       (t "d"
 213          (emt:doc "d is defined")
 214          (emt:assert
 215             (equal answer
 216                "2"
 217                )
 218             t))
 219       (t "e"
 220          (emt:doc "e is defined")
 221          (emt:assert
 222             (equal answer
 223                "3"
 224                )
 225             t))
 226       (t "($set! (get-current-environment) f 14)"
 227          (emt:doc "$set! behavior")
 228          (emt:doc "Operation: set f in the current environment")
 229          (emt:assert
 230             (equal answer
 231                "#inert"
 232                )
 233             t))
 234       (t "f"
 235          (emt:doc "Result: f is now defined")
 236          (emt:assert
 237             (equal answer
 238                "14"
 239                )
 240             t))
 241       (t "($set! (get-current-environment) f 15)"
 242          (emt:doc "Operation: set f to something else")
 243          (emt:assert
 244             (equal answer
 245                "#inert"
 246                )
 247             t))
 248       (t "f"
 249          (emt:doc "Result: f now has the new definition")
 250          (emt:assert
 251             (equal answer
 252                "15"
 253                )
 254             t))
 255       (t "($set! (get-current-environment) (g h) '(16 157))"
 256          (emt:doc "Operation: set g and h")
 257          (emt:assert
 258             (equal answer
 259                "#inert"
 260                )
 261             t))
 262       (t "g"
 263          (emt:doc "Result: g is defined")
 264          (emt:assert
 265             (equal answer
 266                "16"
 267                )
 268             t))
 269       (t "h"
 270          (emt:doc "Result: h is defined")
 271          (emt:assert
 272             (equal answer
 273                "157"
 274                )
 275             t))
 276       (t "($define! i ($vau (a) e (eval a e)))"
 277          (emt:doc "$vau behavior")
 278          (emt:assert
 279             (equal answer
 280                "#inert"
 281                )
 282             t))
 283       (t "(i '(12 14))"
 284          (emt:doc "$vau behavior")
 285          (emt:assert
 286             (equal answer
 287                "(12 14)"
 288                )
 289             t))
 290       (t "(i (i '(12 14)))"
 291          (emt:doc "$vau behavior")
 292          (emt:assert
 293             (equal answer
 294                "(12 14)"
 295                )
 296             t))
 297       (t "(i (car '(12 14)))"
 298          (emt:doc "$vau behavior")
 299          (emt:assert
 300             (equal answer
 301                "12"
 302                )
 303             t))
 304       (t "($define! j ($vau () e 12))"
 305          (emt:doc "$vau behavior")
 306          (emt:assert
 307             (equal answer
 308                "#inert"
 309                )
 310             t))
 311       (t "(j)"
 312          (emt:doc "$vau behavior")
 313          (emt:assert
 314             (equal answer
 315                "12"
 316                )
 317             t))
 318       (t "($define! k ($vau (a) e a))"
 319          (emt:doc "$vau behavior")
 320          (emt:assert
 321             (equal answer
 322                "#inert"
 323                )
 324             t))
 325       (t "(k 12)"
 326          (emt:doc "$vau behavior")
 327          (emt:assert
 328             (equal answer
 329                "12"
 330                )
 331             t))
 332       (t "(k '(1 2))"
 333          (emt:doc "$vau behavior")
 334          (emt:assert
 335             (equal answer
 336                "(#,$quote (1 2))")
 337             t))
 338       (t "($define! l ($vau (a b) e a))"
 339          (emt:doc "$vau behavior")
 340          (emt:assert
 341             (equal answer
 342                "#inert"
 343                )
 344             t))
 345       (t "(l 12 13)"
 346          (emt:doc "$vau behavior")
 347          (emt:assert
 348             (equal answer
 349                "12"
 350                )
 351             t))
 352       (t "($define! (bi ac) (make-keyed-static-variable))"
 353          (emt:doc "Keyed static variables")
 354          (emt:assert
 355             (equal answer
 356                "#inert"
 357                )
 358             t))
 359       (t "ac"
 360          (emt:doc "Keyed static variables")
 361          (emt:assert
 362             (equal answer
 363                "#<APPLICATIVE>"
 364                )
 365             t))
 366       (t "(bi 4 (get-current-environment))"
 367          (emt:doc "Keyed static variables")
 368          (emt:assert
 369             (equal answer
 370                "#<ENVIRONMENT>"
 371                )
 372             t))
 373       (t "(eval '(ac) (bi 4 (get-current-environment)))"
 374          (emt:doc "Keyed static variables")
 375          (emt:assert
 376             (equal answer
 377                "4")
 378             t)))
 379
 380    (expect
 381       ((exec+args (list debug-klink-executable))
 382          (shell t)
 383          (prompt "\nklink> ")
 384          (timeout 10)
 385          (append-newline t))
 386       ;;Clean out header stuff
 387       (t "")
 388       (t "(eq? () ())"
 389          (emt:assert
 390             (equal answer "#t")))
 391       (t "(eq? '() '())"
 392          (emt:assert
 393             (equal answer "#t")))
 394       (t "(eq? ''() ''())"
 395          (emt:doc "Double-quoted nils are not `eq?' because both could \
 396       conceivably be mutated")
 397          (emt:assert
 398             (equal answer "#f")))
 399       (t "(eq? (cdr '(1)) '())"
 400          (emt:doc "nil generated by finding a tail is `eq?' to explicit nil")
 401          (emt:assert
 402             (equal answer "#t"))))
 403
 404    ;;list-tail
 405    (expect
 406       ((exec+args (list debug-klink-executable))
 407          (shell t)
 408          (prompt "\nklink> ")
 409          (timeout 10)
 410          (append-newline t))
 411       ;;Clean out header stuff
 412       (t "")
 413
 414       (t "(list-tail '(0 1 2) 0)"
 415          (emt:doc "Behavior of list-tail")
 416          (emt:assert
 417             (equal answer "(0 1 2)")))
 418       (t "(list-tail '(0 1 2) 1)"
 419        (emt:assert
 420           (equal answer "(1 2)")))
 421       (t "(list-tail '(0 1 2) 2)"
 422          (emt:assert
 423             (equal answer "(2)")))
 424       (t "(list-tail '(0 1 2) 3)"
 425          (emt:assert
 426             (equal answer "()"))))
 427
 428    (expect
 429       ((exec+args (list debug-klink-executable))
 430          (shell t)
 431          (prompt "\nklink> ")
 432          (timeout 10)
 433          (append-newline t))
 434       ;;Clean out header stuff
 435       (t "")
 436       (t "($define! a (list 0 1 2))"
 437          (emt:doc "Make a list object")
 438          (emt:assert
 439             (equal answer "#inert")))
 440       (t "(encycle! a 0 3)"
 441          (emt:doc "Encycle it, no prefix, the whole object")
 442          (emt:assert
 443             (equal answer "#inert")))
 444       (t "a"
 445          (emt:doc "Show the object")
 446          (emt:assert
 447             (equal answer "#0=(0 1 2 #0)")))
 448       (t "($define! a (list 0 1 2))"
 449          (emt:assert
 450             (equal answer "#inert")))
 451       (t "(encycle! a 1 2)"
 452          (emt:doc "Encycle it, the whole list, with prefix")
 453          (emt:assert
 454             (equal answer "#inert")))
 455       (t "a"
 456          (emt:assert
 457             (equal answer "(0 #0=1 2 #0)")))
 458       (t "($define! a (list 0 1 2))"
 459          (emt:assert
 460             (equal answer "#inert")))
 461       (t "(encycle! a 0 2)"
 462          (emt:doc "Encycle it, no prefix, less than the list length")
 463          (emt:assert
 464             (equal answer "#inert")))
 465       (t "a"
 466          (emt:assert
 467             (equal answer "#0=(0 1 #0)")))
 468       (t "($define! a (list 0 1 2))"
 469          (emt:assert
 470             (equal answer "#inert")))
 471       (t "(encycle! a 1 1)"
 472          (emt:doc "Encycle it, less than the list length")
 473          (emt:assert
 474             (equal answer "#inert")))
 475       (t "a"
 476          (emt:assert
 477             (equal answer "(0 #0=1 #0)"))))
 478
 479
 480    ;;apply
 481    (expect
 482       ((exec+args (list debug-klink-executable))
 483          (shell t)
 484          (prompt "\nklink> ")
 485          (timeout 10)
 486          (append-newline t))
 487       ;;Clean out header stuff
 488       (t "")
 489       (t "apply"
 490          (emt:doc "`apply' is recognized")
 491          (emt:assert
 492             (equal answer "#,apply")))
 493       (t "(apply list '(1 2 3) (get-current-environment))"
 494          (emt:doc "Apply works on list argument")
 495          (emt:assert
 496             (equal answer "(1 2 3)")))
 497       (t "(apply list '(1 2 3))"
 498          (emt:doc "Apply with default env works on list argument,
 499       evals each number")
 500          (emt:assert
 501             (equal answer "(1 2 3)")))
 502       (t "(apply list '(a 2 3))"
 503          (emt:doc "Apply doesn't re-eval args, so this works even \
 504 though the symbol `a' is unbound in the empty environment.")
 505          (emt:assert
 506             (equal answer "(a 2 3)")))
 507       (t "(apply list ''(1 2 3))"
 508          (emt:doc "Double-quoted gets single-quoted")
 509          (emt:assert
 510             (equal answer "(#,$quote (1 2 3))")))
 511
 512       (t "(apply list '''(1 2 3))"
 513          (emt:doc "Triple-quoted gets double-quoted")
 514          (emt:assert
 515             (equal answer "(#,$quote (#,$quote (1 2 3)))")))
 516
 517       (t "(apply (wrap list) '(list) (get-current-environment))"
 518          (emt:doc "In normal environment, we see bindings such as `list'")
 519          (emt:assert
 520             (equal answer "(#,list)")))
 521       (t "(apply (wrap list) '(list) (make-environment))"
 522          (emt:doc "In blank environment, we see no bindings")
 523          (emt:assert
 524             (equal answer "Error: eval: unbound variable: list \n")))
 525       (t "(apply (wrap $sequence) '(list) (get-current-environment))"
 526          (emt:doc "In normal environment, we see bindings such as `list'")
 527          (emt:assert
 528             (equal answer "#,list")))
 529       (t "(apply (wrap $sequence) '(list) (make-environment))"
 530          (emt:doc "In blank environment, we see no bindings")
 531          (emt:assert
 532             (equal answer "Error: eval: unbound variable: list \n"))))
 533
 534    ;;predicates
 535    (expect
 536       ((exec+args (list debug-klink-executable))
 537          (shell t)
 538          (prompt "\nklink> ")
 539          (timeout 10)
 540          (append-newline t))
 541       ;;Clean out header stuff
 542       (t "")
 543       (t "(integer? 1)"
 544          (emt:doc "Predicate integer?")
 545          (emt:assert
 546             (equal answer
 547                "#t")
 548             t))
 549       (t "(integer? 'a)"
 550          (emt:doc "Predicate integer?")
 551          (emt:assert
 552             (equal answer
 553                "#f")
 554             t)))
 555    ;;null?
 556    (expect
 557       ((exec+args (list debug-klink-executable))
 558          (shell t)
 559          (prompt "\nklink> ")
 560          (timeout 10)
 561          (append-newline t))
 562       ;;Clean out header stuff
 563       (t "")
 564       (t "null?"
 565          (emt:doc "null? is recognized")
 566          (emt:assert
 567             (equal answer "#,null?")))
 568       ;;Must eval, which right now we don't.
 569       (t "(null? '())"
 570          (emt:assert
 571             (equal answer "#t")))
 572       (t "(null? 13)"
 573          (emt:assert
 574             (equal answer "#f"))))
 575
 576    ;;make-encapsulation-type
 577    (expect
 578       ((exec+args (list debug-klink-executable))
 579          (shell t)
 580          (prompt "\nklink> ")
 581          (timeout 10)
 582          (append-newline t))
 583       ;;Clean out header stuff
 584       (t "")
 585       (t "($define! (e p? d) (make-encapsulation-type))"
 586          (emt:doc "Make an encapsulation type")
 587          (emt:assert
 588             (equal answer "#inert")))
 589       (t "($define! a (e 12))"
 590          (emt:doc "Make an instance of it")
 591          (emt:assert
 592             (equal answer "#inert")))
 593       (t "(p? a)"
 594          (emt:doc "The predicate returns true on the instance")
 595          (emt:assert
 596             (equal answer "#t")))
 597       (t "(p? 12)"
 598          (emt:assert
 599             (equal answer "#f")))
 600       (t "(p? a a)"
 601          (emt:assert
 602             (equal answer "#t")))
 603       (t "(p? a #f a)"
 604          (emt:assert
 605             (equal answer "#f")))
 606       (t "(d a)"
 607          (emt:doc "`d' retrieves the value")
 608          (emt:assert
 609             (equal answer "12"))))
 610
 611    ;;$if
 612    (expect
 613       ((exec+args (list debug-klink-executable))
 614          (shell t)
 615          (prompt "\nklink> ")
 616          (timeout 10)
 617          (append-newline t))
 618       ;;Clean out header stuff
 619       (t "")
 620       (t "$if"
 621          (emt:doc "$if is recognized")
 622          (emt:assert
 623             (equal answer "#,$if")))
 624       (t "($if #t '1 '2)"
 625          (emt:doc "On true, evaluates the CONSEQUENT argument")
 626          (emt:assert
 627             (equal answer "1")))
 628       (t "($if #f '1 '2)"
 629          (emt:doc "On false, evaluates the ALTERNATIVE argument")
 630          (emt:assert
 631             (equal answer "2")))
 632       (t "($if 3 1 2)"
 633          (emt:doc "On non-boolean test, raises error")
 634          (emt:assert
 635             (emt:eq-persist-p
 636                #'equal answer
 637                "dbid:80eedbc8-efd5-47c4-9c3b-d0da6c48f768")))
 638       (t "($if '#t '1 '2)"
 639          (emt:doc "On evaluated true, evaluates the CONSEQUENT argument")
 640          (emt:assert
 641             (equal answer "1")))
 642       (t "($if '#f '1 '2)"
 643          (emt:doc "On evaluated false, evaluates the ALTERNATIVE argument")
 644          (emt:assert
 645             (equal answer "2"))))
 646    ;;$cond
 647    (expect
 648       ((exec+args (list debug-klink-executable))
 649          (shell t)
 650          (prompt "\nklink> ")
 651          (timeout 10)
 652          (append-newline t))
 653       ;;Clean out header stuff
 654       (t "")
 655       (t "($cond (#t 12)(#f 13))"
 656          (emt:doc "The first true claus is evalled")
 657          (emt:assert
 658             (equal answer "12")))
 659       (t "($cond (#f 13)(#t 12))"
 660          (emt:doc "False clauses are skipped")
 661          (emt:assert
 662             (equal answer "12")))
 663       (t "($cond ((integer? 'a) 13)(#t 12))"
 664          (emt:doc "Guard clauses are evalled")
 665          (emt:assert
 666             (equal answer "12")))
 667       (t "($cond ((integer? 'a) 13)((integer? 1) 12))"
 668          (emt:doc "Guard clauses are evalled")
 669          (emt:assert
 670             (equal answer "12")))
 671       (t "($let ((x 5)) ($cond (#t (list 1 2))))"
 672          (emt:doc "The selected clause body is evalled")
 673          (emt:assert
 674             (equal answer "(1 2)")))
 675       (t "($cond)"
 676          (emt:doc "$cond with no clauses gives #inert")
 677          (emt:assert
 678             (equal answer "#inert")))
 679       (t "($let ((x 5))
 680     ($cond ((integer? x)
 681                    (display \"x=\")
 682                    (display x)
 683                    (newline))))"
 684          (emt:doc "Variables are accessible inside clauses")
 685          (emt:assert
 686             (equal answer "x=5\n#inert"))))
 687
 688
 689
 690
 691    ;;$sequence
 692    (expect
 693       ((exec+args (list debug-klink-executable))
 694          (shell t)
 695          (prompt "\nklink> ")
 696          (timeout 10)
 697          (append-newline t))
 698       ;;Clean out header stuff
 699       (t "")
 700       (t "($sequence)"
 701          (emt:doc "$sequence with no args gives inert")
 702          (emt:assert
 703             (equal answer "#inert")))
 704       (t "($sequence '1)"
 705          (emt:doc "Sequence evaluates its args")
 706          (emt:assert
 707             (equal answer "1")))
 708       (t "($sequence '1 '2)"
 709          (emt:doc "Sequence returns the value of the last element")
 710          (emt:assert
 711             (equal answer "2")))
 712       (t "($define! my-lam ($lambda v (write v)(newline)))"
 713          (emt:doc "Define a lambda having a sequence"))
 714       (t "(my-lam 12)"
 715          (emt:doc "That lambda evals all the sequence")
 716          (emt:assert
 717             (equal answer "(12)\n#inert"))))
 718
 719
 720    ;;write and display
 721    (expect
 722       ((exec+args (list debug-klink-executable))
 723          (shell t)
 724          (prompt "\nklink> ")
 725          (timeout 10)
 726          (append-newline t))
 727       ;;Clean out header stuff
 728       (t "")
 729       (t "($sequence (write \"abc\") (newline))"
 730        (emt:doc "`write' displays objects escaped for read-back")
 731        (emt:assert
 732           (equal answer "\"abc\"\n#inert")))
 733       (t "($sequence (display \"abc\") (newline))"
 734          (emt:doc "`display' displays objects unescaped")
 735          (emt:assert
 736             (equal answer "abc\n#inert")))
 737       (t "($sequence (display '(1 2 3)) (newline))"
 738          (emt:doc "`display' can display full objects")
 739          (emt:assert
 740             (equal answer "(1 2 3)\n#inert")))
 741       (t "($sequence (write '(1 2 3)) (newline))"
 742          (emt:doc "`write' can display full objects")
 743          (emt:assert
 744             (equal answer "(1 2 3)\n#inert"))))
 745
 746    (expect
 747       ((exec+args (list debug-klink-executable))
 748          (shell t)
 749          (prompt "\nklink> ")
 750          (timeout 10)
 751          (append-newline t))
 752       ;;Clean out header stuff
 753       (t "")
 754       (t "(read)\n12"
 755          (emt:doc "Reads numbers")
 756          (emt:assert
 757             (equal answer "12")))
 758       (t "(read)\nsym"
 759          (emt:doc "Reads symbols")
 760          (emt:assert
 761             (equal answer "sym")))
 762       (t "(read)\n(1 2 3)"
 763          (emt:doc "Reads lists, no problem with nesting depth.")
 764          (emt:assert
 765             (equal answer "(1 2 3)"))))
 766
 767
 768    ;;On typechecking
 769    (expect
 770       ((exec+args (list debug-klink-executable))
 771          (shell t)
 772          (prompt "\nklink> ")
 773          (timeout 10)
 774          (append-newline t))
 775       ;;Clean out header stuff
 776       (t "")
 777       (t "true/o1"
 778          (emt:doc "true/o1 predicate is recognized")
 779          (emt:assert
 780             (equal answer "#,true/o1")
 781             t))
 782
 783       (t "(true/o1 1)"
 784          (emt:doc "true/o1 predicate gives #t")
 785          (emt:assert
 786             (equal answer "#t")
 787             t))
 788       (t "type?"
 789          (emt:doc "`type?' is recognized")
 790          (emt:assert
 791             (equal answer "#,type?")
 792             t))
 793
 794       (t "(type? 1 true/o1)"
 795          (emt:doc "`type?' can be called")
 796          (emt:assert
 797             (equal answer "#t")
 798             t))
 799       (t "listtype"
 800          (emt:doc "`listtype' ctor is recognized")
 801          (emt:assert
 802             (equal answer "#,listtype")
 803             t))
 804       (t "(listtype true/o1)"
 805          (emt:doc "`listtype' makes an operative")
 806          (emt:assert
 807             (equal answer "#<OPERATIVE>")
 808             t))
 809       (t "(listtype true/o1 true/o1)"
 810          (emt:doc "`listtype' takes a list of args")
 811          (emt:assert
 812             (equal answer "#<OPERATIVE>")
 813             t))
 814       (t "(type? 1 (listtype true/o1))"
 815          (emt:doc "`listtype' makes one that expects a list")
 816          (emt:assert
 817             (equal answer "#f")
 818             t))
 819       (t "(type? '(1) (listtype integer?))"
 820          (emt:doc "Second-level listtypes work OK")
 821          (emt:assert
 822             (equal answer "#t")
 823             t))
 824       (t "(type? '(#t) (listtype integer?))"
 825          (emt:doc "Second-level listtype discriminate (non)match")
 826          (emt:assert
 827             (equal answer "#f")
 828             t))
 829       (t "(type? '(1) (listtype true/o1 true/o1))"
 830          (emt:doc "Situation: Too few elements")
 831          (emt:doc "Result: false")
 832          (emt:assert
 833             (equal answer "#f")
 834             t))
 835       (t "(type? '(1) (listtype))"
 836          (emt:doc "Situation: Objects has too many elements")
 837          (emt:doc "Result: false")
 838          (emt:assert
 839             (equal answer "#f")
 840             t))
 841       (t "(type? '(1) (listtype true/o1 'optional true/o1))"
 842          (emt:doc "Situation: Optional elements")
 843          (emt:doc "Result: true")
 844          (emt:assert
 845             (equal answer "#t")
 846             t))
 847       (t "(type? '(1 2 3) (listtype true/o1 'optional true/o1))"
 848          (emt:doc "Situation: Number of items outruns number of optional elements")
 849          (emt:doc "Result: false")
 850          (emt:assert
 851             (equal answer "#f")
 852             t))
 853       (t "(type? '(1) (listtype true/o1 'optional 'optional))"
 854          (emt:doc "Situation: Two optional keys given")
 855          (emt:doc "Result: error")
 856          (emt:assert
 857             (emt:eq-persist-p
 858                #'equal
 859                answer
 860                "dbid:e144f830-d6a5-4240-94f0-b0b8a9890d42")))
 861       (t "(type? '(1) (listtype true/o1 'DOT))"
 862          (emt:doc "Situation: Dot spec has no spec after it")
 863          (emt:doc "Result: error")
 864          (emt:assert
 865             (emt:eq-persist-p #'equal
 866                answer
 867                "dbid:37a39a99-8b11-4d6f-9e31-033af8d73d41")))
 868       (t "(type? '(1) (listtype true/o1 'DOT true/o1 true/o1))"
 869          (emt:doc "Situation: Dot spec has more than 1 spec after it")
 870          (emt:doc "Result: error")
 871          (emt:assert
 872             (emt:eq-persist-p #'equal
 873                answer
 874                "dbid:7f057673-3b94-4e4c-a25c-b09ed5239af2")))
 875       (t "(type? '(1 2 3) (listtype true/o1 'DOT true/o1))"
 876          (emt:doc "Situation: Dot spec is satisfied")
 877          (emt:doc "Result: true")
 878          (emt:assert
 879             (equal answer "#t")
 880             t))
 881       (t "(type? '(1 2 3) (listtype true/o1 'DOT integer?))"
 882          (emt:doc "Situation: Dot spec is reached but doesn't match")
 883          (emt:doc "Result: false")
 884          (emt:assert
 885             (equal answer "#f")
 886             t))
 887       (t "(type? '(1 2 3) (listtype true/o1 'REPEAT integer?))"
 888          (emt:doc "Situation: Repeat spec is used and matches")
 889          (emt:doc "Result: true")
 890          (emt:assert
 891             (equal answer "#t")
 892             t))
 893       (t "(type? '(1 2 #t) (listtype true/o1 'REPEAT integer?))"
 894          (emt:doc "Situation: Repeat spec is used but doesn't match")
 895          (emt:doc "Result: false")
 896          (emt:assert
 897             (equal answer "#f")
 898             t))
 899       (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT integer? true/o1))"
 900          (emt:doc "Situation: Repeat spec is used, has 2 items, matches")
 901          (emt:doc "Result: true")
 902          (emt:assert
 903             (equal answer "#t")
 904             t))
 905       (t "(type? '(1 2 #t 4 #t) (listtype true/o1 'REPEAT true/o1 integer?))"
 906          (emt:doc "Situation: Repeat spec is used, has 2 items, but doesn't match")
 907          (emt:doc "Result: false")
 908          (emt:assert
 909             (equal answer "#f")
 910             t))
 911       (t "(type? '(1) (listtype true/o1 'REPEAT integer?))"
 912          (emt:doc "Situation: Repeat spec is used, zero items available")
 913          (emt:doc "Result: true")
 914          (emt:assert
 915             (equal answer "#t")
 916             t))
 917       ;; $$IMPROVE ME Test circularity, use encycle!
 918       )
 919
 920    ;;On destructuring
 921    (expect
 922       ((exec+args (list debug-klink-executable))
 923          (shell t)
 924          (prompt "\nklink> ")
 925          (timeout 10)
 926          (append-newline t))
 927       ;;Clean out header stuff
 928       (t "")
 929
 930       (t "destructure-list"
 931          (emt:doc "Test `destructure-list'")
 932          (emt:doc "ctor is recognized")
 933          (emt:assert
 934             (equal answer "#,destructure-list")
 935             t))
 936       (t "(destructure-list true/o1)"
 937          (emt:doc "It makes an operative")
 938          (emt:assert
 939             (equal answer "#<OPERATIVE>")
 940             t))
 941       (t "(destructure-list true/o1 true/o1)"
 942          (emt:doc "It takes a list of args")
 943          (emt:assert
 944             (equal answer "#<OPERATIVE>")
 945             t))
 946       (t "(do-destructure 1 (destructure-list true/o1))"
 947          (emt:doc "It makes one that expects a list")
 948          (emt:doc "Result: Error")
 949          (emt:assert
 950             (emt:eq-persist-p #'equal
 951                answer
 952                "dbid:3e113873-73a0-46f5-8e14-f41034780317")))
 953       (t "(do-destructure '(1) (destructure-list integer?))"
 954          (emt:doc "Second-level destructures work OK")
 955          (emt:assert
 956             (equal answer "#( 1)")
 957             t))
 958       (t "(do-destructure '(#t) (destructure-list integer?))"
 959          (emt:doc "Second-level destructure discriminate (non)match")
 960          (emt:doc "Result: Error")
 961          (emt:assert
 962             (emt:eq-persist-p #'equal
 963                answer
 964                "dbid:dc2648ef-22cb-41c2-8f9b-67548b0a3b7a")))
 965       (t "(do-destructure '(1) (destructure-list true/o1 true/o1))"
 966          (emt:doc "Situation: Too few elements")
 967          (emt:doc "Result: Error")
 968          (emt:assert
 969             (emt:eq-persist-p
 970                #'equal
 971                answer
 972                "dbid:b50e8f78-6652-418d-9b44-1ff676946970")))
 973       (t "(do-destructure '(1) (destructure-list))"
 974          (emt:doc "Situation: Objects has too many elements")
 975          (emt:doc "Result: Error")
 976          (emt:assert
 977             (emt:eq-persist-p
 978                #'equal
 979                answer
 980                "dbid:ee168f5d-5d87-4792-9dba-0fd0ac7c14a4")))
 981
 982       (t "(do-destructure '(1) (destructure-list true/o1 'optional true/o1))"
 983          (emt:doc "Situation: Optional elements")
 984          (emt:doc "Result: true")
 985          (emt:assert
 986             (equal answer "#( 1 #inert)")
 987             t))
 988
 989       (t "(do-destructure '(1 2 3) (destructure-list true/o1 'optional true/o1))"
 990          (emt:doc "Situation: Number of items outruns number of optional elements")
 991          (emt:doc "Result: Error")
 992          (emt:assert
 993             (emt:eq-persist-p #'equal answer
 994                "dbid:a1bd1321-532e-4187-af64-278c009a7f97")))
 995
 996       (t "(do-destructure '(1) (destructure-list true/o1 'optional 'optional))"
 997          (emt:doc "Situation: Two optional keys given")
 998          (emt:doc "Result: Error")
 999          (emt:assert
1000             (emt:eq-persist-p
1001                #'equal
1002                answer
1003                "dbid:ece901d5-4ac0-496e-a9e2-83423a933522")))
1004
1005       (t "(do-destructure '(1) (destructure-list true/o1 'dot))"
1006          (emt:doc "Situation: Dot spec has no spec after it")
1007          (emt:doc "Result: Error")
1008          (emt:assert
1009             (emt:eq-persist-p #'equal
1010                answer
1011                "dbid:8e8711ba-bada-4223-a212-3256d6a2e497")))
1012
1013       (t "(do-destructure '(1) (destructure-list true/o1 'dot true/o1 true/o1))"
1014          (emt:doc "Situation: Dot spec has more than 1 spec after it")
1015          (emt:doc "Result: Error")
1016          (emt:assert
1017             (emt:eq-persist-p #'equal
1018                answer
1019                "dbid:4d68ceb6-f450-4218-b222-c10019a39819")))
1020
1021       (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot true/o1))"
1022          (emt:doc "Situation: Dot spec is satisfied")
1023          (emt:doc "Result: true")
1024          (emt:assert
1025             (equal answer "#( 1 (2 3))")
1026             t))
1027
1028       (t "(do-destructure '(1 2 3) (destructure-list true/o1 'dot integer?))"
1029          (emt:doc "Situation: Dot spec is reached but doesn't match")
1030          (emt:doc "Result: Error")
1031          (emt:assert
1032             (emt:eq-persist-p #'equal answer
1033                "dbid:266cbd1e-734c-4a81-bac6-e9d9a3424e79"))))
1034
1035    ;;On where-typemiss
1036    (expect
1037       ((exec+args (list debug-klink-executable))
1038          (shell t)
1039          (prompt "\nklink> ")
1040          (timeout 10)
1041          (append-newline t))
1042       ;;Clean out header stuff
1043       (t "")
1044
1045       (t "(where-typemiss 1 (listtype true/o1))"
1046          (emt:doc "`listtype' makes one that expects a list")
1047          (emt:assert
1048             (equal answer "(0 too-few)")
1049             t))
1050       (t "(where-typemiss '(#t) (listtype integer?))"
1051          (emt:doc "Second-level listtype discriminate (non)match")
1052          ;;Use persist because the form of the printout changes.
1053          (emt:assert
1054             (emt:eq-persist-p #'equal answer
1055                "dbid:cc211ae0-718b-4462-9062-7f0077cdf162")))
1056       (t "(where-typemiss '(1) (listtype true/o1 true/o1))"
1057          (emt:doc "Situation: Too few elements")
1058          (emt:assert
1059             (equal answer "(1 too-few)")
1060             t))
1061       (t "(where-typemiss '(1) (listtype))"
1062          (emt:doc "Situation: Objects has too many elements")
1063          (emt:assert
1064             (equal answer "(0 too-many)")
1065             t))
1066       (t "(where-typemiss '(1 2 3) (listtype true/o1 'optional true/o1))"
1067          (emt:doc "Situation: Number of items outruns number of optional elements")
1068          (emt:assert
1069             (equal answer "(2 too-many)")
1070             t))
1071       (t "(where-typemiss '(1 2 3) (listtype true/o1 'dot integer?))"
1072          (emt:doc "Situation: Dot spec is reached but doesn't match")
1073          (emt:assert
1074             (emt:eq-persist-p #'equal answer
1075                "dbid:2f83b114-6bdf-4c7d-9a76-0d3e8b43483c")))
1076       (t "(where-typemiss '(1 2 #t) (listtype true/o1 'repeat integer?))"
1077          (emt:doc "Situation: Repeat spec is used but doesn't match")
1078          (emt:assert
1079             (emt:eq-persist-p #'equal answer
1080                "dbid:f90a1f49-9180-4817-8095-6422ee058745")))
1081       (t "(where-typemiss '(1 2 #t 4 #t) (listtype true/o1 'repeat true/o1 integer?))"
1082          (emt:doc "Situation: Repeat spec is used, has 2 items, but doesn't match")
1083          (emt:assert
1084             (emt:eq-persist-p #'equal answer
1085                "dbid:374c6ab3-7907-4ff5-b14d-e41584593296")))
1086       ;; $$IMPROVE ME Test circularity, use encycle!
1087
1088       )
1089    ;;On get-list-metrics
1090    (expect
1091       ((exec+args (list debug-klink-executable))
1092          (shell t)
1093          (prompt "\nklink> ")
1094          (timeout 10)
1095          (append-newline t))
1096       ;;Clean out header stuff
1097       (t "")
1098       (t "(length '(0 1))"
1099          (emt:assert
1100             (equal answer "2")))
1101       (t "(finite-list? '(0 1))"
1102          (emt:assert
1103             (equal answer "#t")))
1104       (t "(finite-list? #f)"
1105          (emt:assert
1106             (equal answer "#f")))
1107       (t "(get-list-metrics '(0 1))"
1108          (emt:assert
1109             (equal answer "(2 1 2 0)")))
1110       (t "(get-list-metrics #f)"
1111          (emt:assert
1112             (equal answer "(0 0 0 0)")))
1113       (t "(get-list-metrics '(0 . 1))"
1114          (emt:assert
1115             (equal answer "(1 0 1 0)")))
1116       (t "($define! a (list 12))"
1117          (emt:doc "Make a circular object"))
1118       (t "(set-cdr! a a)")
1119       (t "(get-list-metrics a)"
1120          (emt:doc "List metrics of a circular object")
1121          (emt:assert
1122             (equal answer "(1 0 0 1)")))
1123
1124
1125       )
1126
1127    ;;On making environment
1128    (expect
1129       ((exec+args (list debug-klink-executable))
1130          (shell t)
1131          (prompt "\nklink> ")
1132          (timeout 10)
1133          (append-newline t))
1134       ;;Clean out header stuff
1135       (t "")
1136       (t "(make-environment (get-current-environment))"
1137          (emt:doc "Can make an environment")
1138          (emt:assert
1139             (equal answer "#<ENVIRONMENT>")))
1140       (t "(make-environment)"
1141          (emt:doc "Can make an empty environment")
1142          (emt:assert
1143             (equal answer "#<ENVIRONMENT>")))
1144
1145       (t "(eval 'make-environment (make-environment))"
1146          (emt:doc "Empty environment does not bind things")
1147          (emt:assert
1148             (emt:eq-persist-p
1149                #'equal answer "dbid:930c9cb4-c8e3-446a-9d0f-80a7a01edf2e")))
1150
1151       (t "($define! env1 (make-environment))"
1152          (emt:doc "Define example environments")
1153          (emt:assert
1154             (equal answer "#inert")))
1155       (t "($define! env2 (make-environment))"
1156          (emt:assert
1157             (equal answer "#inert")))
1158       (t "($set! env1 a 12)"
1159          (emt:doc "Define things in those example environments")
1160          (emt:assert
1161             (equal answer "#inert")))
1162       (t "($set! env2 b 144)"
1163          (emt:assert
1164             (equal answer "#inert")))
1165       (t "(eval 'a env1)"
1166          (emt:doc "The respective bindings are available in the environments")
1167          (emt:assert
1168             (equal answer "12")))
1169       (t "(eval 'b env2)"
1170          (emt:assert
1171             (equal answer "144")))
1172       (t "($define! env1+2 (make-environment env1 env2))"
1173          (emt:doc "Can make an environment from multiple parents")
1174          (emt:assert
1175             (equal answer "#inert")))
1176       (t "(eval 'a env1+2)"
1177          (emt:doc "It contains the bindings of both environments")
1178          (emt:assert
1179             (equal answer "12")))
1180       (t "(eval 'b env1+2)"
1181          (emt:assert
1182             (equal answer "144"))))
1183
1184    (expect
1185       ((exec+args (list debug-klink-executable))
1186          (shell t)
1187          (prompt "\nklink> ")
1188          (timeout 10)
1189          (append-newline t))
1190       (t "")
1191       (t "(reverse-lookup get-current-environment (get-current-environment))"
1192          (emt:doc "Operation: look up an object we know is bound")
1193          (emt:doc "Result: We find it")
1194          (emt:assert
1195             (equal answer "get-current-environment")))
1196       (t "(reverse-lookup reverse-lookup (get-current-environment))"
1197          (emt:doc "Same on another object")
1198          (emt:assert
1199             (equal answer "reverse-lookup")))
1200       (t "(reverse-lookup 'example-unsymboled-object (get-current-environment))"
1201          (emt:doc "Operation: look up an object we know is not bound")
1202          (emt:doc "Result: Error")
1203          (emt:assert
1204             (emt:eq-persist-p #'equal answer
1205                "dbid:c3ec8dcc-39b2-4885-b4f3-f6e5f018c11e")))
1206       (t "($define! a (list))"
1207          (emt:doc "Make an object we will look for"))
1208       (t "($define! my-env (make-environment))")
1209       (t "($set! my-env b a)"
1210          (emt:doc "In my-env, define b as that object"))
1211       (t "($set! my-env b 13)"
1212          (emt:doc "Now define b as something else"))
1213       (t "(reverse-lookup a my-env)"
1214          (emt:doc "Look up the original object")
1215          (emt:assert
1216             (emt:eq-persist-p
1217                #'equal answer
1218                "dbid:673c63c9-1844-4c7f-b67d-22c6ef88fc66")))
1219       (t "($define! my-env2 (make-environment))"
1220          (emt:doc "Make another empty environment"))
1221       (t "($set! my-env2 c a)"
1222          (emt:doc "In my-env2, define c as that object"))
1223       (t "($set! my-env2 b a)"
1224          (emt:doc "In my-env2, define b as that object"))
1225       (t "($set! my-env2 b 13)"
1226          (emt:doc "Now define b as something else"))
1227       (t "(reverse-lookup a my-env2)"
1228          (emt:doc "Operation: Look up the original object")
1229          (emt:doc "Result: We find its binding, c")
1230          (emt:assert
1231             (equal answer "c")))
1232       (t "($set! my-env2 b a)"
1233          (emt:doc "Define b as that object again"))
1234       (t "($define! my-env3 (make-environment my-env2))"
1235          (emt:doc "Make an environment derived from my-env2"))
1236       (t "($set! my-env3 b 13)"
1237          (emt:doc "There set b to be something else"))
1238       (t "(reverse-lookup a my-env3)"
1239          (emt:doc "Operation: Look up the original object")
1240          (emt:doc "Result: We find its binding")
1241          (emt:assert
1242             (equal answer "c"))))
1243
1244    ;;On printing, esp circular objects
1245    (expect
1246       ((exec+args (list debug-klink-executable))
1247          (shell t)
1248          (prompt "\nklink> ")
1249          (timeout 10)
1250          (append-newline t))
1251
1252       (t "")
1253       (t "print-lookup-env"
1254          (emt:assert
1255             (equal answer "#,print-lookup-env"))
1256          )
1257       (t "(list 1 2)"
1258          (emt:doc "Lists print OK")
1259          (emt:assert
1260             (equal answer "(1 2)")))
1261       (t "wrap"
1262          (emt:doc "Bound objects print a lowquote and their binding")
1263          (emt:assert
1264             (equal answer "#,wrap")))
1265       (t "list"
1266          (emt:assert
1267             (equal answer "#,list")))
1268       (t "(list list)"
1269          (emt:doc "These objects are actual working combiners.")
1270          (emt:assert
1271             (equal answer "(#,list)")))
1272
1273       )
1274
1275    ;;On get-recurrences
1276    (expect
1277       ((exec+args (list debug-klink-executable))
1278          (shell t)
1279          (prompt "\nklink> ")
1280          (timeout 10)
1281          (append-newline t))
1282
1283       (t "")
1284       (t "($define! cycles-nil (get-recurrences '()))"
1285          (emt:doc "`cycles-nil' is the recurrences of object '()"))
1286       (t "(recurrence-table? cycles-nil)"
1287          (emt:assert
1288             (equal answer "#t")))
1289       ;; $$RECONSIDER ME
1290       (t "(recurrences-get-object-count cycles-nil '())"
1291          (emt:doc "Nils are not counted")
1292          (emt:assert
1293             (equal answer "0")))
1294       (t "($define! cycles-list (get-recurrences (list 12 144)))"
1295          (emt:doc "`cycles-list' is the recurrences of an ordinary list"))
1296       (t "(recurrence-table? cycles-list)"
1297          (emt:assert
1298             (equal answer "#t")))
1299       (t "($define! cycles-many-nils (get-recurrences '()))"
1300          (emt:doc "`cycles-many-nils' is the recurrences of object of
1301       multiple nils"))
1302       (t "(recurrence-table? cycles-many-nils)"
1303          (emt:assert
1304             (equal answer "#t")))
1305       (t "(recurrences-get-object-count cycles-many-nils '())"
1306          (emt:doc "Nils do not constitute shared objects")
1307          (emt:assert
1308             (equal answer "0")))
1309       (t "($define! cycles-f (get-recurrences '(#f #f)))"
1310          (emt:doc "Get the recurrences of any object with repeated objects"))
1311       (t "(recurrence-table? cycles-f)"
1312          (emt:assert
1313             (equal answer "#t")))
1314       (t "(recurrences-get-object-count cycles-f #f)"
1315          (emt:assert
1316             (equal answer "2")))
1317       (t "($define! a (list 12))"
1318           (emt:doc "Define a circular object"))
1319       (t "(set-cdr! a a)")
1320       (t "($define! cycles-a (get-recurrences a))")
1321       (t "(recurrence-table? cycles-a)"
1322          (emt:assert
1323             (equal answer "#t")))
1324       (t "(recurrences-get-object-count cycles-a a)"
1325           (emt:assert
1326              (equal answer "2"))))
1327
1328    ;;On lists and wrapping
1329    (expect
1330       ((exec+args (list debug-klink-executable))
1331          (shell t)
1332          (prompt "\nklink> ")
1333          (timeout 10)
1334          (append-newline t))
1335       (t "")
1336       (t "(list 1 2)"
1337          (emt:doc "List works")
1338          (emt:assert
1339             (equal answer "(1 2)")))
1340       (t "(reverse (list 1 2))"
1341          (emt:doc "Reverse works")
1342          (emt:assert
1343             (equal answer "(2 1)")))
1344       (t "((wrap list) 1 2)"
1345          (emt:doc "Wrap wrapped over an applicative works (wrap^2)")
1346          (emt:assert
1347             (equal answer "(1 2)")))
1348       (t "((wrap list) '1 '2)"
1349          (emt:doc "Wrap^2 eliminates at least one level of quoting")
1350          (emt:assert
1351             (equal answer "(1 2)")))
1352       (t "((wrap list) ''1 ''2)"
1353          (emt:doc "Wrap^2 eliminates two levels of quoting")
1354          (emt:assert
1355             (equal answer "(1 2)")))
1356       (t "((wrap list) '''1 '''2)"
1357          (emt:doc "Wrap^2 leaves one of three levels of quoting")
1358          (emt:assert
1359             (equal answer "((#,$quote 1) (#,$quote 2))")))
1360       (t "((wrap (wrap list)) '''1 '''2)"
1361          (emt:doc "Wrap^3 eliminates three levels of quoting")
1362          (emt:assert
1363             (equal answer "(1 2)"))))
1364
1365    ;;On map, map1, counted-map/4
1366    (expect
1367       ((exec+args (list debug-klink-executable))
1368          (shell t)
1369          (prompt "\nklink> ")
1370          (timeout 10)
1371          (append-newline t))
1372       (t "")
1373       (t "(map1 list '(1 2 3))"
1374          (emt:doc "It works")
1375          (emt:assert
1376             (equal answer "((1) (2) (3))")))
1377       (t "(map1 (unwrap list) '(1 2 3))"
1378          (emt:doc "It wants an applicative argument")
1379          (emt:assert
1380             (emt:eq-persist-p #'equal
1381                answer
1382                "dbid:bf93cc1e-534c-4a1f-8762-3072e59dcb3c")))
1383       (t "(counted-map/4 2 1 list '((1 2)))"
1384          (emt:doc "Generally behaves like `map'")
1385          (emt:assert
1386             (equal answer "((1) (2))")))
1387       (t "(counted-map/4 1 1 list '((1 2)))"
1388          (emt:doc "Stops after N elements")
1389          (emt:assert
1390             (equal answer "((1))")))
1391       (t "(counted-map/4 2 2 list '((1 2) (11 12)))"
1392          (emt:doc "Can treat multiple lists")
1393          (emt:assert
1394             (equal answer "((1 11) (2 12))")))
1395       (t "(map list '(1 2))"
1396          (emt:doc "Check full `map'")
1397          (emt:assert
1398             (equal answer "((1) (2))")))
1399       (t "(map list '(1 2) '(11 12))"
1400          (emt:assert
1401             (equal answer "((1 11) (2 12))"))))
1402
1403    ;;On continuations
1404    (expect
1405       ((exec+args (list debug-klink-executable))
1406          (shell t)
1407          (prompt "\nklink> ")
1408          (timeout 10)
1409          (append-newline t))
1410       (t "")
1411       (t "($define! my-con-list (call/cc list))"
1412          (emt:doc "Make an object containing a continuation"))
1413       (t "my-con-list"
1414          (emt:doc "Check what we got")
1415          (emt:assert
1416             (equal answer "(#<CONTINUATION>)")))
1417       (t "($define! my-con (car my-con-list))"
1418          (emt:doc "Extract that continuation"))
1419       (t "my-con"
1420          (emt:doc "Check what we got")
1421          (emt:assert
1422             (equal answer "#<CONTINUATION>")))
1423       (t "(continuation->applicative my-con)"
1424          (emt:doc "Try a simple call")
1425          (emt:assert
1426             (equal answer "#<APPLICATIVE>")))
1427       (t "((continuation->applicative my-con) 12)"
1428          (emt:doc "Use the continuation")
1429          (emt:assert
1430             (equal answer "#inert")))
1431       (t "my-con-list"
1432          (emt:doc "my-con-list got redefined by the continuation")
1433          (emt:assert
1434             (equal answer "(12)")))
1435       (t "(apply (continuation->applicative (extend-continuation my-con
1436                     ($lambda v
1437                        (display \"arrived at the continuation with \")
1438                        (write v)
1439                        (newline)))) '(144))"
1440          (emt:assert
1441             (equal answer
1442                "arrived at the continuation with (144)\n#inert")))
1443       (t "($define! my-unguarded-con (guard-continuation '() my-con '()))"
1444          (emt:doc "Make a continuation that has empty list of guards")
1445          (emt:assert
1446             (equal answer "#inert")))
1447       (t "(apply (continuation->applicative my-unguarded-con) '(145))"
1448          (emt:doc "Applies without problem")
1449          (emt:assert
1450             (equal answer "#inert")))
1451       (t "my-con-list"
1452          (emt:doc "The continuation got called")
1453          (emt:assert
1454             (equal answer "(145)")))
1455
1456       (t "($define! my-guarded-con (guard-continuation
1457     (list (list root-continuation
1458                                ($lambda (v %ignore)
1459                                   (display \"entering the continuation with \")
1460                                   (write v)
1461                                   (newline)
1462                                   v)))
1463     my-con
1464     (list (list root-continuation
1465                                ($lambda (v %ignore)
1466                                   (display \"exiting the continuation with \")
1467                                   (write v)
1468                                   (newline)
1469                                   v)))))"
1470          (emt:doc "Create a guarded continuation")
1471          (emt:assert
1472             (equal answer "#inert")))
1473       (t "my-guarded-con"
1474          (emt:doc "Type is correct")
1475          (emt:assert
1476             (equal answer "#<CONTINUATION>")))
1477       (t "(continuation->applicative my-guarded-con)"
1478          (emt:doc "Type is correct")
1479          (emt:assert
1480             (equal answer "#<APPLICATIVE>")))
1481       (t "(apply (continuation->applicative my-guarded-con) '(146))"
1482          (emt:doc "We see it calls the guard and continues")
1483          (emt:assert
1484             (equal answer "entering the continuation with (146)\n#inert")))
1485       (t "my-con-list"
1486          (emt:doc "The continuation got called")
1487          (emt:assert
1488             (equal answer "(146)")))
1489       (t "(guard-dynamic-extent
1490         '()
1491         ($lambda () (display \"Got here\")(newline))
1492          '())"
1493          (emt:doc "Calls the combiner arg with no variables")
1494          (emt:assert
1495             (equal answer "Got here\n#inert")))
1496    (t "(guard-dynamic-extent
1497         (list (list root-continuation               ($lambda (v %ignore)
1498                   (display \"Abnormally entering dynamic extent.\")
1499                   (newline)
1500                   v)))
1501         ($lambda () (display \"Got here\")(newline))
1502         '())"
1503       (emt:doc "Does not initially call the entry guards")
1504       (emt:assert
1505             (equal answer "Got here\n#inert")))
1506    (t "(guard-dynamic-extent
1507         '()
1508         ($lambda () (display \"Got here\")(newline))
1509         (list (list root-continuation               ($lambda (v %ignore)
1510                   (display \"Abnormally entering dynamic extent.\")
1511                   (newline)
1512                   v))))"
1513       (emt:doc "Does not initially call the exit guards")
1514       (emt:assert
1515          (equal answer "Got here\n#inert"))))
1516
1517
1518
1519    ;;On `and?' etc
1520    (expect
1521       ((exec+args (list debug-klink-executable))
1522          (shell t)
1523          (prompt "\nklink> ")
1524          (timeout 10)
1525          (append-newline t))
1526       (t "")
1527       (t "and?"
1528          (emt:doc "Is recognized")
1529          (emt:assert
1530             (equal answer "#,and?")))
1531       (t "(and?)"
1532          (emt:doc "Given no args, returns true")
1533          (emt:assert
1534             (equal answer "#t")))
1535       (t "(and? #t)"
1536          (emt:doc "Accepts 1 arg")
1537          (emt:assert
1538             (equal answer "#t")))
1539       (t "(and? #t #t)"
1540          (emt:doc "Accepts 2 args")
1541          (emt:assert
1542             (equal answer "#t")))
1543       (t "(and? #t #f)"
1544          (emt:doc "If an arg is false, returns false")
1545          (emt:assert
1546             (equal answer "#f")))
1547       (t "(and? #t (integer? 1))"
1548          (emt:doc "Arguments are evaluated")
1549          (emt:assert
1550             (equal answer "#t")))
1551       (t "(and? #t (integer? \"11\"))"
1552          (emt:doc "The evaluated value is used")
1553          (emt:assert
1554             (equal answer "#f")))
1555       (t "(or? #f)"
1556          (emt:doc "If there are only false clauses, returns false")
1557          (emt:assert
1558             (equal answer "#f")))
1559       (t "(or? #f #t)"
1560          (emt:doc "If there is any true clause, return true")
1561          (emt:assert
1562             (equal answer "#t")))
1563       (t "(or? #f #t #f)"
1564          (emt:assert
1565             (equal answer "#t")))
1566       (t "($and?)"
1567          (emt:doc "The evaluating variant")
1568          (emt:assert
1569             (equal answer "#t")))
1570       (t "($and? #t #f)"
1571          (emt:assert
1572             (equal answer "#f")))
1573       (t "($and? #f #t)"
1574          (emt:assert
1575             (equal answer "#f")))
1576       (t "($and? ($sequence (display \"One\")(newline) #f))"
1577          (emt:doc "Evaluates some of its args, at least the first one")
1578          (emt:assert
1579             (equal answer "One\n#f")))
1580       (t "($and? ($sequence (display \"One\")(newline) #t)($sequence (display \"Two\")(newline) #f))"
1581          (emt:assert
1582             (equal answer "One\nTwo\n#f")))
1583       (t "($and? ($sequence (display \"One\")(newline) #f)($sequence (display \"Two\")(newline) #f))"
1584          (emt:assert
1585             (equal answer "One\n#f")))
1586       (t "(every?/2-xary and? '())"
1587          (emt:doc "xary-1 `every?/2-xary' is available (in `simple' environment)")
1588          (emt:assert
1589             (equal answer "#t")))
1590       (t "(every?/2-xary and? '(()))"
1591          (emt:doc "No elements")
1592          (emt:assert
1593             (equal answer "#t")))
1594       (t "(every?/2-xary and? '((#f)))"
1595          (emt:doc "One element containing one element (for `and?')")
1596          (emt:assert
1597             (equal answer "#f")))
1598       (t "(every?/2-xary and? '((#t #t)))"
1599          (emt:doc "More elements")
1600          (emt:assert
1601             (equal answer "#t")))
1602       (t "(every?/2-xary and? '((#t #t)(#t)))"
1603          (emt:assert
1604             (equal answer "#t")))
1605       (t "(every?/2-xary and? '((#t #t)(#f)))"
1606          (emt:assert
1607             (equal answer "#f"))))
1608
1609
1610    (expect
1611       ((exec+args (list debug-klink-executable))
1612          (shell t)
1613          (prompt "\nklink> ")
1614          (timeout 10)
1615          (append-newline t))
1616       (t "")
1617       (t "(>? 1 0)"
1618          (emt:doc "Test that comparisons work as expected")
1619          (emt:assert
1620             (equal answer "#t")))
1621       (t "(>? 1 1)"
1622          (emt:assert
1623             (equal answer "#f")))
1624       (t "(>? 1 2)"
1625          (emt:assert
1626             (equal answer "#f")))
1627       (t "(<? 1 0)"
1628          (emt:assert
1629             (equal answer "#f")))
1630       (t "(<? 1 1)"
1631          (emt:assert
1632             (equal answer "#f")))
1633       (t "(<? 1 2)"
1634          (emt:assert
1635             (equal answer "#t")))
1636       (t "(>=? 1 0)"
1637          (emt:assert
1638             (equal answer "#t")))
1639       (t "(>=? 1 1)"
1640          (emt:assert
1641             (equal answer "#t")))
1642       (t "(>=? 1 2)"
1643          (emt:assert
1644             (equal answer "#f")))
1645       (t "(<=? 1 0)"
1646          (emt:assert
1647             (equal answer "#f")))
1648       (t "(<=? 1 1)"
1649          (emt:assert
1650             (equal answer "#t")))
1651       (t "(<=? 1 2)"
1652          (emt:assert
1653             (equal answer "#t")))
1654       (t "(compare-neighbors <? '(0 1 2))"
1655          (emt:assert
1656             (equal answer "#t")))
1657       (t "(compare-neighbors <? '(0))"
1658          (emt:assert
1659             (equal answer "#t")))
1660       (t "(compare-neighbors <=? '(0 1 2))"
1661          (emt:assert
1662             (equal answer "#t")))
1663       (t "(compare-neighbors <? '(0 1 1 2))"
1664          (emt:assert
1665             (equal answer "#f")))
1666       (t "(compare-neighbors <=? '(0 1 1 2))"
1667          (emt:assert
1668             (equal answer "#t"))))
1669
1670
1671    (expect
1672       ((exec+args (list debug-klink-executable))
1673          (shell t)
1674          (prompt "\nklink> ")
1675          (timeout 10)
1676          (append-newline t))
1677       (t "")
1678       (t "(+ 1 2 3)"
1679          (emt:doc "N-ary addition works")
1680          (emt:assert
1681             (equal answer "6")))
1682       (t "(+ 1 2 (+ 3 0))"
1683          (emt:doc "N-ary addition evaluates its arguments")
1684          (emt:assert
1685             (equal answer "6")))
1686       (t "(+)"
1687          (emt:doc "N-ary addition gives 0 on no operands")
1688          (emt:assert
1689             (equal answer "0")))
1690       (t "(+ 3)"
1691          (emt:doc "N-ary addition with 1 operand works")
1692          (emt:assert
1693             (equal answer "3")))
1694
1695       (t "(* 1 2 30)"
1696          (emt:doc "N-ary multiplication works")
1697          (emt:assert
1698             (equal answer "60")))
1699       (t "(* 1 2 (* 3 10))"
1700          (emt:doc "N-ary multiplication evaluates its arguments")
1701          (emt:assert
1702             (equal answer "60")))
1703       (t "(*)"
1704          (emt:doc "N-ary multiplication gives 0 on no operands")
1705          (emt:assert
1706             (equal answer "1")))
1707       (t "(* 3)"
1708          (emt:doc "N-ary multiplication with 1 operand works")
1709          (emt:assert
1710             (equal answer "3")))
1711       (t "(/ 2 2)"
1712          (emt:doc "Dividing an integer by itself gives 1")
1713          (emt:assert
1714             (equal answer "1")))
1715       (t "(/ 2 1)"
1716          (emt:doc "Dividing an integer by 1 gives itself")
1717          (emt:assert
1718             (equal answer "2")))
1719       (t "(/ 1.0 2.0)"
1720          (emt:doc "For real division, it doesn't floor")
1721          (emt:assert
1722             (equal answer "0.5")))
1723       (t "(/ 6 3)"
1724          (emt:assert
1725             (equal answer "2")))
1726       (t "(/ 6 3 2)"
1727          (emt:assert
1728             (equal answer "1")))
1729       (t "(/ 6 3 2 2)"
1730          (emt:assert
1731             (equal answer "0.5")))
1732       (t "(- 100 20)"
1733          (emt:assert
1734             (equal answer "80")))
1735       (t "(- 100 20 5)"
1736          (emt:assert
1737             (equal answer "75")))
1738       (t "(- 100)"
1739          (emt:doc "`-' with no subtrahends raises error")
1740          (emt:assert
1741             (emt:eq-persist-p #'equal answer
1742                "dbid:d0afc822-58f7-4921-b37d-57d45cd6b5e0")))
1743       (t "(/ 6)"
1744          (emt:doc "`/' with no divisors raises error")
1745          (emt:assert
1746             (emt:eq-persist-p #'equal answer
1747                "dbid:2afbb9f8-3016-46a5-bb93-9d9d2fdd0e98"))))
1748    ;;equal?
1749    (expect
1750       ((exec+args (list debug-klink-executable))
1751          (shell t)
1752          (prompt "\nklink> ")
1753          (timeout 10)
1754          (append-newline t))
1755       (t "")
1756       (t "(equal?/2 3 3)"
1757          (emt:doc "Compares numbers correctly")
1758          (emt:assert
1759             (equal answer "#t")))
1760       (t "(equal?/2 3 2)"
1761          (emt:assert
1762             (equal answer "#f")))
1763       (t "(equal?/2 3 '(1 2))"
1764          (emt:assert
1765             (equal answer "#f")))
1766       (t "(equal?/2 'a 'a)"
1767          (emt:doc "Compares symbols correctly")
1768          (emt:assert
1769             (equal answer "#t")))
1770       (t "(equal?/2 'a 'b)"
1771          (emt:assert
1772             (equal answer "#f")))
1773       (t "(equal?/2 '(1 2) '(1 2))"
1774          (emt:doc "Compares lists correctly")
1775          (emt:assert
1776             (equal answer "#t")))
1777       (t "(equal?/2 '(1 2) '(1 3))"
1778          (emt:doc "Compares lists correctly")
1779          (emt:assert
1780             (equal answer "#f")))
1781       (t "(equal?/2 \"meet\" \"meet\")"
1782           (emt:doc "Compares strings correctly")
1783           (emt:assert
1784              (equal answer "#t")))
1785       (t "(equal?/2 \"meet\" \"not\")"
1786           (emt:doc "Compares strings correctly")
1787           (emt:assert
1788              (equal answer "#f")))
1789       (t "(equal?)"
1790           (emt:doc "Given the empty list, is true")
1791          (emt:assert
1792             (equal answer "#t")))
1793
1794       )
1795
1796
1797    ;;$provide, $binds?
1798    (expect
1799       ((exec+args (list debug-klink-executable))
1800          (shell t)
1801          (prompt "\nklink> ")
1802          (timeout 10)
1803          (append-newline t))
1804       (t "")
1805       (t "($define! a #f)")
1806       (t "($define! b #f)")
1807       (t "($provide! (b c) ($define! a 13) ($define! b 12) ($define! c 144))"
1808          (emt:doc "`$provide!' b and c but not a")
1809          (emt:assert
1810             (equal answer "#inert")))
1811       (t "a"
1812          (emt:doc "`a' is what it was")
1813          (emt:assert
1814             (equal answer "#f")))
1815       (t "b"
1816          (emt:doc "b has been changed")
1817          (emt:assert
1818             (equal answer "12")))
1819       (t "c"
1820          (emt:doc "c is available")
1821          (emt:assert
1822             (equal answer "144")))
1823       (t "((wrap $binds?/2) (get-current-environment) 'wrap)"
1824          (emt:doc "Test the simple version")
1825          (emt:doc "We know `wrap' should be bound")
1826          (emt:assert
1827             (equal answer "#t")))
1828       (t "((wrap $binds?/2) (get-current-environment) '$binds?/2)"
1829          (emt:doc "We know `$binds?/2' should be bound")
1830          (emt:assert
1831             (equal answer "#t")))
1832       (t "((wrap $binds?/2) (make-environment) '$binds?/2)"
1833          (emt:doc "`make-environment' should bind nothing.")
1834          (emt:assert
1835             (equal answer "#f")))
1836       (t "((wrap $binds?/2) (make-environment) 'unlikely-to-be-bound)"
1837          (emt:doc "In case the preceding test worked for the wrong \
1838 reason, ie that `make-environment' leaked")
1839          (emt:assert
1840             (equal answer "#f")))
1841       (t "($binds? (get-current-environment) $binds?)"
1842          (emt:doc "The N-ary version works")
1843          (emt:assert
1844             (equal answer "#t")))
1845       (t "($binds? (make-environment) $binds?)"
1846          (emt:doc "Discriminates")
1847          (emt:assert
1848             (equal answer "#f")))
1849       (t "($binds? (get-current-environment) list wrap)"
1850          (emt:doc "Takes more than 1 arg")
1851          (emt:assert
1852             (equal answer "#t"))))
1853
1854    (expect
1855       ((exec+args (list debug-klink-executable))
1856          (shell t)
1857          (prompt "\nklink> ")
1858          (timeout 10)
1859          (append-newline t))
1860       (t "")
1861       (t "($define! a (open-input-file \"test-m1.krn\"))"
1862          (emt:doc "Open an input port from a known file")
1863          (emt:assert
1864             (equal answer "#inert")))
1865       (t "a"
1866          (emt:doc "We got a port")
1867          (emt:assert
1868             (equal answer "#<PORT>")))
1869       (t "(get-char a)"
1870          (emt:doc "Check the first few characters against known values")
1871          (emt:assert
1872             (equal answer "#\\;")))
1873       (t "(get-char a)"
1874          (emt:assert
1875             (equal answer "#\\newline")))
1876       (t "(get-char a)"
1877          (emt:assert
1878             (equal answer "#\\;"))))
1879
1880    (expect
1881       ((exec+args (list debug-klink-executable))
1882          (shell t)
1883          (prompt "\nklink> ")
1884          (timeout 10)
1885          (append-newline t))
1886       (t "")
1887       (t "($binds? (get-current-environment) not-bound-in-ground)"
1888          (emt:doc "Validate that `not-bound-in-ground' is not already bound")
1889          (emt:assert
1890             (equal answer "#f")))
1891       (t "($define! a (make-kernel-standard-environment))"
1892          (emt:doc "Create a standard environment")
1893          (emt:assert
1894             (equal answer "#inert")))
1895       (t "($binds? a $binds?)"
1896          (emt:doc "The ground bindings are available")
1897          (emt:assert
1898             (equal answer "#t")))
1899       (t "($set! a not-bound-in-ground 12)"
1900          (emt:doc "set `not-bound-in-ground' in a")
1901          (emt:assert
1902             (equal answer "#inert")))
1903       (t "($binds? a not-bound-in-ground)"
1904          (emt:doc "It's bound in `a'")
1905          (emt:assert
1906             (equal answer "#t")))
1907       (t "(eval 'not-bound-in-ground a)"
1908          (emt:doc "It has the right value in `a'")
1909          (emt:assert
1910             (equal answer "12")))
1911       (t "($binds? (get-current-environment) not-bound-in-ground)"
1912          (emt:doc "It's not bound in current environment")
1913          (emt:assert
1914             (equal answer "#f")))
1915       (t "($define! x (get-module \"test-m1.krn\"))"
1916          (emt:doc "In `x', no parameters are defined")
1917          (emt:doc (concat "Answer: " answer)))
1918       (t "($define! y (get-module \"test-m1.krn\"
1919       ($bindings->environment (baz  \"quux\"))))"
1920          (emt:doc "In `y', `baz' is defined")
1921          (emt:doc (concat "Answer: " answer)))
1922       (t "($define! z (get-module \"test-m1.krn\"
1923       ($bindings->environment (quux  \"baz\"))))"
1924          (emt:doc "In `z', quux' is defined")
1925          (emt:doc (concat "Answer: " answer)))
1926       (t "(write (($remote-eval foo x)))"
1927          (emt:doc "Query `x'")
1928          (emt:assert
1929             (equal answer "no parameters\n#inert#inert")))
1930       (t "(write (($remote-eval foo y)))"
1931          (emt:doc "Query `y'")
1932          (emt:assert
1933             (equal answer "parameters, but no quux\n#inert#inert")))
1934       (t "(write (($remote-eval foo z)))"
1935          (emt:doc "Query `z'")
1936          (emt:assert
1937             (equal answer "parameters\n\"baz\"#inert"))))
1938
1939    (expect
1940       ((exec+args (list debug-klink-executable))
1941          (shell t)
1942          (prompt "\nklink> ")
1943          (timeout 10)
1944          (append-newline t))
1945       (t "")
1946       (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
1947       ((x . y)) x) (force low-promise))))) (force p1))"
1948          (emt:doc "WRITE ME")
1949          (emt:assert
1950             (equal answer "1")))
1951       (t "($let* ((low-promise ($lazy (cons 1 2)))(p1 ($lazy (($lambda
1952       ((x . y)) y) (force low-promise))))) (force p1))"
1953          (emt:doc "WRITE ME")
1954          (emt:assert
1955             (equal answer "2"))))
1956
1957    ;;Automatically forcing promises
1958    (expect
1959       ((exec+args (list debug-klink-executable))
1960          (shell t)
1961          (prompt "\nklink> ")
1962          (timeout 10)
1963          (append-newline t))
1964       (t "")
1965       (t "(car ($lazy '(1)))"
1966          (emt:doc "Car can force a promise")
1967          (emt:assert
1968             (equal answer "1")))
1969       (t "(car ($lazy '(2 3)))"
1970          (emt:assert
1971             (equal answer "2")))
1972       (t "((wrap $binds?/2) (get-current-environment) '$binds?/2)"
1973          (emt:doc "Validate that this call works")
1974          (emt:assert
1975             (equal answer "#t")))
1976       (t "((wrap $binds?/2) ($lazy (get-current-environment)) '$binds?/2)"
1977          (emt:doc "And validate that it works with one arg")
1978          (emt:assert
1979             (equal answer "#t")))
1980
1981       (t "((wrap $binds?/2) ($lazy (get-current-environment)) ($lazy '$binds?/2))"
1982          (emt:doc "We can force two arguments")
1983          (emt:assert
1984             (equal answer "#t")))
1985       (t "(every?/2-xary integer? '((1) (2)))"
1986          (emt:doc "Validate that this call works")
1987          (emt:assert
1988             (equal answer "#t")))
1989       (t "(every?/2-xary integer? '((1) (#f)))"
1990          (emt:doc "False works too")
1991          (emt:assert
1992             (equal answer "#f")))
1993
1994       (t "(every?/2-xary ($lazy integer?) '((1) (2)))"
1995          (emt:doc "Arguments after the forced argument work")
1996          (emt:assert
1997             (equal answer "#t")))
1998
1999       (t "(every?/2-xary ($lazy integer?) '((1) (#f)))"
2000          (emt:assert
2001             (equal answer "#f")))
2002
2003       (t "(every?/2-xary ($lazy integer?) ($lazy '((1) (2))))"
2004          (emt:doc "Arguments after the forced argument work")
2005          (emt:assert
2006             (equal answer "#t")))
2007
2008       (t "(every?/2-xary ($lazy integer?) ($lazy '((1) (#f))))"
2009          (emt:assert
2010             (equal answer "#f"))))
2011
2012    (expect
2013       ((exec+args (list debug-klink-executable))
2014          (shell t)
2015          (prompt "\nklink> ")
2016          (timeout 10)
2017          (append-newline t))
2018       (t "")
2019       (t "(profiling 1)"
2020          (emt:doc "Turn profiling on, and it should not have been on before")
2021          (emt:assert
2022             (equal answer "0")))
2023       (t "(profiling 1)"
2024          (emt:doc "Now it's on, and this is our first profiled call")
2025          (emt:assert
2026             (equal answer "1")))
2027       (t "(get-profiling-data)"
2028          (emt:doc "We see the profiling data from just the earlier call")
2029          (emt:doc "All profiling data may change, we're interested in
2030       its general behavior and in including the functions we just called")
2031          (emt:assert
2032             (emt:eq-persist-p #'equal
2033                answer
2034                "dbid:787cceb2-39a0-46c3-97a7-a23a3de3da4b")))
2035       (t "(profiling 1)"
2036          (emt:doc "Run this call again")
2037          (emt:assert
2038             (equal answer "1")))
2039       (t "(get-profiling-data)"
2040          (emt:doc "Now profiling data shows 2 calls to `profiling', 1
2041       to `get-profiling-data'")
2042          (emt:assert
2043             (emt:eq-persist-p #'equal
2044                answer
2045                "dbid:26b534dc-b589-4d2c-9026-7c5ea9b8a858")))
2046       (t "(get-profiling-data)"
2047          (emt:doc "Again")
2048          (emt:assert
2049             (emt:eq-persist-p #'equal
2050                answer
2051                "dbid:3c018d05-1938-4af6-8ad3-5325b9d16fd6"))))
2052
2053    )
2054
2055 ;;;_ , debug-klink-capture-form
2056 ;;;###autoload
2057 (defun debug-klink-capture-form ()
2058    "Push entries for an `emtr:expect' script onto the kill ring.
2059 Basically `emtr:expect:buffer-capture-form' specialized for klink.
2060
2061 Current buffer should contain a transcript of a klink session."
2062
2063
2064    (interactive)
2065    (emtr:expect:buffer-capture-form debug-klink-prompt t t))
2066
2067 ;;;_. Footers
2068 ;;;_ , Provides
2069
2070 (provide 'debug-klink)
2071
2072 ;;;_ * Local emacs vars.
2073 ;;;_  + Local variables:
2074 ;;;_  + mode: allout
2075 ;;;_  + End:
2076
2077 ;;;_ , End
2078 ;;; debug-klink.el ends here