;;;; File: tests/run.scm ;;;; Author: Juergen Lorenz ;;;; ju (at) jugilo (dot) de (require-library bindings arrays basic-sequences simple-tests simple-exceptions) (import simple-tests bindings basic-sequences simple-exceptions ;(only basic-sequences seq-db) (only arrays array array? array-ref array-tail array->list) ) (define-test (binds?) (check (= (bind a 1 a) 1) (= (bind (a ()) (list 1 "") a) 1) (equal? (bind (a b) '(1 2) (where (a odd?)) (list a b)) '(1 2)) (equal? (bind (x . y) '#(1 2 3 4) (list x y)) '(1 #(2 3 4))) (equal? (bind (_ . y) '#(1 2 3 4) y) '#(2 3 4)) (equal? (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4) (list x y z u v w)) '(1 2 #\f #\o "o" 4)) (equal? (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4) (list x y z u w)) '(1 2 #\f #\o 4)) (equal? (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y)) '(1 2)) (equal? (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y)) '(1 2)) (equal? (bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons #f #f)) 5 6) (list x y z u v w)) '(1 2 #f #f 5 #(6))) (equal? (bind (x (y (#f . u)) v . w) (vector 1 (list 2 (cons (odd? 4) #f)) 5 6) (list x y u v w)) '(1 2 #f 5 #(6))) (equal? (bind (x (y (z . u)) v . w) '#(1 (2 (3 . 4)) 5 6) (list x y z u v w)) '(1 2 3 4 5 #(6))) (equal? (bind-named loop (x (a . b) y) '(5 #(1) 0) (where (x integer?)) (if (zero? x) (list x a b y) (loop (list (- x 1) (cons a (cons a b)) (+ y 1))))) '(0 1 (1 1 1 1 1 . #()) 5)) (equal? (bind-named loop (x y) #(5 0) (where (x integer?)) (if (zero? x) (vector x y) (loop (vector (- x 1) (+ y 1))))) '#(0 5)) "LITERALS" (equal? (bind (#f . ys) '(#f 2 3) ys) '(2 3)) (not (condition-case (bind (#f . ys) '(#t 2 3) ys) ((exn sequence) #f))) (bind #f #f #t) (not (condition-case (bind #f #t #t) ((exn sequence) #f))) (not (condition-case (bind (x . #f) '(1 . #t) x) ((exn sequence) #f))) (equal? (bind (x (y . #f)) '(1 (2 . #f)) (list x y)) '(1 2)) (not (condition-case (bind (x (y . #f)) '(1 (2 . #t)) (list x y)) ((exn sequence) #f))) (equal? (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y)) '(1 2)) (not (condition-case (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y)) ((exn sequence) #f))) (not (condition-case (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y)) ((exn sequence) #f))) (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z)) "ADD ARRAYS TO GENERIC SEQUENCES" (seq-db array? ref: array-ref tail: array-tail maker: array ra?: #t) (equal? (bind (x y z) (array 1 2 3) (list x y z)) '(1 2 3)) (equal? (bind (x (y z)) (vector 0 (array 1 2)) (list x y z)) '(0 1 2)) (equal? (bind (x (y . z)) (vector 0 (array 1 2 3 4)) (list x y (array->list z))) '(0 1 (2 3 4))) )) (define-test (predicates?) (check (not ((bindable? (x)) '(name 1))) (not ((bindable? (x y) (where (x number?))) '(name 1))) ((bindable? (_ x)) '(name 1)) (not ((bindable? (_ x)) '(name 1 2))) ((bindable? (a b) (where (a odd?))) '#(1 2)) (not ((bindable? (x (y z)) (where (y char-alphabetic?))) '(1 "23"))) ((bindable? (x (y . z))) '(1 "23")) ((bindable? (x y)) '(1 "23")) (not ((bindable? (a (b . C) . d)) '(1 2 3 4 5))) (not ((bindable? (a)) 1)) )) (define-test (cases?) (check (not (bind-case #() (() #f))) (equal? (bind-case #(2 2) ((a b) (where (a even?) (b odd?)) (print 'even-odd a b)) ((a b) (where (a odd?) (b even?)) (print 'odd-even a b)) ((a b) (list a b))) '(2 2)) (equal? (bind-case '(1 "2 3") ((x (y z)) (list x y z)) ((x (y . z)) (list x y z)) ((x y) (list x y))) '(1 #\2 " 3")) (equal? (bind-case '(1 "23") ((x (y z)) (where (y char-alphabetic?)) (list x y z)) ((x (y . z)) (list x y z)) ((x y) (list x y))) '(1 #\2 "3")) (equal? (bind-case '(1 "23") ((x (y z)) (where (y char-alphabetic?)) (list x y z)) ((x (y . _)) (list x y)) ((x y) (list x y))) '(1 #\2)) (equal? (bind-case '(1 "23") ((x (y z)) (where (y char-numeric?)) (list x y z)) ((x (y . z)) (list x y z)) ((x y) (list x y))) '(1 #\2 #\3)) (equal? (bind-case '(1 "23") ((x (y z)) (list x y z)) ((x (y . z)) (list x y z)) ((x y) (list x y))) '(1 #\2 #\3)) (equal? (bind-case '(1 "2 3") ; ((x (y . z)) (list x y z)) ((x (y z)) (list x y z)) ((x y) (list x y))) '(1 #\2 " 3")) (equal? (bind-case '(1 #(2 3)) ((x y) (where (y list?)) (list x y)) ((x (y . z)) (list x y z)) ((x (y z)) (list x y z))) '(1 2 #(3))) (equal? (bind-case '(1 (2 3)) ((x y) (list x y)) ((x (y . z)) (list x y z)) ((x (y z)) (list x y z))) '(1 (2 3))) (equal? (bind-case '(1 (2 . 3)) ((x y) (list x y)) ((x (y . z)) (list x y z)) ((x (y z)) (list x y z))) '(1 (2 . 3))) (equal? (bind-case '#(1 2) (() '()) ((a) (list a)) ((a b) (list a b)) ((a b C) (list a b C))) '(1 2)) "LOCAL VARIABLES IN ALL RULES" (define (my-map fn lst) (let loop ((lst lst) (result '())) (bind-case lst (() (reverse result)) ((x . xs) (loop xs (cons (fn x) result)))))) (equal? (my-map add1 '(0 1 2 3)) '(1 2 3 4)) (define (vector-map fn vec) (let* ((len (vector-length vec)) (result (make-vector len #f))) (let loop ((vec vec)) (bind-case vec (() result) ((x . xs) (vector-set! result (- len (vector-length xs) 1) (fn x)) (loop (subvector vec 1))))))) (equal? (vector-map add1 #(0 1 2 3)) #(1 2 3 4)) (define (vector-reverse vec) (let ((result (make-vector (vector-length vec) #f))) (let loop ((vec vec)) (bind-case vec (() result) ((x . xs) (vector-set! result (vector-length xs) x) (loop (subvector vec 1))))))) (equal? (vector-reverse #(0 1 2 3)) #(3 2 1 0)) "NON-SYMBOL LITERALS" (bind-case #("a") ((#f) #f) (("a") #t)) (equal? (bind-case (vector 1 (list (odd? 2) 3)) ((x y) (where (y number?)) (list x y)) ((x ("y" . z)) (list x z)) ((x (#f z)) (list x z))) '(1 3)) (equal? (bind-case '(1 (#f 3)) ((x y) (list x y)) ((x ("y" . z)) (list x z)) ((x (#f z)) (list x z))) '(1 (#f 3))) (equal? (bind-case #(1 ("y" 3)) ((x ("y" . z)) (list x z)) ((x (#f z)) (list x z))) '(1 (3))) )) (define-test (lambdas?) (check (equal? ((bind-lambda (a (b . C) . d) (list a b C d)) '(1 #(20 30 40) 2 3)) '(1 20 #(30 40) (2 3))) (equal? ((bind-lambda* ((a (b . C) . d) (e . f)) (list a b C d e f)) '(1 #(20 30 40) 2 3) '#(4 5 6)) '(1 20 #(30 40) (2 3) 4 #(5 6))) (equal? ((bind-case-lambda ((e . f) (where (e zero?)) f) ((e . f) (list e f))) '#(0 2 3 4 5)) '#(2 3 4 5)) (equal? ((bind-case-lambda ((e . f) (where (e zero?)) e) ((a (b . #f) . d) (list a b d)) ((e . f) (list e f))) '(1 (2 . #f) 4 5)) '(1 2 (4 5))) (equal? ((bind-case-lambda ((e . f) (where (e zero?)) e) ((a (b . #f) . d) (list a b d)) ((e . f) (list e f))) ; match '(1 (2 . #t) 4 5)) '(1 ((2 . #t) 4 5))) (not (condition-case ((bind-case-lambda ((e . f) (where (e zero?)) e) ((a (b . #f) . d) (list a b d))) '(1 (2 . #t) 4 5)) ((exn sequence) #f))) (equal? ((bind-case-lambda ((e . f) (where (e zero?)) e) ((a (b "c") . d) (list a b d)) ((e . f) (list e f))) '(1 (2 "c") 4 5)) '(1 2 (4 5))) (equal? ((bind-case-lambda ((a (b . C) . d) (where (a integer?)) (list a b C d)) ((e . f) (list e f))) '(1 #(2 3 4) 5 6)) '(1 2 #(3 4) (5 6))) (equal? ((bind-case-lambda ((a (b . C) . d) (where (a string?)) (list a b C d)) ((e . f) (list e f))) '(1 #(2 3 4) 5 6)) '(1 (#(2 3 4) 5 6))) (equal? ((bind-case-lambda* (((a b C . d) (e . f)) (list a b C d e f))) '(1 2 3) #(4 5 6)) '(1 2 3 () 4 #(5 6))) (equal? ((bind-case-lambda* (((a (b . C) . d) (e . f)) (list a b C d e f))) '(1 #(20 30 40) 2 3) '(4 5 6)) '(1 20 #(30 40) (2 3) 4 (5 6))) )) (define-test (lets?) (check (equal? (bind-let ( (((x y) z) '(#(1 2) 3)) (u (+ 2 2)) ((v w) #(5 6)) ) (where (u integer?)) (list x y z u v w)) '(1 2 3 4 5 6)) (equal? (bind-named loop (a b) '(5 0) (if (zero? a) (list a b) (loop (list (- a 1) (+ b 1))))) '(0 5)) (equal? (bind-let loop ( ((a b) '(5 0)) ) (where (a integer?)) (if (zero? a) (list a b) (loop (list (- a 1) (+ b 1))))) '(0 5)) (equal? (bind-let loop ( ((x . y) '(1 2 3)) ((z) #(10)) ) (where (x integer?) (y (list-of? integer?)) (z integer?)) (if (zero? z) (list x y z) (loop (cons (+ x 1) (map add1 y)) (list (- z 1))))) '(11 (12 13) 0)) (equal? (bind-let* ( (((x y) z) '(#(1 2) 3)) (u (+ 1 2 x)) ((v w) (list (+ z 2) 6)) ) (where (u integer?)) (list x y z u v w)) '(1 2 3 4 5 6)) (equal? (bindrec ((o?) e?) (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1))))) (lambda (n) (if (zero? n) #t (o? (- n 1))))) (where (o? procedure?) (e? procedure?)) (list (o? 95) (e? 95))) '(#t #f)) (equal? (bind-letrec ( ((o? (e?)) (list (lambda (m) (if (zero? m) #f (e? (- m 1)))) (vector (lambda (n) (if (zero? n) #t (o? (- n 1))))))) ) (where (o? procedure?) (e? procedure?)) (list (o? 95) (e? 95))) '(#t #f)) )) (define-test (defines?) (check (equal? (let ((x #f) (y #f) (z #f)) (bind-set! (x (y . z)) '(1 #(2 3 3))) (list x y z)) '(1 2 #(3 3))) (equal? (let ((x #f) (y #f) (z #f)) (bind-set! (x #f _ (y _ . z)) '(1 #f 10 #(2 30 3 3))) (list x y z)) '(1 2 #(3 3))) (equal? (let ((x #f) (y #f) (z #f)) (bind-set! x 1 y 2 z 3) (list x y z)) '(1 2 3)) (equal? (let ((x #f) (y #f) (z #f) (u #f) (v #f)) (bind-set! (x (y . z)) '(1 #(2 3 3)) (u (v)) '(10 (20)) (where (x integer?) (u number?))) (list x y z u v)) '(1 2 #(3 3) 10 20)) (equal? (let ((x #f) (y #f) (z #f)) (bind-set! (x (y . z)) '(1 #(2 3 3)) (where (x integer?))) (list x y z)) '(1 2 #(3 3))) (equal? (begin (define stack #f) (define push! #f) (define pop! #f) (bind-set! (stack (push! pop!)) (list '() (vector (lambda (xpr) (set! stack (cons xpr stack))) (lambda () (set! stack (cdr stack))))) (where (push! procedure?) (pop! procedure?))) (push! 1) (push! 0) stack) '(0 1)) (equal? (begin (bind-define (plus5 times5) (let ((a 5)) (list (lambda (x) (+ x a)) (lambda (x) (* x a))))) (list (plus5 6) (times5 6))) '(11 30)) (equal? (begin (bind-define (x . y) '(1 . 2) ((z)) '((3)) (where (x integer?))) (list x y z)) '(1 2 3)) (equal? (begin (bind-define (x _ . y) '(1 10 . 2) ((z)) '((3)) (where (x integer?))) (list x y z)) '(1 2 3)) (equal? (begin (bind-define (x #f . y) '(1 #f . 2) ((z)) '((3))) (list x y z)) '(1 2 3)) (equal? (begin (bind-define x 1 y 2 z 3 (where (x integer?))) (list x y z)) '(1 2 3)) (equal? (begin (bind-define (push top pop) (let ((lst '())) (vector (lambda (xpr) (set! lst (cons xpr lst))) (lambda () (car lst)) (lambda () (set! lst (cdr lst))))) (where (push procedure?) (top procedure?) (pop procedure?))) (push 0) (push 1) (pop) (top)) 0) (equal? (begin (bind-define (x (_ y (z _))) '(1 #(2 3 (4 5)))) (list x y z)) '(1 3 4)) (equal? (begin (bind-define (x (#f y (z #t))) (list 1 (vector (odd? 2) 3 (list 4 (odd? 5)))) (where (x integer?))) (list x y z)) '(1 3 4)) )) (define-test (types?) (check "LISTS AS ALGEBRAIC TYPE" (define-algebraic-type LIST List? (Nil) (Cons (x) (xs List?))) (define (List->list lst) (bind-case (<< lst List?) ((#:Nil) '()) ((#:Cons x xs) (cons x (List->list xs))))) (define three (Cons 0 (Cons 1 (Cons 2 (Nil))))) (equal? (List->list three) '(0 1 2)) "TYPED VECTORS AS ALGEBRAIC TYPE" (define-algebraic-type VEC Vec? (Vec (x integer?) xs integer?)) (define (Vec->list vec) (bind (#:Vec x . xs) (<< vec Vec?) (cons x (vector->list (subvector xs 1))))) (define four (Vec 0 1 2 3)) (equal? (Vec->list four) '(0 1 2 3)) "TYPED TREES AS ALGEBRAIC TYPE" (define-algebraic-type TREE Tree? (Leaf (b number?)) (Node (left Tree?) (t number?) (right Tree?))) (define (leaf-sum tr) (bind-case (<< tr Tree?) ((#:Leaf b) b) ((#:Node left middle right) (+ (leaf-sum left) middle (leaf-sum right))))) (define tree (Node (Leaf 1) 2 (Leaf 3))) (= (leaf-sum tree) 6) )) (compound-test (BINDINGS) (binds?) (predicates?) (cases?) (lambdas?) (lets?) (defines?) (types?) )