commit c76f788372bdae412122f7d91f4d7abdeeceb663 parent 12498358c579af9b182f8959f97b33ed43cde898 Author: Andres Navarro <canavarro82@gmail.com> Date: Mon, 23 May 2011 16:23:46 -0300 Added a simple test framework and some tests. Diffstat:
| M | COPYRIGHT | | | 1 | + |
| M | src/klisp.h | | | 1 | + |
| A | src/tests/booleans.k | | | 115 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/tests/check.k | | | 408 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/tests/combiners.k | | | 320 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/tests/control.k | | | 199 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/tests/environment-mutation.k | | | 8 | ++++++++ |
| A | src/tests/environments.k | | | 9 | +++++++++ |
| A | src/tests/eq-equal.k | | | 2 | ++ |
| A | src/tests/pair-mutation.k | | | 204 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/tests/pairs-and-lists.k | | | 447 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/tests/symbols.k | | | 38 | ++++++++++++++++++++++++++++++++++++++ |
| A | src/tests/test-all.k | | | 19 | +++++++++++++++++++ |
| A | src/tests/test-helpers.k | | | 28 | ++++++++++++++++++++++++++++ |
14 files changed, 1799 insertions(+), 0 deletions(-)
diff --git a/COPYRIGHT b/COPYRIGHT @@ -12,6 +12,7 @@ under the MIT license. klisp Parts: Copyright (C) 2011 Andres Navarro. Lua Parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio. IMath Parts: Copyright (C) 2002-2007 Michael J. Fromberger. +srfi-78: Copyright (C) 2005-2006 Sebastian Egner. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/src/klisp.h b/src/klisp.h @@ -41,6 +41,7 @@ void klisp_close (klisp_State *K); * Copyright (C) 2011 Andres Navarro. All rights reserved. * Lua parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio. All rights reserved. * IMath Parts: Copyright (C) 2002-2007 Michael J. Fromberger. +* srfi-78: Copyright (C) 2005-2006 Sebastian Egner. * * Permission is hereby granted, free of charge, to any person obtaining * a copy of this software and associated documentation files (the diff --git a/src/tests/booleans.k b/src/tests/booleans.k @@ -0,0 +1,115 @@ +;; check.k & test-helpers.k should be loaded + +;;; +;;; Basic Functionality +;;; + +;; boolean? +($check-predicate (boolean?)) +($check-predicate (boolean? #t)) +($check-predicate (boolean? #f)) +($check-predicate (boolean? #t #t #f #f)) +($check-predicate (boolean? #f . #0=(#t . #0#))) + +($check-not-predicate (boolean? ((unwrap list) . symbol))) +($check-not-predicate (boolean? ())) +($check-not-predicate (boolean? (cons () ()))) +($check-not-predicate (boolean? #ignore)) +($check-not-predicate (boolean? (make-environment))) +($check-not-predicate (boolean? #inert)) +($check-not-predicate (boolean? $vau)) +($check-not-predicate (boolean? wrap)) +($check-not-predicate (boolean? (call/cc ($lambda (c) c)))) +($check-not-predicate (boolean? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (boolean? (memoize #inert))) +($check-not-predicate (boolean? 1)) +;XXX ($check-not-predicate (boolean? 1.0)) +($check-not-predicate (boolean? #e+infinity)) +;XXX ($check-not-predicate (boolean? #i+infinity)) +;($check-not-predicate (boolean? #undefined)) +;($check-not-predicate (boolean? #real-with-no-primary-value)) +($check-not-predicate (boolean? "string")) +($check-not-predicate (boolean? #\a)) +($check-not-predicate (boolean? (get-current-input-port))) + +;; basic eq?-ness and not? +($check eq? #t #t) +($check eq? #f #f) +($check not-eq? #t #f) +($check not-eq? #f #t) +($check eq? (not? #t) #f) +($check eq? (not? #f) #t) + +;; basic equal?-ness and not? +($check equal? #t #t) +($check equal? #f #f) +($check not-equal? #t #f) +($check not-equal? #f #t) +($check equal? (not? #t) #f) +($check equal? (not? #f) #t) + +;; and? & or? +($check-predicate (and?)) +($check-predicate (and? #t)) +($check-predicate (and? #t #t)) +($check-predicate (and? #t #t #t)) +($check-predicate (and? #t . #0=(#t . #0#))) +($check-not-predicate (and? #f)) +($check-not-predicate (and? #t #t #f)) + +($check-predicate (or? #t)) +($check-predicate (or? #f #t)) +($check-predicate (or? #f #f #t)) +($check-predicate (or? #f . #0=(#t . #0#))) +($check-not-predicate (or?)) +($check-not-predicate (or? #f)) +($check-not-predicate (or? #f #f #f)) + +;; $and? & $or? +;; TODO check tail call +($check-predicate ($and?)) +($check-predicate ($and? #t)) +($check-predicate ($and? (eq? #t #t) #t)) ;; test some evaluation too! +($check-predicate ($and? #t (eq? #f #f) #t)) +($check-not-predicate ($and? #t . #0=((eq? #t #f) . #0#))) +($check-not-predicate ($and? #f)) +($check-not-predicate ($and? #t #t #f)) +($check-not-predicate ($and? #f (/ 1 0))) ;; test conditional evaluation + +($check-predicate ($or? #t)) +($check-predicate ($or? #f (eq? #t #t) #t)) ;; test some evaluation too! +($check-predicate ($or? #f #f #t)) +($check-predicate ($or? #t (/ 1 0))) +($check-predicate ($or? #f . #0=(#t . #0#))) +($check-not-predicate ($or? #f)) +($check-not-predicate ($or?)) + + +;;; +;;; Error Checking and Robustness +;;; + +;; boolean? +($check-error (boolean? #t . #f)) + +;; not? +($check-error (not?)) +($check-error (not? 1)) +($check-error (not? #inert)) +($check-error (not? #t #f)) + +;; and? & or? +($check-error (and? #t #f 0)) +($check-error (or? #f #t 0)) +($check-error (and? #t . #f)) + +;; $and? & $or? +($check-error ($and? #t 0 #t)) +($check-error ($or? #f 0 #f)) + +;; check boolean in last operand +($check-error ($and? #t 0)) +($check-error ($or? #f 0)) + diff --git a/src/tests/check.k b/src/tests/check.k @@ -0,0 +1,408 @@ +;;; Simple test framework based on srfi-78 +;;; +;;; See Copyright Notice in klisp.h +;;; +;;; SOURCE NOTE: Based on the reference implementation by Sebastian Egner +;;; +;;; TEMP: No eager comprehension for now +;;; XXX: modes are encapsulated values instead of symbols, it could also +;;; be done with a $check-set-mode! operative, or with keyword objects +;;; it they were implemented. +;;; +;;; + +;; TODO refactor out some of the code in $check, $check-error, and the -ec +;; variants, there is too much duplication and the applicatives are a bit +;; too long. +($provide! + ($check $check-error check-report check-reset! check-set-mode! + check-passed? check-mode-off check-mode-summary + check-mode-report-failed check-mode-report) + ;; PRIVATE + + ;; STATE + + ;; internal count + ($define! passed 0) + ($define! failed 0) + ($define! first-failed #inert) ;; form: (error? . extra-data) + ;; no error: (#f exp actual expected) + ;; error: (#t string exp error) + ;; failed = 0 => first-failed = #inert + + ;; initial state: report-failed (states are off summary report-failed and + ;; report) + ($define! report-on? #t) ; #t except in all states except: off + ($define! report-fail? #t) ; #t in states: report-failed and report + ($define! report-pass? #f) ; #t in state: report + + ;; encapsulation for mode parameter + ($define! (enc-mode mode? get-mode-params) (make-encapsulation-type)) + ;; /STATE + + ;; little helper for error catching + ;; This evaluates expression in the dynamic environment + ;; If no error occurs it returs #t + ;; If an there is an error, the handler applicative is called + ;; in the dynamic environment with the object passed to the error + ;; continuation as sole argument + ($define! $without-error? + ($vau (exp handler) denv + (guard-dynamic-extent + () + ($lambda () + (eval exp denv) + #t) + (list (list error-continuation + ($lambda (error-obj divert) + (apply (eval handler denv) + (list error-obj) denv) + (apply divert #f))))))) + + ;; ;; another way to do the same: return a pair of (error? result/error-obj) + ;; ;; but it is difficult to use because it starts nesting (see $check) + ;; ($define! $try + ;; ($vau (exp) denv + ;; (guard-dynamic-extent + ;; () + ;; ($lambda () + ;; (list #t (eval exp denv)) + ;; (list (list error-continuation + ;; ($lambda (error-obj divert) + ;; (apply divert (list #f error-obj))))))))) + + + + ($define! check-passed! + ($let ((env (get-current-environment))) + ($lambda () + ($set! env passed (+ passed 1))))) + + ($define! check-failed/expected! + ($let ((env (get-current-environment))) + ($lambda ls + ($if (zero? failed) + ($set! env first-failed (cons #f ls)) + #inert) + ($set! env failed (+ failed 1))))) + + ($define! check-failed/error! + ($let ((env (get-current-environment))) + ($lambda ls + ($if (zero? failed) + ($set! env first-failed (cons #t ls)) + #inert) + ($set! env failed (+ failed 1))))) + + ($define! describe-passed + ($lambda (exp actual) + (show-exp exp) + (show-res actual) + (show-passed 1))) + + ($define! describe-failed + ($lambda (exp actual expected) + (show-exp exp) + (show-res actual) + (show-failed expected))) + + ($define! describe-error + ($lambda (str exp err-obj) + (display str) + (show-exp exp) + (show-error err-obj))) + + ($define! describe-first-failed + ($lambda () + ($if (not? (zero? failed)) + ($let (((error? . extra-data) first-failed)) + (apply ($if error? + describe-error + describe-failed) + extra-data)) + #inert))) + + ;; show applicatives + ($define! show-exp + ($lambda (exp) + (write exp) + (display " => "))) + + ($define! show-res + ($lambda (res) + (write res))) + + ($define! show-passed + ($lambda (cases) + (display "; *** passed ") + ($if (not? (=? cases 1)) + ($sequence (display "(") + (display cases) + (display " cases)")) + #inert) + (display "***") + (newline))) + + ($define! show-failed + ($lambda (expected) + (display "; *** failed ***") + (newline) + (display " ; expected result: ") + (write expected) + (newline))) + + ($define! show-error + ($lambda (err-obj) + (display "; *** error ***") + (newline) + (display "; error object: ") + (write err-obj) + (newline))) + ;; /PRIVATE + + ;; PUBLIC + + ;; general check facility. It always take an equality predicate + ;; needs to be operative to save the original expression + ($define! $check + ($let ((handler (wrap ($vau (error-obj) denv + ($set! denv error-obj error-obj))))) + ($vau (test? exp expected) denv + ($cond ((not? report-on?) #inert) + ((not? ($without-error? ($define! test? (eval test? denv)) + handler)) + ($let ((error-ls + (list "error evaling test? applicative: " test? + error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert))) + ((not? ($without-error? ($define! expected (eval expected denv)) + handler)) + ($let ((error-ls + (list "error evaling expected value: " expected + error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert))) + ((not? ($without-error? ($define! res (eval exp denv)) handler)) + ($let ((error-ls + (list "error evaling expression: " exp error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert))) + ((not? ($without-error? ($define! test-result + (apply test? (list res expected))) + handler)) ;; no dyn env here + ($let ((error-ls + (list "error evaling (test? exp expected): " + (list test? exp expected) error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert))) + (test-result + (check-passed!) + ($if report-pass? (describe-passed exp res) #inert)) + (#t ; test-result = #f + (check-failed/expected! exp res expected) + ($if report-fail? (describe-failed exp res expected) + #inert)))))) + +;; XXX /work in progress + + ;; helpers + ($define! $check-ec-helper + ($vau (test?-exp exp expected-exp escape/c) denv + ;; TODO, add argument-list for errors + ($cond ((not? ($without-error? ($define! test? (eval test? denv)) + handler)) + ($let ((error-ls + (list "error evaling test? applicative: " test? + error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert) + (apply-continuation escape/c #inert))) + ((not? ($without-error? ($define! expected (eval expected denv)) + handler)) + ($let ((error-ls + (list "error evaling expected value: " expected + error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert) + (apply-continuation escape/c #inert) + )) + ((not? ($without-error? ($define! res (eval exp denv)) handler)) + ($let ((error-ls + (list "error evaling expression: " exp error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert) + (apply-continuation escape/c #inert))) + ((not? ($without-error? ($define! test-result + (apply test? (list res expected))) + handler)) ;; no dyn env here + ($let ((error-ls + (list "error evaling (test? exp expected): " + (list test? exp expected) error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert) + (apply-continuation escape/c #inert))) + (test-result + ; (check-passed!) passed only after all passed + ; ($if report-pass? (describe-passed exp res) #inert)) + #inert + (#t ; test-result = #f + (check-failed/expected! exp res expected) + ($if report-fail? (describe-failed exp res expected) #inert) + (apply-continuation escape/c #inert)))))) + + ($define! $check-ec + ($let ((handler (wrap ($vau (error-obj) denv + ($set! denv error-obj error-obj))))) + ($vau (gens test? exp expected . maybe-arg-list) denv + ;; TODO add check + ($define! arg-list ($if (null? maybe-arg-list) + () + (car maybe-arg-list))) + ($cond ((not? report-on?) #inert) + ((not? ($without-error? ($define! gen (eval (cons $nested-ec + gens) + denv)) handler)) + ($let ((error-ls + (list "error evaling qualifiers: " gens error-obj))) + (apply check-failed/error! error-ls) + ($if report-fail? + (apply describe-error error-ls) + #inert))) + (($let/cc escape/c + ;; TODO add some security to the continuation + ;; (like make it one-shot and/or avoid reentry) + (eval (list do-ec (list gen) + (list check-ec-helper + test?-exp exp expected-exp + escape/c))) + #t) + ;; ... TODO passed with n cases + (check-passed!) + ($if report-pass? (describe-passed exp res) #inert) + ) + (#t ;; TODO didn't pass... + #inert + ))))) + +;; XXX /work in progress + + ;; Check that the given expression throws an error + ;; needs to be operative to save the original expression + ;; (not in the srfi, probably because of poor specification of error + ;; signaling in R5RS + ;; but very useful for checking proper argument checking) + ($define! $check-error + ($let ((handler (wrap ($vau (error-obj) denv + ($set! denv error-obj error-obj))))) + ($vau (exp) denv + ($cond ((not? report-on?) #inert) + (($without-error? ($define! result + (eval exp denv)) handler) + ($let ((error-ls + (list exp result "<ERROR>"))) + (apply check-failed/expected! error-ls) + ($if report-fail? + (apply describe-failed error-ls) + #inert))) + (#t ;; didn't throw error + (check-passed!) + ($if report-pass? + (describe-passed exp error-obj) + #inert)))))) + + ($define! check-report + ($lambda () + ($if report-on? + ($sequence + (display "Tests Passed: ") + (write passed) + (newline) + (display "Tests Failed: ") + (write failed) + (newline) + (display "Tests Total: ") + (write (+ failed passed)) + (newline) + (describe-first-failed)) + #inert))) ;; state: off don't show anything + + + ;; the modes are an encapsulated object each of + ;; '(off summary report-failed report) + ;; is an ecapsulated list of their effect on state variables + ;; (report-on? report-error? report-pass?) + ($define! check-mode-off (enc-mode (list #f #f #f))) + ($define! check-mode-summary (enc-mode (list #t #f #f))) + ($define! check-mode-report-failed (enc-mode (list #t #t #f))) + ($define! check-mode-report (enc-mode (list #t #t #t))) + + ($define! check-set-mode! + ($let ((env (get-current-environment))) + ($lambda (mode) + ($if (mode? mode) + ($set! env + (report-on? report-error? report-pass?) + (get-mode-params mode)) + (#t (error "$check-set-mode: invalid mode")))))) + + ($define! check-reset! + ($let ((env (get-current-environment))) + ($lambda () + ($set! env passed 0) + ($set! env failed 0) + ($set! env first-failed #inert)))) + + ($define! check-passed? + ($lambda (expected) + (and? (zero? failed) + (=? passed expected))))) +;; /PUBLIC + + +;; I drawed freely from the reference implementation so here is the +;; copyright notice: + +;; +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; ``Software''), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;; +;; ----------------------------------------------------------------------- +;; +;; Lightweight testing (reference implementation) +;; ============================================== +;; +;; Sebastian.Egner@philips.com + diff --git a/src/tests/combiners.k b/src/tests/combiners.k @@ -0,0 +1,320 @@ +;; check.k & test-helpers.k should be loaded + +;;; +;;; Basic Functionality +;;; + +;; operative?, applicative? & combiner? +($check-predicate (applicative? operative?)) +($check-predicate (applicative? applicative?)) +($check-predicate (applicative? combiner?)) + +($check-predicate (operative?)) +($check-predicate (operative? $if $vau $lambda)) +($check-predicate (operative? $cond . #0=($sequence . #0#))) + +($check-predicate (applicative?)) +($check-predicate (applicative? applicative? operative? combiner?)) +($check-predicate (applicative? wrap . #0=(unwrap . #0#))) + +($check-predicate (combiner?)) +($check-predicate (combiner? $if $vau $lambda)) +($check-predicate (combiner? $cond . #0=($sequence . #0#))) +($check-predicate (combiner?)) +($check-predicate (combiner? applicative? operative? combiner?)) +($check-predicate (combiner? wrap . #0=(unwrap . #0#))) + +($check-not-predicate (operative? #t)) +($check-not-predicate (operative? #f)) +($check-not-predicate (operative? ((unwrap list) . symbol))) +($check-not-predicate (operative? ())) +($check-not-predicate (operative? (cons () ()))) +($check-not-predicate (operative? #ignore)) +($check-not-predicate (operative? (make-environment))) +($check-not-predicate (operative? #inert)) +($check-not-predicate (operative? wrap)) +($check-not-predicate (operative? (call/cc ($lambda (c) c)))) +($check-not-predicate (operative? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (operative? (memoize #inert))) +($check-not-predicate (operative? 1)) +;($check-not-predicate (operative? 1.0)) +($check-not-predicate (operative? #e+infinity)) +;($check-not-predicate (operative? #i+infinity)) +;($check-not-predicate (operative? #undefined)) +;($check-not-predicate (operative? #real-with-no-primary-value)) +($check-not-predicate (operative? "string")) +($check-not-predicate (operative? #\a)) +($check-not-predicate (operative? (get-current-input-port))) + +($check-not-predicate (applicative? #t)) +($check-not-predicate (applicative? #f)) +($check-not-predicate (applicative? ((unwrap list) . symbol))) +($check-not-predicate (applicative? ())) +($check-not-predicate (applicative? (cons () ()))) +($check-not-predicate (applicative? #ignore)) +($check-not-predicate (applicative? (make-environment))) +($check-not-predicate (applicative? #inert)) +($check-not-predicate (applicative? $vau)) +($check-not-predicate (applicative? (call/cc ($lambda (c) c)))) +($check-not-predicate (applicative? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (applicative? (memoize #inert))) +($check-not-predicate (applicative? 1)) +;($check-not-predicate (applicative? 1.0)) +($check-not-predicate (applicative? #e+infinity)) +;($check-not-predicate (applicative? #i+infinity)) +;($check-not-predicate (applicative? #undefined)) +;($check-not-predicate (applicative? #real-with-no-primary-value)) +($check-not-predicate (applicative? "string")) +($check-not-predicate (applicative? #\a)) +($check-not-predicate (applicative? (get-current-input-port))) + +($check-not-predicate (combiner? #t)) +($check-not-predicate (combiner? #f)) +($check-not-predicate (combiner? ((unwrap list) . symbol))) +($check-not-predicate (combiner? ())) +($check-not-predicate (combiner? (cons () ()))) +($check-not-predicate (combiner? #ignore)) +($check-not-predicate (combiner? (make-environment))) +($check-not-predicate (combiner? #inert)) +($check-not-predicate (combiner? (call/cc ($lambda (c) c)))) +($check-not-predicate (combiner? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (combiner? (memoize #inert))) +($check-not-predicate (combiner? 1)) +;($check-not-predicate (combiner? 1.0)) +($check-not-predicate (combiner? #e+infinity)) +;($check-not-predicate (combiner? #i+infinity)) +;($check-not-predicate (combiner? #undefined)) +;($check-not-predicate (combiner? #real-with-no-primary-value)) +($check-not-predicate (combiner? "string")) +($check-not-predicate (combiner? #\a)) +($check-not-predicate (combiner? (get-current-input-port))) + +;; $vau +($check-predicate (operative? ($vau #ignore #ignore #inert))) +($check eq? (($vau #ignore #ignore)) #inert) +($check eq? (($vau #ignore #ignore 1)) 1) +($check equal? (($vau ls #ignore ls) 1 2) (list 1 2)) +($check equal? (($vau #ignore env env)) (get-current-environment)) +($check equal? (($vau (x y) #ignore (list y x)) 1 2) (list 2 1)) +;; parameter trees (generalized parameter lists) +($check equal? (($vau ((x . y) (z)) #ignore (list z y x)) (1 . 2) (3)) (list 3 2 1)) +($check equal? (($vau ((x y z)) #ignore (list z y x)) (1 2 3)) (list 3 2 1)) +($check equal? (($vau ((x y . z)) #ignore (finite-list? z)) + #0=(1 2 3 . #0#)) #f) + +;; test static scope of $vau, define an "inverted" $if and use it in the body +($let (($if ($vau (test a b) denv + (eval (list $if test b a) + denv)))) + ($check eq? + (($vau () #ignore + ($if #t 1 2))) + 2)) + +;; shared structure in ptree (but no shared symbols and no cycles) +($check equal? + (($vau ((x . #0=(#ignore)) (y . #0#)) #ignore (list x y)) (1 4) (2 5)) + (list 1 2)) + +;; wrap +($check-predicate (applicative? wrap)) +($check-predicate (applicative? (wrap ($vau #ignore #ignore #inert)))) +($check-predicate (applicative? (wrap (wrap ($vau #ignore #ignore #inert))))) +($check-predicate (applicative? (wrap $if))) + +;; unwrap +($check-predicate (applicative? unwrap)) +($check-predicate (operative? + (unwrap (wrap ($vau #ignore #ignore #inert))))) +($check-predicate (applicative? + (unwrap (wrap (wrap ($vau #ignore #ignore #inert)))))) +($check-predicate (operative? + (unwrap list))) +($check-predicate (applicative? + (unwrap (wrap list)))) + +;; $lambda +($check-predicate (applicative? ($lambda #ignore #inert))) +($check eq? (($lambda #ignore)) #inert) +($check eq? (($lambda #ignore 1)) 1) +($check equal? (($lambda ls ls) 1 2) (list 1 2)) +($check equal? (($lambda (x y) (list y x)) 1 2) (list 2 1)) +;; arguments should be eval'ed in the current environment +($check eq? + (($lambda (x) x) (get-current-environment)) + (get-current-environment)) +;; parameter trees (generalized parameter lists) +($check equal? (($lambda ((x . y) (z)) (list z y x)) + (cons 1 2) (list 3)) (list 3 2 1)) +($check equal? (($lambda ((x y z)) (list z y x)) (list 1 2 3)) (list 3 2 1)) +($check equal? (($lambda ((x y . z)) (finite-list? z)) + (list . #0=(1 2 3 . #0#))) #f) + +;; test static scope of $lambda, define an "inverted" $if and use it in the body +($let (($if ($vau (test a b) denv + (eval (list $if test b a) + denv)))) + ($check eq? + (($lambda () + ($if #t 1 2))) + 2)) +;; shared structure in ptree (but no shared symbols and no cycles) +($check equal? + (($lambda ((x . #0=(#ignore)) (y . #0#)) (list x y)) + (list 1 4) (list 2 5)) + (list 1 2)) + +;; apply +($check-predicate (applicative? apply)) +($check equal? (apply cons (list 1 2)) (cons 1 2)) +;; the underlying operative of list always returns its operand tree +;; so this is correct in kernel +($check eq? (apply list 3) 3) +;; the two argument case uses an empty environment +($check eq? (apply (wrap ($vau #ignore env ($binds? env $vau))) + #inert) + #f) + +($let ((empty-env (make-environment))) + ($check eq? + (apply (wrap ($vau #ignore env env)) #inert empty-env) + empty-env)) + +;; map +($check-predicate (applicative? map)) +($check equal? (map + (list 1 2 3 4)) (list 1 2 3 4)) +($check equal? (map cons (list 1 2 3 4) (list 10 20 30 40)) + (list (cons 1 10) (cons 2 20) (cons 3 30) (cons 4 40))) + +($let ((p (cons () ()))) + ($check eq? + ($sequence (map (wrap ($vau #ignore env + (set-car! p env))) + (list 1)) + (car p)) + (get-current-environment))) + +($let ((p (cons 0 ()))) + ($check eq? + ($sequence (map ($lambda (x) + (set-car! p (+ (car p) x))) + (list 1 2 3 4)) + (car p)) + 10)) + + +($check equal? + (map ($lambda (x) + (- 0 x)) + (list 1 . #0=(2 3 4 . #0#))) + (list -1 . #1=(-2 -3 -4 . #1#))) + +($check equal? + (map ($lambda ls + (finite-list? ls)) + . #0=((list 1 2 3 4) + (list 10 20 30 40) + . #0#)) + (list #f #f #f #f)) + + +;;; +;;; Error Checking and Robustness +;;; + +;; operative?, applicative? & combiner? +($check-error (operative? $vau . $cond)) +($check-error (applicative? wrap . unwrap)) +($check-error (combiner? $vau . wrap)) + +;; $vau +($check-error ($vau)) +($check-error ($vau #ignore)) +($check-error ($vau #ignore #ignore . #inert)) + +;; repeated symbols aren't allowed +($check-error ($vau (x x) #ignore x)) +;; same symbol in ptree and env aren't allowed either +($check-error ($vau (x) x x)) +;; this counts as repeating symbols +($check-error ($vau ((x . #0=(z)) (y . #0#)) #ignore (list x y z))) +;; cycles aren't allowed either (containing symbols or not) +($check-error ($vau (x . #0=(#ignore . #0#)) #ignore x)) + +($check-error ($vau #ignore #t #inert)) +($check-error ($vau #f #ignore #inert)) +($check-error ($vau #inert #inert #inert)) + +;; wrap +($check-error (wrap)) +($check-error (wrap $vau $vau)) +($check-error (wrap . #0=($vau . #0#))) + +($check-error (wrap 1)) +($check-error (wrap #t)) +($check-error (wrap #inert)) +($check-error (wrap #ignore)) +($check-error (wrap ())) +($check-error ($let/cc cont (wrap cont))) +($check-error (wrap (memoize #inert))) + +;; unwrap +($check-error (unwrap)) +($check-error (unwrap list list)) +($check-error (unwrap . #0=(list . #0#))) + +($check-error (unwrap 1)) +($check-error (unwrap #t)) +($check-error (unwrap #inert)) +($check-error (unwrap #ignore)) +($check-error ($let/cc cont (unwrap cont))) +($check-error (unwrap (memoize #inert))) + +;; $lambda +($check-error ($lambda)) +($check-error ($lambda #ignore . #inert)) + +;; repeated symbols aren't allowed +($check-error ($lambda (x x) x)) +;; this counts as repeating symbols +($check-error ($lambda ((x . #0=(z)) (y . #0#)) (list x y z))) +;; cycles aren't allowed either (containing symbols or not) +($check-error ($lambda (x . #0=(#ignore . #0#)) x)) + +($check-error ($lambda #t #inert)) +($check-error ($lambda #f #inert)) +($check-error ($lambda #inert #inert)) + +;; apply +($check-error (apply)) +($check-error (apply list)) +($check-error (apply list 1 (get-current-environment #inert))) +($check-error (apply . #0=(list 1 (get-current-environment) . #0#))) + +($check-error (apply (unwrap list) 1)) +($check-error (apply #ignore 1)) +($check-error (apply 1 1)) +($check-error (apply list 1 #inert)) +($check-error (apply list 1 1)) +($check-error (apply cons (list 1))) + +;; map +($check-error (map)) +;; the list can't be empty +($check-error (map list)) + +($check-error (map list (list 1 2) (list 1 2 3))) +($check-error (map list (list . #0=(1 2 . #0#)) (list 1 2 3))) + +($check-error (map list #inert)) +($check-error (map #inert (list 1 2))) +($check-error (map ((unwrap list) #inert) (list 1 2))) + +($check-error (map list (list 1 2) #inert)) +($check-error (map cons (list 1 2))) diff --git a/src/tests/control.k b/src/tests/control.k @@ -0,0 +1,199 @@ +;; check.k & test-helpers.k should be loaded + +;;; +;;; Basic Functionality +;;; + +;; inert? +($check-predicate (applicative? inert?)) +($check-predicate (inert?)) +($check-predicate (inert? #inert)) +($check-predicate (inert? #inert #inert #inert)) +($check-predicate (inert? #inert . #0=(#inert . #0#))) + +($check-not-predicate (inert? ((unwrap list) . symbol))) +($check-not-predicate (inert? ())) +($check-not-predicate (inert? (cons () ()))) +($check-not-predicate (inert? #ignore)) +($check-not-predicate (inert? (make-environment))) +($check-not-predicate (inert? #t)) +($check-not-predicate (inert? #f)) +($check-not-predicate (inert? $vau)) +($check-not-predicate (inert? wrap)) +($check-not-predicate (inert? (call/cc ($lambda (c) c)))) +($check-not-predicate (inert? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (inert? (memoize #inert))) +($check-not-predicate (inert? 1)) +;($check-not-predicate (inert? 1.0)) +($check-not-predicate (inert? #e+infinity)) +;($check-not-predicate (inert? #i+infinity)) +;($check-not-predicate (inert? #undefined)) +;($check-not-predicate (inert? #real-with-no-primary-value)) +($check-not-predicate (inert? "string")) +($check-not-predicate (inert? #\a)) +($check-not-predicate (inert? (get-current-input-port))) + +;; basic eq?-ness +($check eq? #inert #inert) + +;; basic equal?-ness and not? +($check equal? #inert #inert) + +;; $if +($check-predicate (operative? $if)) +($check eq? ($if #t #t #f) #t) +($check eq? ($if #f #t #f) #f) +($check eq? ($if #t (get-current-environment) #f) (get-current-environment)) +($check eq? ($if #f #t (get-current-environment)) (get-current-environment)) +($let ((p (cons () ()))) + ($check eq? ($if (($vau #ignore env + (set-car! p env) + #t)) (car p) #f) + (get-current-environment))) + +;; $sequence +($check-predicate (operative? $sequence)) +($check eq? ($sequence) #inert) +($check eq? ($sequence 1) 1) +($check eq? ($sequence 1 2 3) 3) +($check eq? ($sequence (get-current-environment)) (get-current-environment)) +($check eq? ($sequence #inert #inert (get-current-environment)) + (get-current-environment)) + +($let ((p (cons 0 ()))) + ($check eq? + ($let/cc cont + ($sequence . #0=(($if (=? (car p) 3) + (apply-continuation cont #t) + (set-car! p (+ (car p) 1))) + . #0#))) + #t)) + +;; $cond +($check-predicate (operative? $cond)) +($check eq? ($cond) #inert) +($check eq? ($cond (#f 1) (#f 2) (#f 3)) #inert) +($check eq? ($cond (#t 1) (#t 2) (#t 3)) 1) + +($check eq? ($cond (#t (get-current-environment))) (get-current-environment)) +($let ((p (cons () ()))) + ($check eq? + ($cond (#f) + (($sequence (set-car! p (get-current-environment)) + #t) + (car p)) + (#f)) + (get-current-environment))) +($check eq? ($cond . #0=((#f) (#t 1) . #0#)) 1) +($let ((p (cons 0 ()))) + ($check eq? + ($cond . #0=(((=? (car p) 3) 3) + (($sequence (set-car! p (+ (car p) 1)) + #f) + 0) + (#f) + . #0#)) + 3)) + + +;; for-each +($check-predicate (applicative? for-each)) +($check eq? (for-each + (list 1 2 3 4)) #inert) +($check eq? (for-each cons (list 1 2 3 4) (list 10 20 30 40)) #inert) +($let ((p (cons () ()))) + ($check eq? + ($sequence (for-each (wrap ($vau #ignore env + (set-car! p env))) + (list 1)) + (car p)) + (get-current-environment))) +($let ((p (cons 0 ()))) + ($check eq? + ($sequence (for-each ($lambda (x) + (set-car! p (+ (car p) x))) + (list 1 2 3 4)) + (car p)) + 10)) +($let ((p (cons 0 ()))) + ($check eq? + ($sequence (for-each ($lambda (x y ) + (set-car! p (+ (car p) x y))) + (list 1 2 3 4) + (list 10 20 30 40)) + (car p)) + 110)) + +($let ((p (cons 0 ()))) + ($check eq? + ($let/cc cont + (for-each ($lambda (x) + ($if (=? (car p) 10) + (apply-continuation cont 10) + (set-car! p (+ (car p) 1)))) + (list 1 . #0=(2 3 4 . #0#)))) + #inert)) + +($let ((p (cons 0 ()))) + ($check eq? + ($sequence (for-each ($lambda ls + (set-car! p (finite-list? ls))) + . #0=((list 1 2 3 4) + (list 10 20 30 40) + . #0#)) + (car p)) + #f)) + + +;;; +;;; Error Checking and Robustness +;;; + +;; inert? +($check-error (inert? #inert . #inert)) +($check-error (inert? #t . #inert)) + +;; $if +($check-error ($if)) +($check-error ($if #t)) + +;; this short form isn't allowed in Kernel +($check-error ($if #f #t)) +($check-error ($if #t #t)) + +($check-error ($if #t #t #t #t)) +($check-error ($if . #0=(#t . #0#))) + +($check-error ($if 0 #t #f)) +($check-error ($if () #t #f)) +($check-error ($if #inert #t #f)) +($check-error ($if #ignore #t #f)) +($check-error ($if (cons #t #f) #t #f)) +($check-error ($if (cons #t #f) #t #f)) + +;; $sequence +($check-error ($sequence . #inert)) +($check-error ($sequence #inert #inert . #inert)) + +;; $cond +($check-error ($cond . #inert)) +($check-error ($cond (#t #t) . #inert)) +($check-error ($cond #inert)) +($check-error ($cond (1 1) (#t #t))) + +;; for-each + +($check-error (for-each)) +;; the list can't be empty +($check-error (for-each list)) + +($check-error (for-each list (list 1 2) (list 1 2 3))) +($check-error (for-each list (list . #0=(1 2 . #0#)) (list 1 2 3))) + +($check-error (for-each list #inert)) +($check-error (for-each #inert (list 1 2))) +($check-error (for-each ((unwrap list) #inert) (list 1 2))) + +($check-error (for-each list (list 1 2) #inert)) +($check-error (for-each cons (list 1 2))) diff --git a/src/tests/environment-mutation.k b/src/tests/environment-mutation.k @@ -0,0 +1,8 @@ +;; check.k & test-helpers.k should be loaded + +;;; +;;; Basic Functionality +;;; + +;; environmen mutation +;; .... diff --git a/src/tests/environments.k b/src/tests/environments.k @@ -0,0 +1,9 @@ +;; check.k & test-helpers.k should be loaded + +;;; +;;; Basic Functionality +;;; + +;; environment +($check-predicate (applicative? environment?)) +;; .... diff --git a/src/tests/eq-equal.k b/src/tests/eq-equal.k @@ -0,0 +1 @@ +;; TODO +\ No newline at end of file diff --git a/src/tests/pair-mutation.k b/src/tests/pair-mutation.k @@ -0,0 +1,204 @@ +;; check.k & test-helpers.k should be loaded + +;;; +;;; Basic Functionality +;;; + +;; set-car! & set-cdr! +($let ((pair (cons () ()))) + ($check-predicate (inert? (set-car! pair 1))) + ($check-predicate (inert? (set-cdr! pair 2))) + ($check equal? (car pair) 1) + ($check equal? (cdr pair) 2) + (set-car! pair pair) + (set-cdr! pair pair) + ($check eq? (car pair) pair) + ($check eq? (cdr pair) pair)) + +;; copy-es-immutable +($let* ((orig (list (cons 1 2) (cons 3 4))) + (copy (copy-es-immutable orig)) + (copy2 (copy-es-immutable copy))) + ($check equal? orig copy) + ($check-predicate (mutable-pair? orig)) + ($check-predicate (immutable-pair? copy)) + ($check equal? orig copy2) + ($check-predicate (immutable-pair? copy2))) + +;; encycle! +($check equal? ($let ((l 1)) (encycle! l 0 0) l) + 1) +($check equal? ($let ((l (list 1 2 3 4 5))) (encycle! l 4 0) l) + (list 1 2 3 4 5)) +($check equal? ($let ((l (list 1 2 3 4 5))) (encycle! l 2 3) l) + (list 1 2 . #0=(3 4 5 . #0#))) +($check equal? ($let ((l (list* 1 2 3 4 5))) (encycle! l 0 3) l) + (list . #0=(1 2 3 . #0#))) + +;; append! +($let () + ($define! l1 (list 1 2)) + ($define! l2 (list 3 4)) + ($define! l3 (list 5 6)) + + ($check equal? ($sequence (append! l1 ()) l1) (list 1 2)) + ($check equal? ($sequence (append! l1 () ()) l1) (list 1 2)) + ($check equal? ($sequence (append! l1 l2) l1) (list 1 2 3 4)) + ($check equal? ($sequence (append! l1 () () l3 ()) l1) (list 1 2 3 4 5 6)) + + ($define! l1 (list 1 2)) + ($define! l2 (list 3 4)) + ($define! l3 (list . #0=(5 6 . #0#))) + + (append! l1 l2 l3) + ($check equal? l1 (list 1 2 3 4 . #2=(5 6 . #2#))) + ($check eq? (cddddr l1) l3) + + ($define! l1 (list 1 2)) + ($define! l2 (list 3 4)) + ($define! l3 (list 5 6)) + + ($check equal? + ($sequence (append! l1 . #3=(l2 l3 . #3#)) l1) + (list 1 2 . #4=(3 4 5 6 . #4#))) + + ($define! l1 (list 1 2)) + ($define! l2 (list 3 4)) + ($define! l3 (list 5 6)) + + ($check equal? + ($sequence (append! l1 l2 l3 . #5=(() () . #5#)) l1) + (list 1 2 3 4 5 6)) + + ($define! l1 (list 1 2)) + ($define! l2 (list 3 4)) + ($define! l3 (list 5 6)) + + ($check equal? + ($sequence (append! l1 () . #6=(() l2 () l3 () . #6#)) l1) + (list 1 2 . #7=(3 4 5 6 . #7#)))) + +;; copy-es +($let* ((orig (list (cons 1 2) (cons 3 4))) + (copy (copy-es orig))) + ($check equal? orig copy) + ($check-predicate (mutable-pair? orig)) + ($check-predicate (mutable-pair? copy)) + ($check not-eq? orig copy)) + +;; assq +($check equal? (assq #inert ()) ()) +($check equal? (assq 3 (list (list 1 10) (list 2 20))) ()) +($check equal? (assq 1 (list (list 1 10) (list 2 20))) (list 1 10)) +($check equal? + (assq 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))) + (list 1 10)) +($check equal? + (assq 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))) + ()) +($check equal? + (assq (list 1) (list (list (list 1) 1) (list (list 2) 2))) + ()) + +;; memq +($check-predicate (memq? 1 (list 1 2))) +($check-predicate (memq? 2 (list 1 2))) +($check-not-predicate (memq? 1 ())) +($check-not-predicate (memq? 3 (list 1 2))) +($check-not-predicate (memq? (list 1) (list (list 1) 2))) +($check-not-predicate (memq? (list 2) (list 1 (list 2)))) +($check-predicate + (memq? 3 (list . #0=(1 2 3 . #0#)))) +($check-not-predicate + (memq? 4 (list . #0=(1 2 1 . #0#)))) + + +;;; +;;; Error Checking and Robustness +;;; + +;; set-car! & set-cdr! +($check-error (set-car!)) +($check-error (set-car! (cons () ()))) +($check-error (set-car! (cons () ()) #inert #inert)) + +($check-error (set-car! () #inert)) +($check-error (set-car! 1 #inert)) +($check-error (set-car! (get-current-environment) #inert)) +($check-error (set-car! ($lambda #ignore) #inert)) +($check-error (set-car! ($vau #ignore #ignore) #inert)) + +($check-error (set-cdr!)) +($check-error (set-cdr! (cons () ()))) +($check-error (set-cdr! (cons () ()) #inert #inert)) + +($check-error (set-cdr! () #inert)) +($check-error (set-cdr! 1 #inert)) +($check-error (set-cdr! (get-current-environment) #inert)) +($check-error (set-cdr! ($lambda #ignore) #inert)) +($check-error (set-cdr! ($vau #ignore #ignore) #inert)) + +($let ((imm-pair (copy-es-immutable (cons () ())))) + ($check-error (set-car! imm-pair #inert)) + ($check-error (set-cdr! imm-pair #inert)) + ($check-predicate (null? (car imm-pair))) + ($check-predicate (null? (cdr imm-pair)))) + +;; copy-es-immutable +($check-error (copy-es-immutable)) +($check-error (copy-es-immutable (cons () ()) (cons () ()))) + +;; encycle! +($check-error (encycle!)) +($check-error (encycle! (list 1 2 3))) +($check-error (encycle! (list 1 2 3) 1)) +($check-error (encycle! (list 1 2 3) 1 2 3)) + +($check-error (encycle! (list 1 2 3) 2 2)) +($check-error (encycle! (list 1 2 3) -1 2)) +($check-error (encycle! (list 1 2 3) 0 -2)) +($check-error (encycle! (list 1 2 3) 0 #e+infinity)) + +;; append! +;; ASK does the report assert that the lists remains unmodified?? +;; probably should for robust implementations + +($check-error (append!)) +($check-error (append! ())) +($check-error (append! (list . #0=(1 2 . #0#)) ())) +($check-error (append! (list 1 2) 3 (list 4 5))) +($check-error (append! (list 1 2) 3 ())) + +($check-error (append! ((unwrap list) . (1 2 . #0=(3))) + ((unwrap list) . (4 5 . #0#)) + ())) + +;; ASK if this is valid or not +;; ($check-error (append! ((unwrap list) . (1 2 . #0=(3))) +;; ((unwrap list) . (4 5 . #0#)))) + + +;; copy-es +($check-error (copy-es)) +($check-error (copy-es (cons () ()) (cons () ()))) + +;; assq +($check-error (assq)) +($check-error (assq 2)) +($check-error (assq 2 (list (list 1 1) (list 2 2)) ())) +($check-error (assq . #0=(2 (list (list 1 1) (list 2 2)) . #0#))) + +($check-error (assq 2 (list* (list 1 1) 2))) +($check-error (assq 2 (list* (list 1 1) (list 2 2) #inert))) +($check-error (assq 4 (list (list 1 1) (list 2 2) #inert (list 4 4)))) +($check-error (assq 2 (list (list 1 1) (list 2 2) #inert (list 4 4)))) + +;; memq +($check-error (memq?)) +($check-error (memq? 2)) +($check-error (memq? 2 (list 1 2) ())) +($check-error (memq? . #0=(2 (list 1 2) . #0#))) + +($check-error (memq? 2 (list* 1 2))) +($check-error (memq? 2 (list* 1 2 3))) + diff --git a/src/tests/pairs-and-lists.k b/src/tests/pairs-and-lists.k @@ -0,0 +1,447 @@ +;; check.k & test-helpers.k should be loaded + +;; TODO use mutable-pair to verify that cons, list append etc construct with + +;;; +;;; Basic Functionality +;;; + +;; null? & pair? +($check-predicate (null?)) +($check-predicate (null? ())) +($check-predicate (null? () () ())) +($check-predicate (null? () . #0=(() . #0#))) + +($check-predicate (pair?)) +($check-predicate (pair? (cons () ()))) +($check-predicate (pair? (cons () ()) (copy-es-immutable (cons () ())) (cons () ()))) +($check-predicate (pair? (cons () ()) . #0=((copy-es-immutable (cons () ())) . #0#))) + +($check-not-predicate (null? #t)) +($check-not-predicate (null? ((unwrap list) . symbol))) +($check-not-predicate (null? (cons () ()))) +($check-not-predicate (null? #ignore)) +($check-not-predicate (null? (make-environment))) +($check-not-predicate (null? #inert)) +($check-not-predicate (null? $vau)) +($check-not-predicate (null? wrap)) +($check-not-predicate (null? (call/cc ($lambda (c) c)))) +($check-not-predicate (null? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (null? (memoize #inert))) +($check-not-predicate (null? 1)) +;($check-not-predicate (null? 1.0)) +($check-not-predicate (null? #e+infinity)) +;($check-not-predicate (null? #i+infinity)) +;($check-not-predicate (null? #undefined)) +;($check-not-predicate (null? #real-with-no-primary-value)) +($check-not-predicate (null? "string")) +($check-not-predicate (null? #\a)) +($check-not-predicate (null? (get-current-input-port))) + +($check-not-predicate (pair? #t)) +($check-not-predicate (pair? ((unwrap list) . symbol))) +($check-not-predicate (pair? ())) +($check-not-predicate (pair? #ignore)) +($check-not-predicate (pair? (make-environment))) +($check-not-predicate (pair? #inert)) +($check-not-predicate (pair? $vau)) +($check-not-predicate (pair? wrap)) +($check-not-predicate (pair? (call/cc ($lambda (c) c)))) +($check-not-predicate (pair? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (pair? (memoize #inert))) +($check-not-predicate (pair? 1)) +;($check-not-predicate (pair? 1.0)) +($check-not-predicate (pair? #e+infinity)) +;($check-not-predicate (pair? #i+infinity)) +;($check-not-predicate (pair? #undefined)) +;($check-not-predicate (pair? #real-with-no-primary-value)) +($check-not-predicate (pair? "string")) +($check-not-predicate (pair? #\a)) +($check-not-predicate (pair? (get-current-input-port))) + +;; basic eq?-ness +($check eq? () ()) +($let ((p (cons () ()))) + ($check eq? p p)) +($check not-eq? (cons () ()) (cons () ())) +($check not-eq? (cons () ()) ()) + +;; basic equal?-ness +($check equal? (cons () ()) (cons () ())) +($check equal? () ()) +($check not-equal? (cons () ()) (cons (cons () ()) ())) +($check not-equal? (cons () ()) ()) + +;; list & list* +($check equal? (list) ()) +($check equal? (list 1 2 3) (cons 1 (cons 2 (cons 3 ())))) +($check equal? ((unwrap list) 1 2 . 3) (list* 1 2 3)) +($check equal? ((unwrap list) . #inert) (list* #inert)) +($check equal? (list* #inert) #inert) +($check equal? (list* 1 2 3) (cons 1 (cons 2 3))) +($check equal? (list 1 . #0=(2 3 . #0#)) ((unwrap list) 1 . #0#)) + +;; car, cdr & co +($check equal? (car (cons 1 2)) 1) +($check equal? (cdr (cons 1 2)) 2) + +($let* ((tree2 (cons 1 2)) + (tree4 (cons tree2 (cons 3 4))) + (tree8 (cons tree4 (cons (cons 5 6) (cons 7 8)))) + (tree16 (cons tree8 (cons (cons (cons 9 10) (cons 11 12)) + (cons (cons 13 14) (cons 15 16)))))) + ($check eq? (car tree2) 1) + ($check eq? (cdr tree2) 2) + + ($check eq? (caar tree4) 1) + ($check eq? (cdar tree4) 2) + ($check eq? (cadr tree4) 3) + ($check eq? (cddr tree4) 4) + + ($check eq? (caaar tree8) 1) + ($check eq? (cdaar tree8) 2) + ($check eq? (cadar tree8) 3) + ($check eq? (cddar tree8) 4) + ($check eq? (caadr tree8) 5) + ($check eq? (cdadr tree8) 6) + ($check eq? (caddr tree8) 7) + ($check eq? (cdddr tree8) 8) + + ($check eq? (caaaar tree16) 1) + ($check eq? (cdaaar tree16) 2) + ($check eq? (cadaar tree16) 3) + ($check eq? (cddaar tree16) 4) + ($check eq? (caadar tree16) 5) + ($check eq? (cdadar tree16) 6) + ($check eq? (caddar tree16) 7) + ($check eq? (cdddar tree16) 8) + ($check eq? (caaadr tree16) 9) + ($check eq? (cdaadr tree16) 10) + ($check eq? (cadadr tree16) 11) + ($check eq? (cddadr tree16) 12) + ($check eq? (caaddr tree16) 13) + ($check eq? (cdaddr tree16) 14) + ($check eq? (cadddr tree16) 15) + ($check eq? (cddddr tree16) 16)) + +;; get-list-metrics +($check equal? (get-list-metrics ()) (list 0 1 0 0)) +($check equal? (get-list-metrics #inert) (list 0 0 0 0)) +($check equal? (get-list-metrics (list 1)) (list 1 1 1 0)) +($check equal? (get-list-metrics (list* 1 2)) (list 1 0 1 0)) +($check equal? (get-list-metrics (list 1 2 . #0=(3 4 5 . #0#))) (list 5 0 2 3)) +($check equal? (get-list-metrics (list . #0=(1 2 . #0#))) (list 2 0 0 2)) + +;; list-tail +($check equal? (list-tail (list 1 2 3 4 5) 0) (list 1 2 3 4 5)) +($check equal? (list-tail (list 1 2 3 4 5) 1) (list 2 3 4 5)) +($check equal? (list-tail (list* 1 2 3) 2) 3) +($check equal? (list-tail (list . #0=(1 2 3 4 5 . #0#)) 10) (list . #0#)) + +;; length +($check =? (length ()) 0) +($check =? (length "string") 0) ; in Kernel improper lists have length too +($check =? (length (list 1 2 3 4 5)) 5) +($check =? (length (list* 1 2 3 4 5 "string")) 5) +($check =? (length (list 1 2 . #0=(3 4 5 . #0#))) #e+infinity) + +;; list-ref +($check =? (list-ref (list 1 2 3 4 5) 0) 1) +($check =? (list-ref (list 1 2 3 4 5) 1) 2) +;; see ground/pairs-and-lists.scm for rationale on allowing +;; improper lists as argument to list-ref +($check =? (list-ref (list* 1 2 3 4) 2) 3) +($check =? (list-ref (list . #0=(1 2 3 4 5 . #0#)) 10) 1) + +;; append +($check equal? (append) ()) +($check equal? (append ()) ()) +($check equal? (append () ()) ()) +($check equal? (append (list 1 2 3) (list 4 5) (list 6)) (list 1 2 3 4 5 6)) +($check equal? (append (list 1 2) (list 3 4 5 6) ()) (list 1 2 3 4 5 6)) +($check equal? (append () (list 1) (list 2 3 4)) (list 1 2 3 4)) +($check equal? (append (list 1 2) (list 3 4) 5) (list* 1 2 3 4 5)) +($let ((l1 (list 1 2)) (l2 (list 3 4))) ; the last list isn't copied + ($check eq? (cddr (append l1 l2)) l2)) +($let ((l1 (list 1 2)) (l2 (list 3 4))) ; here the last list is copied + ($check not-eq? (cddr (append l1 l2 ())) l2)) +($check equal? + (append (list 1 2) (list 3 4) . #0=((list 5 6) . #0#)) + (list 1 2 3 4 . #1=(5 6 . #1#))) +($check equal? + (append () () . #0=(() (list 1 2) () . #0#)) + (list . #1=(1 2 . #1#))) +($check equal? + (append (list 1 2) (list 3 4) . #0=(() () . #0#)) + (list 1 2 3 4)) + +;; list-neighbors +($check equal? (list-neighbors ()) ()) +($check equal? (list-neighbors (list 1)) ()) +($check equal? (list-neighbors (list 1 2)) (list (list 1 2))) +($check equal? + (list-neighbors (list 1 2 3 4)) + (list (list 1 2) (list 2 3) (list 3 4))) +($check equal? + (list-neighbors (list . #0=(1 2 3 4 . #0#))) + (list . #1=((list 1 2) (list 2 3) (list 3 4) (list 4 1) . #1#))) +($check equal? + (list-neighbors (list 1 2 . #0=(3 4 . #0#))) + (list (list 1 2) (list 2 3) . #1=((list 3 4) (list 4 3) . #1#))) + +;; filter +($check equal? (filter number? ()) ()) +($check equal? (filter number? (list #t #f #t)) ()) +($check equal? (filter number? (list 1 2 3)) (list 1 2 3)) +($check equal? (filter number? (list 1 #t 2 #f)) (list 1 2)) +($check equal? + (filter number? (list 1 #t . #0=(2 #f . #0#))) + (list 1 . #1=(2 . #1#))) +($check equal? + (filter number? (list #t 1 #f . #0=(#t #f . #0#))) + (list 1)) +($check equal? + (filter number? (list #t #f . #0=(#t #f . #0#))) + ()) + +($check equal? ; filter should use an empty environment + (filter (wrap ($vau #ignore denv ($binds? denv $if))) + (list 1 2 3)) + ()) + +;; assoc +($check equal? (assoc #inert ()) ()) +($check equal? (assoc 3 (list (list 1 10) (list 2 20))) ()) +($check equal? (assoc 1 (list (list 1 10) (list 2 20))) (list 1 10)) +($check equal? + (assoc 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))) + (list 1 10)) +($check equal? + (assoc 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))) + ()) +($check equal? + (assoc (list 1) (list (list (list 1) 1) (list (list 2) 2))) + (list (list 1) 1)) + +;; member? +($check-predicate (member? 1 (list 1 2))) +($check-predicate (member? 2 (list 1 2))) +($check-not-predicate (member? 1 ())) +($check-not-predicate (member? 3 (list 1 2))) +($check-predicate (member? (list 1) (list (list 1) 2))) +($check-predicate (member? (list 2) (list 1 (list 2)))) +($check-predicate + (member? (list 1 3) (list . #0=(1 2 (list 1 3) . #0#)))) +($check-not-predicate + (member? 4 (list . #0=(1 2 1 . #0#)))) + +;; finite-list? +($check-predicate (finite-list? ())) +($check-predicate (finite-list? (list 1))) +($check-predicate (finite-list? (list 1 2))) +($check-predicate (finite-list? (list 1 2) (list 1 2 3) ())) +($check-predicate (finite-list? (list 1 2) . #0=((list 1 2 3) () . #0#))) +($check-not-predicate (finite-list? 1)) +($check-not-predicate (finite-list? () (list 1 2 . #0=(3 . #0#)))) +($check-not-predicate (finite-list? () 1)) +($check-not-predicate (finite-list? (list 1 2) . #0=(1 () . #0#))) + +;; countable-list? +($check-predicate (countable-list? ())) +($check-predicate (countable-list? (list 1 2))) +($check-predicate (countable-list? (list 1 . #0=(2 . #0#)))) +($check-predicate (countable-list? (list 1 2) (list 1 . #0=(2 . #0#)) ())) +($check-predicate (countable-list? + () . #0=((list 1 . #1=(2 . #1#)) () . #0#))) + +($check-not-predicate (countable-list? 1)) +($check-not-predicate (countable-list? () 1)) +($check-not-predicate (countable-list? (list 1 2) . #0=(#inert () . #0#))) +($check-not-predicate (countable-list? + () . #0=((list 1 . #1=(2 . #1#)) 3 . #0#))) + +;; reduce +($let ((ac-+ ($lambda ls (reduce ls + 0))) + (c-+ +;; the idea of the cycle treatment is to carry a flag indicating +;; if all elements so far in the cycle were actually zero, if so +;; the sum of the cycle is zero otherwise it can be undefined or +;; (* +infinity (acyclic-sum)) which in the integer case is +infinity +;; or -infinity + ($let ((precycle ($lambda (x) + (cons x (zero? x)))) + (incycle ($lambda ((x . x-zero?) (y . y-zero?)) + (cons (+ x y) + (and? x-zero? y-zero?)))) + (postcycle ($lambda ((result . all-zero?)) + ($if all-zero? + 0 + (* #e+infinity result))))) + ($lambda ls + (reduce ls + 0 precycle incycle postcycle))))) + ($check equal? (ac-+) 0) + ($check equal? (ac-+ 1) 1) + ($check equal? (ac-+ 1 2) 3) + ($check equal? (ac-+ 1 2 3) 6) + + ($check equal? (c-+) 0) + ($check equal? (c-+ 1) 1) + ($check equal? (c-+ 1 2) 3) + ($check equal? (c-+ 1 2 . #0=(0 0 . #0#)) 3) + ($check equal? (c-+ 1 2 . #2=(-3 -4 . #2#)) #e-infinity)) + + +;;; +;;; Error Checking and Robustness +;;; + +;; null? & pair? +($check-error (null? () . #inert)) +($check-error (pair? (cons () ()) . #inert)) + +;; list & list* +($check-error (list #inert . 1)) +($check-error (list* . 1)) +($check-error (list*)) +($check-error (list* 1 #0=(2 3 . #0#))) + +;; car, cdr & co +($check-error (car)) +($check-error (cdr)) +($check-error (car ())) +($check-error (cdr ())) +($check-error (car 1)) +($check-error (cdr 1)) +($check-error (car (cons 1 2) (cons 3 4))) +($check-error (cdr (cons 1 2) (cons 3 4))) + +($let* ((tree2 (cons 1 2)) + (tree4 (cons tree2 (cons 3 4))) + (tree8 (cons tree4 (cons (cons 5 6) (cons 7 8))))) + ($check-error (caar tree2)) + ($check-error (cdar tree2)) + ($check-error (cadr tree2)) + ($check-error (cddr tree2)) + + ($check-error (caaar tree4)) + ($check-error (cdaar tree4)) + ($check-error (cadar tree4)) + ($check-error (cddar tree4)) + ($check-error (caadr tree4)) + ($check-error (cdadr tree4)) + ($check-error (caddr tree4)) + ($check-error (cdddr tree4)) + + ($check-error (caaaar tree8)) + ($check-error (cdaaar tree8)) + ($check-error (cadaar tree8)) + ($check-error (cddaar tree8)) + ($check-error (caadar tree8)) + ($check-error (cdadar tree8)) + ($check-error (caddar tree8)) + ($check-error (cdddar tree8)) + ($check-error (caaadr tree8)) + ($check-error (cdaadr tree8)) + ($check-error (cadadr tree8)) + ($check-error (cddadr tree8)) + ($check-error (caaddr tree8)) + ($check-error (cdaddr tree8)) + ($check-error (cadddr tree8)) + ($check-error (cddddr tree8))) + +;; get-list-metrics +($check-error (get-list-metrics)) +($check-error (get-list-metrics () ())) + +;; list-tail +($check-error (list-tail)) +($check-error (list-tail (list 1 2 3))) +($check-error (list-tail (list 1 2 3) 3 4)) +($check-error (list-tail (list 1 2 3) 4)) +($check-error (list-tail (list 1 2 3) #e+infinity)) +;($check-error (list-tail (list 1 2 3) 3.4)) +($check-error (list-tail (list 1 2 3) -1)) +($check-error (list-tail (list 1 2 3) #f)) + +;; length +($check-error (length)) +($check-error (length () ())) +($check-error (length . #0=(() . #0#))) + +;; list-ref +($check-error (list-ref)) +($check-error (list-ref (list 1 2 3))) +($check-error (list-ref (list 1 2 3) 3 4)) +($check-error (list-ref (list 1 2 3) 4)) +($check-error (list-ref (list 1 2 3) #e+infinity)) +;($check-error (list-ref (list 1 2 3) 3.4)) +($check-error (list-ref (list 1 2 3) -1)) +($check-error (list-ref (list 1 2 3) #f)) + +;; append +($check-error (append (list 1 2) (list . #0=(3 4 . #0#)) (list 5 6))) +($check-error (append (list . #0=(1 2 . #0#)) ())) +($check-error (append (list 1 2) 3 (list 4 5))) +($check-error (append (list 1 2) 3 ())) + +;; list-neighbors +($check-error (list-neighbors)) +($check-error (list-neighbors (list 1 2) (list 3 4))) +($check-error (list-neighbors 1)) +($check-error (list-neighbors (list* 1 2 3 4))) + +;; filter +($check-error (filter)) +($check-error (filter number?)) +($check-error (filter (list 1))) +($check-error (filter number? #inert)) +($check-error (filter number? (list* 1 2 3))) +($check-error (filter number? (list 1 2 3) #inert)) +($check-error (filter (unwrap number?) (list 1 2 3))) +($check-error (filter + (list 1 2 3))) +($check-error (filter car (list 1 2 3))) + +;; asooc +($check-error (assoc)) +($check-error (assoc 2)) +($check-error (assoc 2 (list (list 1 1) (list 2 2)) ())) +($check-error (assoc . #0=(2 (list (list 1 1) (list 2 2)) . #0#))) + +($check-error (assoc 2 (list* (list 1 1) 2))) +($check-error (assoc 2 (list* (list 1 1) (list 2 2) #inert))) +($check-error (assoc 4 (list (list 1 1) (list 2 2) #inert (list 4 4)))) +($check-error (assoc 2 (list (list 1 1) (list 2 2) #inert (list 4 4)))) + +;; member? +($check-error (member?)) +($check-error (member? 2)) +($check-error (member? 2 (list 1 2) ())) +($check-error (member? . #0=(2 (list 1 2) . #0#))) + +($check-error (member? 2 (list* 1 2))) +($check-error (member? 2 (list* 1 2 3))) + +;; finite-list? +($check-error (countable-list? (cons () ()) . #inert)) + +;; countable-list? +($check-error (countable-list? (list . #0=(1 . #0#)) . #inert)) + +;; reduce +($check-error (reduce)) +($check-error (reduce (list 1 2))) +($check-error (reduce (list 1 2) +)) +($check-error (reduce #inert + 0)) +($check-error (reduce (list 1 2) #inert 0)) +($check-error (reduce (list 1 2 #0=(3 . #0#)) + 0)) + +($check-error (reduce (list 1 2 #0=(3 . #0#)) + 0 +)) +($check-error (reduce (list 1 2 #0=(3 . #0#)) + 0 + +)) +($check-error (reduce (list 1 2 #0=(3 . #0#)) + 0 + + + +)) +($check-error (reduce (list 1 2 #0=(3 . #0#)) + 0 + + #inert)) +($check-error (reduce (list 1 2 #0=(3 . #0#)) + 0 + #inert +)) +($check-error (reduce (list 1 2 #0=(3 . #0#)) + 0 #inert + +)) diff --git a/src/tests/symbols.k b/src/tests/symbols.k @@ -0,0 +1,38 @@ +;; check.k & test-helpers.k should be loaded + +;;; +;;; Basic Functionality +;;; + +;; symbol? +($check-predicate (applicative? symbol?)) + +($let (($qs ($vau (s) #ignore s))) + ($let ((s1 ($qs s1)) + (s2 ($qs s2)) + (s3 ($qs s3))) + ($check-predicate (symbol?)) + ($check-predicate (symbol? s1)) + ($check-predicate (symbol? s1 s2 s3)) + ($check-predicate (symbol? s1 . #0=(s2 . #0#))))) + +($check-not-predicate (symbol? ())) +($check-not-predicate (symbol? (cons () ()))) +($check-not-predicate (symbol? #ignore)) +($check-not-predicate (symbol? (make-environment))) +($check-not-predicate (symbol? #inert)) +($check-not-predicate (symbol? wrap)) +($check-not-predicate (symbol? (call/cc ($lambda (c) c)))) +($check-not-predicate (symbol? ($let (((enc . #ignore) + (make-encapsulation-type))) + (enc #inert)))) +($check-not-predicate (symbol? (memoize #inert))) +($check-not-predicate (symbol? 1)) +;($check-not-predicate (symbol? 1.0)) +($check-not-predicate (symbol? #e+infinity)) +;($check-not-predicate (symbol? #i+infinity)) +;($check-not-predicate (symbol? #undefined)) +;($check-not-predicate (symbol? #real-with-no-primary-value)) +($check-not-predicate (symbol? "string")) +($check-not-predicate (symbol? #\a)) +($check-not-predicate (symbol? (get-current-input-port))) diff --git a/src/tests/test-all.k b/src/tests/test-all.k @@ -0,0 +1,18 @@ +(load "tests/check.k") +(load "tests/test-helpers.k") + +;(check-set-mode! check-mode-report) + +;; TODO add applicative?/operative? check in boolean, eq/equal, pairs and lists and pair-mutation + +(load "tests/booleans.k") +(load "tests/eq-equal.k") +(load "tests/symbols.k") +(load "tests/control.k") +(load "tests/pairs-and-lists.k") +(load "tests/pair-mutation.k") +(load "tests/environments.k") +(load "tests/environment-mutation.k") +(load "tests/combiners.k") + +(check-report) +\ No newline at end of file diff --git a/src/tests/test-helpers.k b/src/tests/test-helpers.k @@ -0,0 +1,27 @@ +;;; +;;; Some helpers used in many modules +;;; (check.k should be loaded) +;;; + +($define! not-eq? ($lambda (x y) (not? (eq? x y)))) +($define! not-equal? ($lambda (x y) (not? (equal? x y)))) +($define! $check-predicate ($vau (x) denv (eval (list $check eq? x #t) denv))) +($define! $check-not-predicate ($vau (x) denv (eval (list $check eq? x #f) denv))) + +($define! mutable-pair? + ($lambda (obj) + ($and? (pair? obj) + (guard-dynamic-extent + () + ($lambda () + (set-car! obj (car obj)) + #t) + ;; As per the report (section 4.7.1) setting the car of an + ;; immutable pair (even if the value is the same) should + ;; signal an error. + (list (list error-continuation + ($lambda (#ignore divert) + (apply divert #f)))))))) + +($define! immutable-pair? + ($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj))))) +\ No newline at end of file