;;; File: tests/run.scm ;;; Author: Juergen Lorenz ;;; ju (at) jugilo (dot) de (import simple-tests bindings (chicken base) (chicken condition) ) (define-checks (listify? verbose?) (begin ;; reset internal database (bind-listify*) ;; add support for vectors and strings (bind-listify* vector? vector-car vector-cdr) (bind-listify* string? string-car string-cdr) #t) #t (bind-listify* "x") (list string-car string-cdr) (bind-listify* 'a 1) '(1) (bind-listify* '(a . as) #(1 2 3)) '(1 #(2 3)) (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3)) '(1 (2) 3) (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50)) '(1 (2 (3 (300)) 4) #(50)) (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5)) '(1 (30) 5) (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5)) '(1 (30) (5)) (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5)) '(1 (30) (5)) (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5)) '(1 (#\y) (5)) (bind-listify* '(x) "x") '(#\x) (bind-listify* '(x . y) "xyz") '(#\x "yz") (bind-listify* 'x 1) '(1) (bind-listify* '(x) #(1)) '(1) (bind-listify* '(x . y) #(1 2 3)) '(1 #(2 3)) (bind-listify* '(#f ()) #(#f #())) '(()) (bind-listify* '(as ... b c) '(1 2 3 40 50)) '((1 2 3) 40 50) (bind-listify* '(as ... b c) '(40 50)) '(() 40 50) (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50)) '(-2 -1 (1 2 3) 40 50) (bind-listify* '(x y as ... b c) '(-2 -1 40 50)) '(-2 -1 () 40 50) (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5)) '(((1 10) ((2 20) (3 30))) 4 5) (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5)) '(-1 0 ((1 10) ((2 20) (3 30))) 4 5) (bind-listify* '(x y (as (bs cs)) ... d e) #(-1 0 (1 (2 3)) (10 (20 30)) 4 5)) '(-1 0 ((1 10) ((2 20) (3 30))) 4 5) (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) #(10 (20 30)) 4 5)) '(-1 0 ((1 10) ((2 20) (3 30))) 4 5) (bind-listify* '(x y (as (bs (cs))) ... d e) '(-1 0 (1 (2 (3))) #(10 (20 (30))) 4 5)) '(-1 0 ((1 10) ((2 20) ((3 30)))) 4 5) ) ;(listify?) (define-checks (lists-only? verbose?) (begin ;; reset internal database (bind-listify*) #t) #t ;; this would work with string support: (condition-case (bind (x) "x" x) ((exn) #f)) #f (bind-list (a b) '(1 2) (list a b)) '(1 2) (bind-list (x (y (z))) '(1 (2 (3))) (list x y z)) '(1 2 3) (let ((x #f) (y #f)) (bind-list (x y) '(1 2)) (and (= x 1) (= y 2))) #t (let ((x #f) (y #f)) (bind-list (x (y)) '(1 (2))) (and (= x 1) (= y 2))) #t (let ((lst '())) (bind-list (push top pop) (list (lambda (xpr) (set! lst (cons xpr lst))) (lambda () (car lst)) (lambda () (set! lst (cdr lst)))) (push 0) (push 1) (pop) (top))) 0 (let () (bind-list! (u v w)) (and (eq? u 'u) (eq? v 'v) (eq? w 'w))) #t ) ;(lists-only?) (define stack #f) (define push! #f) (define pop! #f) (define-checks (defines? verbose?) (begin ;; reset internal database (bind-listify*) ;; add support for vectors and strings (bind-listify* vector? vector-car vector-cdr) (bind-listify* string? string-car string-cdr) #t) #t (let ((x #f) (y #f) (z #f)) (bind! (x (y . z)) '(1 #(2 3 3))) (list x y z)) '(1 2 #(3 3)) (let ((x #f) (y #f) (z #f)) (bind! (x #f _ (y _ . z)) '(1 #f 10 #(2 30 3 3))) (list x y z)) '(1 2 #(3 3)) (let ((x #f) (y #f) (z #f)) (bind! x 1) (bind! y 2) (bind! z 3) (list x y z)) '(1 2 3) (let ((x #f) (y #f) (z #f) (u #f) (v #f)) (bind! (x (y . z)) '(1 #(2 3 3))) (bind! (u (v)) '(10 (20))) (list x y z u v)) '(1 2 #(3 3) 10 20) (let ((x #f) (y #f) (z #f)) (bind! (x (y . z)) '(1 #(2 3 3))) (list x y z)) '(1 2 #(3 3)) (let ((state #f) (push! #f) (pop! #f)) (bind! (state (push! pop!)) (list '() (vector (lambda (xpr) (set! state (cons xpr state))) (lambda () (set! state (cdr state)))))) (push! 1) (push! 0) state) '(0 1) (begin (bind! (plus5 times5) (let ((a 5)) (list (lambda (x) (+ x a)) (lambda (x) (* x a))))) (list (plus5 6) (times5 6))) '(11 30) (begin (bind! (x . y) '(1 . 2)) (list x y)) '(1 2) (begin (bind! (x _ . y) '(1 10 . 2)) (list x y)) '(1 2) (begin (bind! (x #f . y) '(1 #f . 2)) (list x y)) '(1 2) (begin (let ((lst '())) (bind! (push top pop) (vector (lambda (xpr) (set! lst (cons xpr lst))) (lambda () (car lst)) (lambda () (set! lst (cdr lst)))))) (push 0) (push 1) (pop) (top)) 0 (begin (bind! (x (_ y (z _))) '(1 #(2 3 (4 5)))) (list x y z)) '(1 3 4) (begin (bind! (x (#f y (z #t))) (list 1 (vector (odd? 2) 3 (list 4 (odd? 5))))) (list x y z)) '(1 3 4) (let () (bind! (a _ (b #f . bs) c)) (and (eq? a 'a) (eq? b 'b) (eq? bs 'bs) (eq? c 'c))) #t ) ;(defines?) (define-checks (binds? verbose?) (begin ;; reset internal database (bind-listify*) ;; add support for vectors and strings (bind-listify* vector? vector-car vector-cdr) (bind-listify* string? string-car string-cdr) #t) #t (bind a 1 a) 1 (bind (a b) '(1 2) (list a b)) '(1 2) (bind (x . y) #(1 2 3 4) (list x y)) '(1 #(2 3 4)) (bind (_ . y) #(1 2 3 4) y) '#(2 3 4) (bind (x (y (z u . v)) w) '(1 #(2 "foo") 4) (list x y z u v w)) '(1 2 #\f #\o "o" 4) (bind (x (y (z u . _)) w) '(1 #(2 "foo") 4) (list x y z u w)) '(1 2 #\f #\o 4) (bind (x (y . _) . _) '(1 #(2 3 4) 5 6) (list x y)) '(1 2) (bind (x (y _ . _) . _) '(1 #(2 3 4) 5 6) (list x y)) '(1 2) (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)) (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)) (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)) (bind (as ... d e) '(1 2 3 4 5) (list as d e)) '((1 2 3) 4 5) (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e)) '(-1 0 (1 2 3) 4 5) (bind (x y as .. d e) '(-1 0 4 5) (list x y as d e)) '(-1 0 () 4 5) (bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5) (list as bs cs d e)) '((1 10) (2 20) (3 30) 4 5) (bind ((as (bs cs)) ... d e) '((1 (2 3)) #(10 (20 30)) 4 5) (list as bs cs d e)) '((1 10) (2 20) (3 30) 4 5) (bind-loop (x (a . b) y) '(5 #(1) 0) (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) (bind* loop (x (a . b) y) '(5 #(1) 0) (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) (bind-loop (x y) #(5 0) (if (zero? x) (vector x y) (loop (vector (- x 1) (+ y 1))))) '#(0 5) (bind* loop (x y) #(5 0) (if (zero? x) (vector x y) (loop (vector (- x 1) (+ y 1))))) '#(0 5) ;LITERALS (bind (#f . ys) '(#f 2 3) ys) '(2 3) (condition-case (bind (#f . ys) '(#t 2 3) ys) ((exn) #f)) #f (bind #f #f #t) #t (condition-case (bind #f #t #t) ((exn) #f)) #f (condition-case (bind (x . #f) '(1 . #t) x) ((exn) #f)) #f (bind (x (y . #f)) '(1 (2 . #f)) (list x y)) '(1 2) (condition-case (bind (x (y . #f)) '(1 (2 . #t)) (list x y)) ((exn) #f)) #f (bind ((x . #f) y . #f) '((1 . #f) 2 . #f) (list x y)) '(1 2) (condition-case (bind ((x . #f) y . #f) '((1 . #f) 2 . #t) (list x y)) ((exn) #f)) #f (condition-case (bind ((x . #f) y . #f) '((1 . #t) 2 . #f) (list x y)) ((exn) #f)) #f (bind ((x . z) y . #f) '((1 . 3) 2 . #f) (list x y z)) '(1 2 3) (bind (a: ()) #(a: #()) #f) #f ) ;(binds?) ; (define-checks (predicates? verbose?) (begin ;; reset internal database (bind-listify*) ;; add support for vectors and strings (bind-listify* vector? vector-car vector-cdr) (bind-listify* string? string-car string-cdr) #t) #t ((bindable? (x)) '(name 1)) #f ((bindable? (_ x)) '(name 1 2)) #f ((bindable? (a b)) '#(1 2)) #t ((bindable? (x (y z))) '(1 "23")) #t ((bindable? (x (y . z))) '(1 "23")) #t ((bindable? (x y)) '(1 "23")) #t ((bindable? (a (b . c) . d)) '(1 2 3 4 5)) #f ((bindable? (a)) 1) #f (bindable? (a b) (where (even? a) (odd? b)) '(2 2)) #f (bindable? (a (b cs .. d)) '(1 (2 3))) #t ) ;(predicates?) (define my-map #f) (define vector-map #f) (define vector-revrerse #f) (define-checks (cases? verbose?) (begin ;; reset internal database (bind-listify*) ;; add support for vectors and strings (bind-listify* vector? vector-car vector-cdr) (bind-listify* string? string-car string-cdr) #t) #t (bind-case #() (() #f)) #f (bind-case #(2 2) ((a b) (where (even? a) (odd? b)) (print 'even-odd a b)) ((a b) (where (odd? a) (even? b)) (print 'odd-even a b)) ((a b) (list a b))) '(2 2) (bind-case '(1 "2 3") ((x (y z)) #f) ((x (y . z)) (list x y z)) ((x y) #t)) '(1 #\2 " 3") (bind-case '(1 "23") ((x (y z)) (where (char-alphabetic? y)) #f) ((x (y . z)) (list x y z)) ((x y) #t)) '(1 #\2 "3") (bind-case '(1 "23") ((x (y z)) (where (char-alphabetic? y)) #f) ((x (y . _)) (list x y)) ((x y) #t)) '(1 #\2) (bind-case '(1 "23") ((x (y z)) (where (char-numeric? y)) (list x y z)) ((x (y . z)) #t) ((x y) #t)) '(1 #\2 #\3) (bind-case '(1 "23") ((x (y z)) (list x y z)) ((x (y . z)) #t) ((x y) #t)) '(1 #\2 #\3) (bind-case '(1 "2 3") ; ((x (y . z)) (list x y z)) ((x (y z)) #f) ((x y) #t)) '(1 #\2 " 3") (bind-case '(1 #(2 3)) ((x y) (where (list? y)) #f) ((x (y . z)) (list x y z)) ((x (y z)) #t)) '(1 2 #(3)) (bind-case '(1 (2 3)) ((x y) (list x y)) ((x (y . z)) #t) ((x (y z)) #t)) '(1 (2 3)) (bind-case '(1 (2 . 3)) ((x y) (list x y)) ((x (y . z)) #t) ((x (y z)) #f)) '(1 (2 . 3)) (bind-case '#(1 2) (() #f) ((a) #f) ((a b) (list a b)) ((a b c) #f)) '(1 2) (bind-case '(0 4) ((a bs .... c) #f) ((a bs ... c) (list a bs c))) '(0 () 4) (bind-case '(0 1 2 3 4) ((a bs .. c) #f) ((a bs ... c) (list a bs c))) '(0 (1 2 3) 4) (bind-case '(0 #(1 (2 3)) 4) ((a (bs (cs (ds))) .. e) #f) ((a (bs (cs ds)) .. e) (list a bs cs ds e))) '(0 (1) (2) (3) 4) (bind-case '(0 4) ((a (bs (cs (ds))) .. e) (list a bs cs ds e)) ((a (bs (cs ds)) .. e) #t)) '(0 () () () 4) (bind-case '((0 1 2 3) (10 #(20 30))) (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs))) '(0 (1 2 3) 10 (20) (30)) ;LOCAL VARIABLES IN ALL RULES (set! my-map (lambda (fn lst) (let loop ((lst lst) (result '())) (bind-case lst (() (reverse result)) ((x . xs) (loop xs (cons (fn x) result))))))) (void) (my-map add1 '(0 1 2 3)) '(1 2 3 4) (set! vector-map (lambda (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)))))))) (void) (vector-map add1 #(0 1 2 3)) #(1 2 3 4) (set! vector-reverse (lambda (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)))))))) (void) (vector-reverse #(0 1 2 3)) #(3 2 1 0) ;NON-SYMBOL LITERALS (bind-case #("a") ((#f) #f) (("a") #t)) #t (bind-case (vector 1 (list (odd? 2) 3)) ((x y) (where (number? y)) #f) ((x ("y" . z)) #f) ((x (#f z)) (list x z))) '(1 3) (bind-case '(1 (#f 3)) ((x y) (list x y)) ((x ("y" . z)) #f) ((x (#f z)) (list x z))) '(1 (#f 3)) (bind-case #(1 ("y" 3)) ((x ("y" . z)) (list x z)) ((x (#f z)) #f)) '(1 (3)) (bind-case '((0 1 2 3) ("" #(20 30))) (((a bs ...) ("x" (ys zs) ..)) #f) (((a bs ...) ("" (ys zs) ..)) (list a bs ys zs))) '(0 (1 2 3) (20) (30)) (bind-case '((0 1 2 3) (10 #(20 30))) (((_ bs ... c) (_ (ys zs) ..)) (list bs c ys zs))) '((1 2) 3 (20) (30)) ) ;(cases?) (define-checks (lambdas? verbose?) (begin ;; reset internal database (bind-listify*) ;; add support for vectors and strings (bind-listify* vector? vector-car vector-cdr) (bind-listify* string? string-car string-cdr) #t) #t ((bind-lambda (a (b cs ...) ds ...) (list a b cs ds)) '(1 #(20 30 40) 2 3)) '(1 20 (30 40) (2 3)) ((bind-lambda (a (b (cs ds) ...) . es) (list a b cs ds es)) '(1 #(20 (30 40)) 2 3)) '(1 20 (30) (40) (2 3)) ((bind-lambda (a (b . cs) . ds) (list a b cs ds)) '(1 #(20 30 40) 2 3)) '(1 20 #(30 40) (2 3)) ((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)) ((bind-case-lambda ((e . f) (where (zero? e)) f) ((e . f) (list e f))) '#(0 2 3 4 5)) '#(2 3 4 5) ((bind-case-lambda ((e . f) (where (zero? e)) #f) ((a (b . #f) . d) (list a b d)) ((e . f) #f)) '(1 (2 . #f) 4 5)) '(1 2 (4 5)) ((bind-case-lambda ((e . f) (where (zero? e)) #f) ((a (b . #f) (ds es) ...) (list a b ds es)) ((e . f) #f)) '(1 (2 . #f) (4 5) (40 50))) '(1 2 (4 40) (5 50)) ((bind-case-lambda ((e . f) (where (zero? e)) #f) ((a (b . #f) . d) #f) ((e . f) (list e f))) '(1 (2 . #t) 4 5)) '(1 ((2 . #t) 4 5)) (condition-case ((bind-case-lambda ((e . f) (where (zero? e)) #f) ((a (b . #f) . d) #f)) '(1 (2 . #t) 4 5)) ((exn) #f)) #f ((bind-case-lambda ((e . f) (where (zero? e)) #f) ((a (b "c") . d) (list a b d)) ((e . f) #f)) '(1 (2 "c") 4 5)) '(1 2 (4 5)) ((bind-case-lambda ((a (b . c) . d) (where (integer? a)) (list a b c d)) ((e . f) (list e f))) '(1 #(2 3 4) 5 6)) '(1 2 #(3 4) (5 6)) ((bind-case-lambda ((a (b . c) . d) (where (string? a)) #f) ((e . f) (list e f))) '(1 #(2 3 4) 5 6)) '(1 (#(2 3 4) 5 6)) ((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)) ((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)) ) ;(lambdas?) (define-checks (lets? verbose?) (begin ;; reset internal database (bind-listify*) ;; add support for vectors and strings (bind-listify* vector? vector-car vector-cdr) (bind-listify* string? string-car string-cdr) #t) #t (bind-let ((((x y) z) '(#(1 2) 3)) (u (+ 2 2)) ((v w) #(5 6))) (list x y z u v w)) '(1 2 3 4 5 6) (bind-let ((((x y) (zs ..)) '(#(1 2) ())) (u (+ 2 2)) ((v w) #(5 6))) (list x y zs u v w)) '(1 2 () 4 5 6) (bind-let ((((x y) (zs ..)) '(#(1 2) ())) (((us vs) ...) '((3 4) (30 40) (300 400)))) (list x y zs us vs)) '(1 2 () (3 30 300) (4 40 400)) (bind* loop (a b) '(5 0) (if (zero? a) (list a b) (loop (list (- a 1) (+ b 1))))) '(0 5) (bind-let loop (((a b) '(5 0))) (if (zero? a) (list a b) (loop (list (- a 1) (+ b 1))))) '(0 5) (bind-let loop (((x . y) '(1 2 3)) ((z) #(10))) (if (zero? z) (list x y z) (loop (cons (+ x 1) (map add1 y)) (list (- z 1))))) '(11 (12 13) 0) (bind-let* ((((x y) z) '(#(1 2) 3)) (u (+ 1 2 x)) ((v w) (list (+ z 2) 6))) (list x y z u v w)) '(1 2 3 4 5 6) (bindrec ((o?) e?) (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1))))) (lambda (n) (if (zero? n) #t (o? (- n 1))))) (list (o? 95) (e? 95))) '(#t #f) (bind-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1))))) ((e?) (vector (lambda (n) (if (zero? n) #t (o? (- n 1))))))) (list (o? 95) (e? 95))) '(#t #f) ) ;(lets?) (import biglists) ; (define (integers-from n) (Cons n (integers-from (+ n 1)) #f)) (define integers (integers-from 0)) (define (Car xs) (At 0 xs)) (define (Cdr xs) (Drop 1 xs)) (define-checks (biglists? verbose?) (begin ;; reset internal database (bind-listify*) ;; add vector and biglist support (bind-listify* vector? vector-car vector-cdr) (bind-listify* BigList? Car Cdr) #t) #t (bind (x y . zs) integers (Car zs)) 2 (bind (_ _ . zs) integers (Car zs)) 2 (bind (x #f (_ (b . cs) . zs)) (vector 1 #f (List 10 integers 2 3)) (list x b (Car cs) (Car zs) (At 1 zs))) '(1 0 1 2 3) ) ;(biglists?) (define-checks (dots? verbose?) (resolve-dots '(1 2 3) ...) '(1 2 3) (resolve-dots 1 2 '(30 40) .. 5) '(1 2 30 40 5) (resolve-dots 1 2 '() .. 5) '(1 2 5) (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7) '(1 20 30 4 40 50 60 7) ) ;(dots?) (check-all BINDINGS (listify?) (lists-only?) (defines?) (binds?) (predicates?) (cases?) (lambdas?) (lets?) (biglists?) (dots?) )