Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

2434 lines (2201 sloc) 65.891 kB
; File: "error.scm", Time-stamp: <2008-04-01 12:44:06 feeley>
; Copyright (c) 1998-2007 by Marc Feeley, All Rights Reserved.
; Test program for error processing.
; run like this: gsi/gsi -f error.scm < error.scm
1 2 3
(define scheme-system
(let ((str1 (symbol->string (car '(aB\c;
))))
(str2 "\0411\x23"))
(cond ((or (equal? str1 "aB\\c") (equal? str1 "aB"))
'gambit) ; Gambit in case-sensitive mode
((equal? str1 "ab\\c")
(let* ((c0 (string-ref str2 0)))
(cond ((char=? c0 (integer->char 0))
'scm)
((char=? c0 (integer->char 9))
'stk)
((char=? c0 #\!)
(cond ((char=? (string-ref str2 2) #\#)
'gambit) ; Gambit in case-insensitive mode
(else
'mit)))
(else
'unknown))))
((equal? str1 "ABc")
'scheme-to-c)
((equal? str1 "abc")
'chez)
((equal? str1 "aBc")
'elk)
((equal? str1 "AB\\C")
'bigloo)
(else
'unknown))))
(define return #f)
(define call-args #f)
(define call-expr #f)
(define continuation->return-address #f)
(define catch-all #f)
(define chez-continuation->return-address
(lambda (cont)
#f))
(define chez-catch-all
(lambda (catcher thunk)
(parameterize ((error-handler
(lambda (fn-name err-format . err-args)
(catcher (string->symbol "##signal.runtime-error")
(list (apply format
(cons err-format err-args))
fn-name
call-args)))))
(thunk))))
(define mit-continuation->return-address
(lambda (cont)
#f))
(define mit-catch-all
(lambda (catcher thunk)
(call-with-current-continuation
(lambda (return)
(bind-condition-handler
'()
(lambda (condition)
(catcher (string->symbol "##signal.runtime-error")
(list (condition/report-string condition)
(car call-expr)
call-args))
(return #f))
thunk)))))
(define scm-continuation->return-address
(lambda (cont)
#f))
(define scm-catch-all
(lambda (catcher thunk)
(call-with-current-continuation
(lambda (return)
(let ((error? #t))
(dynamic-wind
(lambda () #f)
(lambda ()
(let ((result (thunk)))
(set! error? #f)
result))
(lambda ()
(if error?
(begin
(catcher (string->symbol "##signal.runtime-error")
(list "ERROR"
(car call-expr)
call-args))
(return #f))))))))))
(case scheme-system
((gambit)
(set! continuation->return-address
(eval `(lambda (cont)
(,(string->symbol "##continuation-ret")
(,(string->symbol "##procedure->continuation") cont)))))
(set! catch-all
(lambda (catcher thunk)
(with-exception-handler
(lambda (exc)
(define (call oper args)
(catcher
(string->symbol "##signal.runtime-error")
(list (with-input-from-string
(with-output-to-string
'()
(lambda ()
(if (os-exception? exc)
(write exc)
(##display-exception exc (current-output-port)))))
read-line)
(##procedure-friendly-name oper)
args)))
(cond ((abandoned-mutex-exception? exc)
(call "???" '()))
((sfun-conversion-exception? exc)
(call
(sfun-conversion-exception-procedure exc)
(sfun-conversion-exception-arguments exc)))
((cfun-conversion-exception? exc)
(call
(cfun-conversion-exception-procedure exc)
(cfun-conversion-exception-arguments exc)))
((datum-parsing-exception? exc)
(call "???" '()))
((deadlock-exception? exc)
(call "???" '()))
((divide-by-zero-exception? exc)
(call
(divide-by-zero-exception-procedure exc)
(divide-by-zero-exception-arguments exc)))
((error-exception? exc)
(call "???" '()))
((expression-parsing-exception? exc)
(call "???" '()))
((heap-overflow-exception? exc)
(call "???" '()))
((improper-length-list-exception? exc)
(call
(improper-length-list-exception-procedure exc)
(improper-length-list-exception-arguments exc)))
((join-timeout-exception? exc)
(call
(join-timeout-exception-procedure exc)
(join-timeout-exception-arguments exc)))
((keyword-expected-exception? exc)
(call
(keyword-expected-exception-procedure exc)
(keyword-expected-exception-arguments exc)))
((multiple-c-return-exception? exc)
(call "???" '()))
((noncontinuable-exception? exc)
(call "???" '()))
((nonprocedure-operator-exception? exc)
(call
(quot (nonprocedure-operator-exception-operator exc))
(nonprocedure-operator-exception-arguments exc)))
((number-of-arguments-limit-exception? exc)
(call
(number-of-arguments-limit-exception-procedure exc)
(number-of-arguments-limit-exception-arguments exc)))
((os-exception? exc)
(call
(os-exception-procedure exc)
(os-exception-arguments exc)))
((range-exception? exc)
(call
(range-exception-procedure exc)
(range-exception-arguments exc)))
((scheduler-exception? exc)
(call "???" '()))
((stack-overflow-exception? exc)
(call "???" '()))
((started-thread-exception? exc)
(call
(started-thread-exception-procedure exc)
(started-thread-exception-arguments exc)))
((terminated-thread-exception? exc)
(call
(terminated-thread-exception-procedure exc)
(terminated-thread-exception-arguments exc)))
((type-exception? exc)
(call
(type-exception-procedure exc)
(type-exception-arguments exc)))
((unbound-os-environment-variable-exception? exc)
(call
(unbound-os-environment-variable-exception-procedure exc)
(unbound-os-environment-variable-exception-arguments exc)))
((unbound-global-exception? exc)
(call "???" '()))
((uncaught-exception? exc)
(call
(uncaught-exception-procedure exc)
(uncaught-exception-arguments exc)))
((unknown-keyword-argument-exception? exc)
(call
(unknown-keyword-argument-exception-procedure exc)
(unknown-keyword-argument-exception-arguments exc)))
((wrong-number-of-arguments-exception? exc)
(call
(wrong-number-of-arguments-exception-procedure exc)
(wrong-number-of-arguments-exception-arguments exc)))
((no-such-file-or-directory-exception? exc)
(call
(no-such-file-or-directory-exception-procedure exc)
(no-such-file-or-directory-exception-arguments exc)))
(else
(call "???" '()))))
thunk))))
((chez)
(set! continuation->return-address chez-continuation->return-address)
(set! catch-all chez-catch-all)
(print-vector-length #f))
((mit)
(set! continuation->return-address mit-continuation->return-address)
(set! catch-all mit-catch-all))
((scm)
(set! continuation->return-address scm-continuation->return-address)
(set! catch-all scm-catch-all)))
(define copy-obj
(lambda (obj)
(cond ((string? obj) (string-copy obj))
((pair? obj) (cons (copy-obj (car obj)) (copy-obj (cdr obj))))
((vector? obj) (list->vector (map copy-obj (vector->list obj))))
(else obj))))
(define apply-fn
(lambda (fn args)
(let ((result ; make sure continuation is unique (even in interpreter)
(cond (fn => (lambda (f) (apply f args))))))
result)))
(define return-address-of-apply-fn
(apply-fn
(lambda ()
(call-with-current-continuation
(lambda (cont)
(continuation->return-address cont))))
'()))
(define error-catcher
(lambda (s args)
(call-with-current-continuation
(lambda (cont)
(if (not (eq? s (string->symbol "##signal.runtime-error")))
(begin
(display ";;; SIGNAL ")
(write s)
(display " IS WRONG: ")
(write call-expr)
(newline))
(let ((call-expr2
(cons (cadr args)
(map quot (caddr args)))))
(if (not (equal? call-expr call-expr2))
(begin
(display ";;; CALL EXPRESSION ")
(write call-expr2)
(display " IS WRONG: ")
(write call-expr)
(newline))
(let ((retadr (continuation->return-address cont)))
(if (not (eq? retadr return-address-of-apply-fn))
(begin
(display ";;; CONTINUATION ")
(display retadr)
(display " IS WRONG: ")
(write call-expr)
(newline))
(begin
(display ";;; ")
(display (car args))
(display ": ")
(write call-expr)
(newline)))))))
(return #t)))))
(define quot
(lambda (x)
(if (or (number? x) (string? x) (char? x) (boolean? x))
x
(list 'quote x))))
(define generic-try
(lambda (fn-name fn args proc)
(set! call-args (map copy-obj args))
(set! call-expr (cons fn-name (map quot call-args)))
(call-with-current-continuation
(lambda (cont)
(set! return cont)
(proc
(catch-all
error-catcher
(lambda ()
(apply-fn fn args))))))))
(define try
(lambda (fn-name fn . args)
(generic-try fn-name
fn
args
(lambda (result)
(write call-expr)
(display " => ")
(write (normalize-numbers result))
(newline)))))
(define try*
(lambda (obj fn-name fn . args)
(generic-try fn-name
fn
args
(lambda (result)
(write call-expr)
(display " => ")
(write (normalize-numbers obj))
(newline)))))
(define normalize-numbers
(lambda (x)
(if (and (number? x) (inexact? x))
(if (real? x)
(let ((y (/ (round (* (abs x) 1000000)) 1000000)))
(if (< x 0) (- y) y)) ; get rid of -0.
(make-rectangular (normalize-numbers (real-part x))
(normalize-numbers (imag-part x))))
x)))
(define (sort-list lst <?)
(define (mergesort lst)
(define (merge lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
(else
(let ((e1 (car lst1)) (e2 (car lst2)))
(if (<? e1 e2)
(cons e1 (merge (cdr lst1) lst2))
(cons e2 (merge lst1 (cdr lst2))))))))
(define (split lst)
(if (or (null? lst) (null? (cdr lst)))
lst
(cons (car lst) (split (cddr lst)))))
(if (or (null? lst) (null? (cdr lst)))
lst
(let* ((lst1 (mergesort (split lst)))
(lst2 (mergesort (split (cdr lst)))))
(merge lst1 lst2))))
(mergesort lst))
;------------------------------------------------------------------------------
(define (test-not) ; no error possible
(try 'not not #f)
(try 'not not #t)
(try 'not not '())
(try 'not not "foo")
)
(test-not)
(define (test-boolean?) ; no error possible
(try 'boolean? boolean? #f)
(try 'boolean? boolean? #t)
(try 'boolean? boolean? '())
(try 'boolean? boolean? "foo")
)
(test-boolean?)
(define (test-eqv?) ; no error possible
(try 'eqv? eqv? #f "foo")
(try 'eqv? eqv? #f #f)
(try 'eqv? eqv? 'foo 'foo)
(try 'eqv? eqv? 12345678901234567890 12345678901234567890)
(try 'eqv? eqv? '(1 2) '(1 2))
)
(test-eqv?)
(define (test-eq?) ; no error possible
(try 'eq? eq? #f "foo")
(try 'eq? eq? #f #f)
(try 'eq? eq? 'foo 'foo)
(try 'eq? eq? 12345678901234567890 12345678901234567890)
(try 'eq? eq? '(1 2) '(1 2))
)
(test-eq?)
(define (test-equal?) ; no error possible
(try 'equal? equal? #f "foo")
(try 'equal? equal? #f #f)
(try 'equal? equal? 'foo 'foo)
(try 'equal? equal? 12345678901234567890 12345678901234567890)
(try 'equal? equal? '(1 2) '(1 2))
)
(test-equal?)
(define (test-pair?) ; no error possible
(try 'pair? pair? '(1 . 2))
(try 'pair? pair? '())
(try 'pair? pair? "foo")
(try 'pair? pair? #f)
)
(test-pair?)
(define (test-cons) ; no error possible
(try 'cons cons 1 "foo")
)
(test-cons)
(define (test-car)
(try 'car car '(a . b))
(try 'car car 'a)
(try 'car car "foo")
(try 'car car '#(a b))
)
(test-car)
(define (test-cdr)
(try 'cdr cdr '(a . b))
(try 'cdr cdr 'a)
(try 'cdr cdr "foo")
(try 'cdr cdr '#(a b))
)
(test-cdr)
(define (test-set-car!)
(let ((x (cons 'a 'b))) (try* x 'set-car! set-car! x 123))
(try 'set-car! set-car! 'a 123)
(try 'set-car! set-car! "foo" 123)
(try 'set-car! set-car! '#(a b) 123)
)
(test-set-car!)
(define (test-set-cdr!)
(let ((x (cons 'a 'b))) (try* x 'set-cdr! set-cdr! x 123))
(try 'set-cdr! set-cdr! 'a 123)
(try 'set-cdr! set-cdr! "foo" 123)
(try 'set-cdr! set-cdr! '#(a b) 123)
)
(test-set-cdr!)
(define (test-caar)
(try 'caar caar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'caar caar '(((a . b) c . d) (e . f) g . h))
(try 'caar caar '((a . b) c . d))
(try 'caar caar '(a . b))
(try 'caar caar 'a)
)
(test-caar)
(define (test-cadr)
(try 'cadr cadr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cadr cadr '(((a . b) c . d) (e . f) g . h))
(try 'cadr cadr '((a . b) c . d))
(try 'cadr cadr '(a . b))
(try 'cadr cadr 'a)
)
(test-cadr)
(define (test-cdar)
(try 'cdar cdar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cdar cdar '(((a . b) c . d) (e . f) g . h))
(try 'cdar cdar '((a . b) c . d))
(try 'cdar cdar '(a . b))
(try 'cdar cdar 'a)
)
(test-cdar)
(define (test-cddr)
(try 'cddr cddr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cddr cddr '(((a . b) c . d) (e . f) g . h))
(try 'cddr cddr '((a . b) c . d))
(try 'cddr cddr '(a . b))
(try 'cddr cddr 'a)
)
(test-cddr)
(define (test-caaar)
(try 'caaar caaar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'caaar caaar '(((a . b) c . d) (e . f) g . h))
(try 'caaar caaar '((a . b) c . d))
(try 'caaar caaar '(a . b))
(try 'caaar caaar 'a)
)
(test-caaar)
(define (test-caadr)
(try 'caadr caadr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'caadr caadr '(((a . b) c . d) (e . f) g . h))
(try 'caadr caadr '((a . b) c . d))
(try 'caadr caadr '(a . b))
(try 'caadr caadr 'a)
)
(test-caadr)
(define (test-cddar)
(try 'cddar cddar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cddar cddar '(((a . b) c . d) (e . f) g . h))
(try 'cddar cddar '((a . b) c . d))
(try 'cddar cddar '(a . b))
(try 'cddar cddar 'a)
)
(test-cddar)
(define (test-cdddr)
(try 'cdddr cdddr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cdddr cdddr '(((a . b) c . d) (e . f) g . h))
(try 'cdddr cdddr '((a . b) c . d))
(try 'cdddr cdddr '(a . b))
(try 'cdddr cdddr 'a)
)
(test-cdddr)
(define (test-caaaar)
(try 'caaaar caaaar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'caaaar caaaar '(((a . b) c . d) (e . f) g . h))
(try 'caaaar caaaar '((a . b) c . d))
(try 'caaaar caaaar '(a . b))
(try 'caaaar caaaar 'a)
)
(test-caaaar)
(define (test-caaadr)
(try 'caaadr caaadr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'caaadr caaadr '(((a . b) c . d) (e . f) g . h))
(try 'caaadr caaadr '((a . b) c . d))
(try 'caaadr caaadr '(a . b))
(try 'caaadr caaadr 'a)
)
(test-caaadr)
(define (test-caddar)
(try 'caddar caddar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'caddar caddar '(((a . b) c . d) (e . f) g . h))
(try 'caddar caddar '((a . b) c . d))
(try 'caddar caddar '(a . b))
(try 'caddar caddar 'a)
)
(test-caddar)
(define (test-cadddr)
(try 'cadddr cadddr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cadddr cadddr '(((a . b) c . d) (e . f) g . h))
(try 'cadddr cadddr '((a . b) c . d))
(try 'cadddr cadddr '(a . b))
(try 'cadddr cadddr 'a)
)
(test-cadddr)
(define (test-cdaaar)
(try 'cdaaar cdaaar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cdaaar cdaaar '(((a . b) c . d) (e . f) g . h))
(try 'cdaaar cdaaar '((a . b) c . d))
(try 'cdaaar cdaaar '(a . b))
(try 'cdaaar cdaaar 'a)
)
(test-cdaaar)
(define (test-cdaadr)
(try 'cdaadr cdaadr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cdaadr cdaadr '(((a . b) c . d) (e . f) g . h))
(try 'cdaadr cdaadr '((a . b) c . d))
(try 'cdaadr cdaadr '(a . b))
(try 'cdaadr cdaadr 'a)
)
(test-cdaadr)
(define (test-cdddar)
(try 'cdddar cdddar '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cdddar cdddar '(((a . b) c . d) (e . f) g . h))
(try 'cdddar cdddar '((a . b) c . d))
(try 'cdddar cdddar '(a . b))
(try 'cdddar cdddar 'a)
)
(test-cdddar)
(define (test-cddddr)
(try 'cddddr cddddr '((((a . b) c . d) (e . f) g . h) ((i . j) k . l) (m . n) o . p))
(try 'cddddr cddddr '(((a . b) c . d) (e . f) g . h))
(try 'cddddr cddddr '((a . b) c . d))
(try 'cddddr cddddr '(a . b))
(try 'cddddr cddddr 'a)
)
(test-cddddr)
(define (test-null?) ; no error possible
(try 'null? null? '())
(try 'null? null? '(1 . 2))
(try 'null? null? "foo")
(try 'null? null? #f)
)
(test-null?)
(define (test-list?) ; no error possible
(try 'list? list? '())
(try 'list? list? '(1 . 2))
(try 'list? list? '(1 2))
(try 'list? list? "foo")
(try 'list? list? #f)
)
(test-list?)
(define (test-list) ; no error possible
(try 'list list)
(try 'list list 1)
(try 'list list 1 2)
)
(test-list)
(define (test-length)
(try 'length length '())
(try 'length length '(1 2 3))
(try 'length length '(1 2 . 3))
(try 'length length "foo")
)
(test-length)
(define (test-append)
(try 'append append)
(try 'append append #f)
(try 'append append '() #f)
(try 'append append '(1 2) #f)
(try 'append append '(1 2 . "foo") #f)
(try 'append append '() '() #f)
(try 'append append '() '(1 2) #f)
(try 'append append '() '(1 2 . "foo") #f)
(try 'append append '(1 2) '() #f)
(try 'append append '(1 2 . "foo") '() #f)
(try 'append append '(1 2) '(3 4) #f)
(try 'append append '() '() '() #f)
(try 'append append '(1 2) '(3 4) '(5 6) #f)
)
(test-append)
(define (test-reverse)
(try 'reverse reverse '())
(try 'reverse reverse '(1 2 3))
(try 'reverse reverse '(1 2 . 3))
(try 'reverse reverse "foo")
)
(test-reverse)
(define (test-list-tail)
(try 'list-tail list-tail '() 0)
(try 'list-tail list-tail '(1 2 . 3) 1)
(try 'list-tail list-tail '(1 2) 3)
(try 'list-tail list-tail "foo" 1)
)
(test-list-tail)
(define (test-list-ref)
(try 'list-ref list-ref '() 0)
(try 'list-ref list-ref '(1 2 . 3) 1)
(try 'list-ref list-ref '(1 2) 3)
(try 'list-ref list-ref "foo" 1)
)
(test-list-ref)
(define (test-memq)
(try 'memq memq 123 '(a b c))
(try 'memq memq #f '(a #f b))
(try 'memq memq 'foo '(a foo b))
(try 'memq memq 12345678901234567890 '(a 12345678901234567890 b))
(try 'memq memq '(1 2) '(a (1 2) b))
(try 'memq memq 123 '())
(try 'memq memq 123 "foo")
(try 'memq memq 123 '(a b . "foo"))
)
(test-memq)
(define (test-memv)
(try 'memv memv 123 '(a b c))
(try 'memv memv #f '(a #f b))
(try 'memv memv 'foo '(a foo b))
(try 'memv memv 12345678901234567890 '(a 12345678901234567890 b))
(try 'memv memv '(1 2) '(a (1 2) b))
(try 'memv memv 123 '())
(try 'memv memv 123 "foo")
(try 'memv memv 123 '(a b . "foo"))
)
(test-memv)
(define (test-member)
(try 'member member 123 '(a b c))
(try 'member member #f '(a #f b))
(try 'member member 'foo '(a foo b))
(try 'member member 12345678901234567890 '(a 12345678901234567890 b))
(try 'member member '(1 2) '(a (1 2) b))
(try 'member member 123 '())
(try 'member member 123 "foo")
(try 'member member 123 '(a b . "foo"))
)
(test-member)
(define (test-assq)
(try 'assq assq 123 '((a . 1) (b . 2) (c . 3)))
(try 'assq assq #f '((a . 1) (#f . 2) (b . 3)))
(try 'assq assq 'foo '((a . 1) (foo . 2) (b . 3)))
(try 'assq assq 12345678901234567890 '((a . 1) (12345678901234567890 . 2) (b . 3)))
(try 'assq assq '(1 2) '((a . 1) ((1 2) . 2) (b . 3)))
(try 'assq assq 123 '())
(try 'assq assq 123 "foo")
(try 'assq assq 123 '((a . 1) (b . 2) . "foo"))
(try 'assq assq 123 '((a . 1) b (c . 3)))
)
(test-assq)
(define (test-assv)
(try 'assv assv 123 '((a . 1) (b . 2) (c . 3)))
(try 'assv assv #f '((a . 1) (#f . 2) (b . 3)))
(try 'assv assv 'foo '((a . 1) (foo . 2) (b . 3)))
(try 'assv assv 12345678901234567890 '((a . 1) (12345678901234567890 . 2) (b . 3)))
(try 'assv assv '(1 2) '((a . 1) ((1 2) . 2) (b . 3)))
(try 'assv assv 123 '())
(try 'assv assv 123 "foo")
(try 'assv assv 123 '((a . 1) (b . 2) . "foo"))
(try 'assv assv 123 '((a . 1) b (c . 3)))
)
(test-assv)
(define (test-assoc)
(try 'assoc assoc 123 '((a . 1) (b . 2) (c . 3)))
(try 'assoc assoc #f '((a . 1) (#f . 2) (b . 3)))
(try 'assoc assoc 'foo '((a . 1) (foo . 2) (b . 3)))
(try 'assoc assoc 12345678901234567890 '((a . 1) (12345678901234567890 . 2) (b . 3)))
(try 'assoc assoc '(1 2) '((a . 1) ((1 2) . 2) (b . 3)))
(try 'assoc assoc 123 '())
(try 'assoc assoc 123 "foo")
(try 'assoc assoc 123 '((a . 1) (b . 2) . "foo"))
(try 'assoc assoc 123 '((a . 1) b (c . 3)))
)
(test-assoc)
(define (test-symbol?) ; no error possible
(try 'symbol? symbol? 'foo)
(try 'symbol? symbol? #f)
(try 'symbol? symbol? '())
(try 'symbol? symbol? "foo")
)
(test-symbol?)
(define (test-symbol->string)
(try 'symbol->string symbol->string 'foo)
(try 'symbol->string symbol->string "foo")
)
(test-symbol->string)
(define (test-string->symbol)
(try 'string->symbol string->symbol "foo")
(try 'string->symbol string->symbol 'foo)
)
(test-string->symbol)
(define (test-number?) ; no error possible
(try 'number? number? 1)
(try 'number? number? 1/2)
(try 'number? number? 1.5)
(try 'number? number? +i)
(try 'number? number? #f)
)
(test-number?)
(define (test-complex?) ; no error possible
(try 'complex? complex? 1)
(try 'complex? complex? 1/2)
(try 'complex? complex? 1.5)
(try 'complex? complex? +i)
(try 'complex? complex? #f)
)
(test-complex?)
(define (test-real?) ; no error possible
(try 'real? real? 1)
(try 'real? real? 1/2)
(try 'real? real? 1.5)
(try 'real? real? +i)
(try 'real? real? #f)
)
(test-real?)
(define (test-rational?) ; no error possible
(try 'rational? rational? 1)
(try 'rational? rational? 1/2)
(try 'rational? rational? 1.5)
(try 'rational? rational? +i)
(try 'rational? rational? #f)
)
(test-rational?)
(define (test-integer?) ; no error possible
(try 'integer? integer? 1)
(try 'integer? integer? 1/2)
(try 'integer? integer? 1.5)
(try 'integer? integer? +i)
(try 'integer? integer? #f)
)
(test-integer?)
(define (test-exact?)
(try 'exact? exact? 1/2)
(try 'exact? exact? 1.5)
(try 'exact? exact? +i)
(try 'exact? exact? #f)
)
(test-exact?)
(define (test-inexact?)
(try 'inexact? inexact? 1/2)
(try 'inexact? inexact? 1.5)
(try 'inexact? inexact? +i)
(try 'inexact? inexact? #f)
)
(test-inexact?)
(define (test-=)
(try '= =)
(try '= = 1)
(try '= = 'a)
(try '= = 1 1)
(try '= = 1 2)
(try '= = 2 1)
(try '= = 1 +i)
(try '= = 'a 2)
(try '= = 1 'b)
(try '= = 1 2 3)
(try '= = 1 2 'c)
(try '= = 2 2 2 2)
(try '= = 1 2 3 4)
(try '= = 4 3 2 1)
(try '= = 1 2 4 4)
(try '= = 4 4 2 1)
)
(test-=)
(define (test-<)
(try '< <)
(try '< < 1)
(try '< < 'a)
(try '< < 1 1)
(try '< < 1 2)
(try '< < 2 1)
(try '< < 1 +i)
(try '< < 'a 2)
(try '< < 1 'b)
(try '< < 1 2 3)
(try '< < 1 2 'c)
(try '< < 2 2 2 2)
(try '< < 1 2 3 4)
(try '< < 4 3 2 1)
(try '< < 1 2 4 4)
(try '< < 4 4 2 1)
)
(test-<)
(define (test->)
(try '> >)
(try '> > 1)
(try '> > 'a)
(try '> > 1 1)
(try '> > 1 2)
(try '> > 2 1)
(try '> > 1 +i)
(try '> > 'a 2)
(try '> > 1 'b)
(try '> > 1 2 3)
(try '> > 1 2 'c)
(try '> > 2 2 2 2)
(try '> > 1 2 3 4)
(try '> > 4 3 2 1)
(try '> > 1 2 4 4)
(try '> > 4 4 2 1)
)
(test->)
(define (test-<=)
(try '<= <=)
(try '<= <= 1)
(try '<= <= 'a)
(try '<= <= 1 1)
(try '<= <= 1 2)
(try '<= <= 2 1)
(try '<= <= 1 +i)
(try '<= <= 'a 2)
(try '<= <= 1 'b)
(try '<= <= 1 2 3)
(try '<= <= 1 2 'c)
(try '<= <= 2 2 2 2)
(try '<= <= 1 2 3 4)
(try '<= <= 4 3 2 1)
(try '<= <= 1 2 4 4)
(try '<= <= 4 4 2 1)
)
(test-<=)
(define (test->=)
(try '>= >=)
(try '>= >= 1)
(try '>= >= 'a)
(try '>= >= 1 1)
(try '>= >= 1 2)
(try '>= >= 2 1)
(try '>= >= 1 +i)
(try '>= >= 'a 2)
(try '>= >= 1 'b)
(try '>= >= 1 2 3)
(try '>= >= 1 2 'c)
(try '>= >= 2 2 2 2)
(try '>= >= 1 2 3 4)
(try '>= >= 4 3 2 1)
(try '>= >= 1 2 4 4)
(try '>= >= 4 4 2 1)
)
(test->=)
(define (test-zero?)
(try 'zero? zero? 1)
(try 'zero? zero? 2.0)
(try 'zero? zero? 3.4)
(try 'zero? zero? +i)
(try 'zero? zero? 'foo)
)
(test-zero?)
(define (test-positive?)
(try 'positive? positive? 1)
(try 'positive? positive? 2.0)
(try 'positive? positive? 3.4)
(try 'positive? positive? +i)
(try 'positive? positive? 'foo)
)
(test-positive?)
(define (test-negative?)
(try 'negative? negative? 1)
(try 'negative? negative? 2.0)
(try 'negative? negative? 3.4)
(try 'negative? negative? +i)
(try 'negative? negative? 'foo)
)
(test-negative?)
(define (test-odd?)
(try 'odd? odd? 1)
(try 'odd? odd? 2.0)
(try 'odd? odd? 3.4)
(try 'odd? odd? +i)
(try 'odd? odd? 'foo)
)
(test-odd?)
(define (test-even?)
(try 'even? even? 1)
(try 'even? even? 2.0)
(try 'even? even? 3.4)
(try 'even? even? +i)
(try 'even? even? 'foo)
)
(test-even?)
(define (test-max)
(try 'max max 3)
(try 'max max 'a)
(try 'max max 3 4)
(try 'max max 3 4.0)
(try 'max max 'a 4.0)
(try 'max max 3 'b)
(try 'max max 1 2 3)
(try 'max max 1 2 'c)
(try 'max max 1+0.i 2+0.i)
)
(test-max)
(define (test-min)
(try 'min min 3)
(try 'min min 'a)
(try 'min min 3 4)
(try 'min min 3 4.0)
(try 'min min 'a 4.0)
(try 'min min 3 'b)
(try 'min min 1 2 3)
(try 'min min 1 2 'c)
(try 'min min 1+0.i 2+0.i)
)
(test-min)
(define (test-+)
(try '+ +)
(try '+ + 2)
(try '+ + 'a)
(try '+ + 2 3)
(try '+ + 2 +i)
(try '+ + 'a 2)
(try '+ + 1 'b)
(try '+ + 1 2 3)
(try '+ + 1 2 'c)
(try '+ + 2 2 2 2)
(try '+ + 1 2 3 4)
(try '+ + 4 3 2 1)
(try '+ + 1 2 4 4)
(try '+ + 4 4 2 1)
)
(test-+)
(define (test-*)
(try '* *)
(try '* * 2)
(try '* * 'a)
(try '* * 2 3)
(try '* * 2 +i)
(try '* * 'a 2)
(try '* * 1 'b)
(try '* * 1 2 3)
(try '* * 1 2 'c)
(try '* * 2 2 2 2)
(try '* * 1 2 3 4)
(try '* * 4 3 2 1)
(try '* * 1 2 4 4)
(try '* * 4 4 2 1)
)
(test-*)
(define (test--)
(try '- - 2)
(try '- - 'a)
(try '- - 2 3)
(try '- - 2 +i)
(try '- - 'a 2)
(try '- - 1 'b)
(try '- - 1 2 3)
(try '- - 1 2 'c)
(try '- - 2 2 2 2)
(try '- - 1 2 3 4)
(try '- - 4 3 2 1)
(try '- - 1 2 4 4)
(try '- - 4 4 2 1)
)
(test--)
(define (test-/)
(try '/ / 2)
(try '/ / 0)
(try '/ / 'a)
(try '/ / 2 3)
(try '/ / 2 +i)
(try '/ / 2 0)
(try '/ / 'a 2)
(try '/ / 1 'b)
(try '/ / 1 2 3)
(try '/ / 1 2 0)
(try '/ / 1 2 'c)
(try '/ / 2 2 2 2)
(try '/ / 1 2 3 4)
(try '/ / 4 3 2 1)
(try '/ / 1 2 4 4)
(try '/ / 4 4 2 1)
)
(test-/)
(define (test-abs)
(try 'abs abs -7)
(try 'abs abs +i)
(try 'abs abs 'a)
)
(test-abs)
(define (test-quotient)
(try 'quotient quotient 9 4)
(try 'quotient quotient 295147905149568077200 34359738366)
(try 'quotient quotient 696898287454081973170944403677937368733396 1180591620717411303422)
(try 'quotient quotient 9. -4.)
(try 'quotient quotient 9. 3/2)
(try 'quotient quotient 9 0)
(try 'quotient quotient 'a 4)
(try 'quotient quotient 9 'b)
)
(test-quotient)
(define (test-remainder)
(try 'remainder remainder 9 4)
(try 'remainder remainder 295147905149568077200 34359738366)
(try 'remainder remainder 696898287454081973170944403677937368733396 1180591620717411303422)
(try 'remainder remainder 9. -4.)
(try 'remainder remainder 9. 3/2)
(try 'remainder remainder 9 0)
(try 'remainder remainder 'a 4)
(try 'remainder remainder 9 'b)
)
(test-remainder)
(define (test-modulo)
(try 'modulo modulo 9 4)
(try 'modulo modulo 295147905149568077200 34359738366)
(try 'modulo modulo 696898287454081973170944403677937368733396 1180591620717411303422)
(try 'modulo modulo 9. -4.)
(try 'modulo modulo 9. 3/2)
(try 'modulo modulo 9 0)
(try 'modulo modulo 'a 4)
(try 'modulo modulo 9 'b)
)
(test-modulo)
(define (test-gcd)
(try 'gcd gcd)
(try 'gcd gcd 10)
(try 'gcd gcd 3/2)
(try 'gcd gcd 'a)
(try 'gcd gcd 9 4)
(try 'gcd gcd 9. -4.)
(try 'gcd gcd 9. 3/2)
(try 'gcd gcd 'a 4)
(try 'gcd gcd 9 'b)
(try 'gcd gcd 12 8 10)
(try 'gcd gcd 12 8 'c)
)
(test-gcd)
(define (test-lcm)
(try 'lcm lcm)
(try 'lcm lcm 10)
(try 'lcm lcm 3/2)
(try 'lcm lcm 'a)
(try 'lcm lcm 9 4)
(try 'lcm lcm 9. -4.)
(try 'lcm lcm 9. 3/2)
(try 'lcm lcm 'a 4)
(try 'lcm lcm 9 'b)
(try 'lcm lcm 12 8 10)
(try 'lcm lcm 12 8 'c)
)
(test-lcm)
(define (test-numerator)
(try 'numerator numerator 3/2)
(try 'numerator numerator 1.5)
(try 'numerator numerator +i)
(try 'numerator numerator 'a)
)
(test-numerator)
(define (test-denominator)
(try 'denominator denominator 3/2)
(try 'denominator denominator 1.5)
(try 'denominator denominator +i)
(try 'denominator denominator 'a)
)
(test-denominator)
(define (test-floor)
(try 'floor floor 2/3)
(try 'floor floor 1.2)
(try 'floor floor +i)
(try 'floor floor 'a)
)
(test-floor)
(define (test-ceiling)
(try 'ceiling ceiling 2/3)
(try 'ceiling ceiling 1.2)
(try 'ceiling ceiling +i)
(try 'ceiling ceiling 'a)
)
(test-ceiling)
(define (test-truncate)
(try 'truncate truncate 2/3)
(try 'truncate truncate 1.2)
(try 'truncate truncate +i)
(try 'truncate truncate 'a)
)
(test-truncate)
(define (test-round)
(try 'round round 2/3)
(try 'round round 1.2)
(try 'round round +i)
(try 'round round 'a)
)
(test-round)
(define (test-rationalize)
(try 'rationalize rationalize -3/2 1/2)
(try 'rationalize rationalize -1.5 0.5)
(try 'rationalize rationalize -1.5 -0.5)
(try 'rationalize rationalize +i 2)
(try 'rationalize rationalize 1 +i)
(try 'rationalize rationalize 'a 2)
(try 'rationalize rationalize 1 'b)
)
(test-rationalize)
(define (test-exp)
(try 'exp exp 1/2)
(try 'exp exp -1.5)
(try 'exp exp +i)
(try 'exp exp 'a)
)
(test-exp)
(define (test-log)
(try 'log log 1/2)
(try 'log log -1.5)
(try 'log log +i)
(try 'log log 'a)
)
(test-log)
(define (test-sin)
(try 'sin sin 1/2)
(try 'sin sin -1.5)
(try 'sin sin +i)
(try 'sin sin 'a)
)
(test-sin)
(define (test-cos)
(try 'cos cos 1/2)
(try 'cos cos -1.5)
(try 'cos cos +i)
(try 'cos cos 'a)
)
(test-cos)
(define (test-tan)
(try 'tan tan 1/2)
(try 'tan tan -1.5)
(try 'tan tan +i)
(try 'tan tan 'a)
)
(test-tan)
(define (test-asin)
(try 'asin asin 1/2)
(try 'asin asin -1.5)
(try 'asin asin +i)
(try 'asin asin 'a)
)
(test-asin)
(define (test-acos)
(try 'acos acos 1/2)
(try 'acos acos -1.5)
(try 'acos acos +i)
(try 'acos acos 'a)
)
(test-acos)
(define (test-atan)
(try 'atan atan 1/2)
(try 'atan atan -1.5)
(try 'atan atan +i)
(try 'atan atan 'a)
(try 'atan atan -1.5 2.5)
(try 'atan atan 1 +i)
(try 'atan atan +i 2)
(try 'atan atan 1 'b)
(try 'atan atan 'a 2)
)
(test-atan)
(define (test-sqrt)
(try 'sqrt sqrt 1/4)
(try 'sqrt sqrt -1.5)
(try 'sqrt sqrt +i)
(try 'sqrt sqrt 'a)
)
(test-sqrt)
(define (test-expt)
(try 'expt expt 1/4 -1.5)
(try 'expt expt 2 +i)
(try 'expt expt +i 2)
(try 'expt expt 'a +i)
(try 'expt expt +i 'b)
)
(test-expt)
(define (test-make-rectangular)
(try 'make-rectangular make-rectangular 1/2 -1.5)
(try 'make-rectangular make-rectangular 1/2 +i)
(try 'make-rectangular make-rectangular +i -1.5)
(try 'make-rectangular make-rectangular 'a 2)
(try 'make-rectangular make-rectangular 1 'b)
)
(test-make-rectangular)
(define (test-make-polar)
(try 'make-polar make-polar 1/2 -1.5)
(try 'make-polar make-polar 1/2 +i)
(try 'make-polar make-polar +i -1.5)
(try 'make-polar make-polar 'a 2)
(try 'make-polar make-polar 1 'b)
)
(test-make-polar)
(define (test-real-part)
(try 'real-part real-part 1/2)
(try 'real-part real-part -1.5)
(try 'real-part real-part +i)
(try 'real-part real-part 'a)
)
(test-real-part)
(define (test-imag-part)
(try 'imag-part imag-part 1/2)
(try 'imag-part imag-part -1.5)
(try 'imag-part imag-part +i)
(try 'imag-part imag-part 'a)
)
(test-imag-part)
(define (test-magnitude)
(try 'magnitude magnitude 1/2)
(try 'magnitude magnitude -1.5)
(try 'magnitude magnitude +i)
(try 'magnitude magnitude 'a)
)
(test-magnitude)
(define (test-angle)
(try 'angle angle 1/2)
(try 'angle angle -1.5)
(try 'angle angle +i)
(try 'angle angle 'a)
)
(test-angle)
(define (test-exact->inexact)
(try 'exact->inexact exact->inexact 1/2)
(try 'exact->inexact exact->inexact -1.5)
(try 'exact->inexact exact->inexact +i)
(try 'exact->inexact exact->inexact 'a)
)
(test-exact->inexact)
(define (test-inexact->exact)
(try 'inexact->exact inexact->exact 1/2)
(try 'inexact->exact inexact->exact -1.5)
(try 'inexact->exact inexact->exact +i)
(try 'inexact->exact inexact->exact 'a)
)
(test-inexact->exact)
(define (test-number->string)
(try 'number->string number->string 1/2)
(try 'number->string number->string -1.5)
(try 'number->string number->string +i)
(try 'number->string number->string 'a)
(try 'number->string number->string 123 2)
(try 'number->string number->string 123 3)
(try 'number->string number->string 123 2.)
(try 'number->string number->string 123 +i)
(try 'number->string number->string 123 'a)
)
(test-number->string)
(define (test-string->number)
(try 'string->number string->number "1/2")
(try 'string->number string->number "-1.5")
(try 'string->number string->number "+i")
(try 'string->number string->number "foo")
(try 'string->number string->number 'a)
(try 'string->number string->number "123" 2)
(try 'string->number string->number "123" 3)
(try 'string->number string->number "123" 2.)
(try 'string->number string->number "123" +i)
(try 'string->number string->number "123" 'a)
)
(test-string->number)
(define (test-char?) ; no error possible
(try 'char? char? #\A)
(try 'char? char? #f)
(try 'char? char? '())
(try 'char? char? "foo")
)
(test-char?)
(define (test-char=?)
(try 'char=? char=?)
(try 'char=? char=? #\A)
(try 'char=? char=? 123)
(try 'char=? char=? #\A #\A)
(try 'char=? char=? #\A #\B)
(try 'char=? char=? #\B #\A)
(try 'char=? char=? #\A 123)
(try 'char=? char=? 123 #\A)
(try 'char=? char=? #\A #\B #\C)
(try 'char=? char=? #\A #\B #\B)
(try 'char=? char=? #\B #\B #\B)
(try 'char=? char=? #\B #\B #\A)
(try 'char=? char=? #\C #\B #\A)
(try 'char=? char=? #\A #\B 123)
)
(test-char=?)
(define (test-char<?)
(try 'char<? char<?)
(try 'char<? char<? #\A)
(try 'char<? char<? 123)
(try 'char<? char<? #\A #\A)
(try 'char<? char<? #\A #\B)
(try 'char<? char<? #\B #\A)
(try 'char<? char<? #\A 123)
(try 'char<? char<? 123 #\A)
(try 'char<? char<? #\A #\B #\C)
(try 'char<? char<? #\A #\B #\B)
(try 'char<? char<? #\B #\B #\B)
(try 'char<? char<? #\B #\B #\A)
(try 'char<? char<? #\C #\B #\A)
(try 'char<? char<? #\A #\B 123)
)
(test-char<?)
(define (test-char>?)
(try 'char>? char>?)
(try 'char>? char>? #\A)
(try 'char>? char>? 123)
(try 'char>? char>? #\A #\A)
(try 'char>? char>? #\A #\B)
(try 'char>? char>? #\B #\A)
(try 'char>? char>? #\A 123)
(try 'char>? char>? 123 #\A)
(try 'char>? char>? #\A #\B #\C)
(try 'char>? char>? #\A #\B #\B)
(try 'char>? char>? #\B #\B #\B)
(try 'char>? char>? #\B #\B #\A)
(try 'char>? char>? #\C #\B #\A)
(try 'char>? char>? #\A #\B 123)
)
(test-char>?)
(define (test-char<=?)
(try 'char<=? char<=?)
(try 'char<=? char<=? #\A)
(try 'char<=? char<=? 123)
(try 'char<=? char<=? #\A #\A)
(try 'char<=? char<=? #\A #\B)
(try 'char<=? char<=? #\B #\A)
(try 'char<=? char<=? #\A 123)
(try 'char<=? char<=? 123 #\A)
(try 'char<=? char<=? #\A #\B #\C)
(try 'char<=? char<=? #\A #\B #\B)
(try 'char<=? char<=? #\B #\B #\B)
(try 'char<=? char<=? #\B #\B #\A)
(try 'char<=? char<=? #\C #\B #\A)
(try 'char<=? char<=? #\A #\B 123)
)
(test-char<=?)
(define (test-char>=?)
(try 'char>=? char>=?)
(try 'char>=? char>=? #\A)
(try 'char>=? char>=? 123)
(try 'char>=? char>=? #\A #\A)
(try 'char>=? char>=? #\A #\B)
(try 'char>=? char>=? #\B #\A)
(try 'char>=? char>=? #\A 123)
(try 'char>=? char>=? 123 #\A)
(try 'char>=? char>=? #\A #\B #\C)
(try 'char>=? char>=? #\A #\B #\B)
(try 'char>=? char>=? #\B #\B #\B)
(try 'char>=? char>=? #\B #\B #\A)
(try 'char>=? char>=? #\C #\B #\A)
(try 'char>=? char>=? #\A #\B 123)
)
(test-char>=?)
(define (test-char-ci=?)
(try 'char-ci=? char-ci=?)
(try 'char-ci=? char-ci=? #\A)
(try 'char-ci=? char-ci=? 123)
(try 'char-ci=? char-ci=? #\A #\a)
(try 'char-ci=? char-ci=? #\A #\b)
(try 'char-ci=? char-ci=? #\B #\a)
(try 'char-ci=? char-ci=? #\A 123)
(try 'char-ci=? char-ci=? 123 #\A)
(try 'char-ci=? char-ci=? #\A #\b #\C)
(try 'char-ci=? char-ci=? #\A #\b #\B)
(try 'char-ci=? char-ci=? #\B #\b #\B)
(try 'char-ci=? char-ci=? #\B #\b #\A)
(try 'char-ci=? char-ci=? #\C #\b #\A)
(try 'char-ci=? char-ci=? #\A #\b 123)
)
(test-char-ci=?)
(define (test-char-ci<?)
(try 'char-ci<? char-ci<?)
(try 'char-ci<? char-ci<? #\A)
(try 'char-ci<? char-ci<? 123)
(try 'char-ci<? char-ci<? #\A #\a)
(try 'char-ci<? char-ci<? #\A #\b)
(try 'char-ci<? char-ci<? #\B #\a)
(try 'char-ci<? char-ci<? #\A 123)
(try 'char-ci<? char-ci<? 123 #\A)
(try 'char-ci<? char-ci<? #\A #\b #\C)
(try 'char-ci<? char-ci<? #\A #\b #\B)
(try 'char-ci<? char-ci<? #\B #\b #\B)
(try 'char-ci<? char-ci<? #\B #\b #\A)
(try 'char-ci<? char-ci<? #\C #\b #\A)
(try 'char-ci<? char-ci<? #\A #\b 123)
)
(test-char-ci<?)
(define (test-char-ci>?)
(try 'char-ci>? char-ci>?)
(try 'char-ci>? char-ci>? #\A)
(try 'char-ci>? char-ci>? 123)
(try 'char-ci>? char-ci>? #\A #\a)
(try 'char-ci>? char-ci>? #\A #\b)
(try 'char-ci>? char-ci>? #\B #\a)
(try 'char-ci>? char-ci>? #\A 123)
(try 'char-ci>? char-ci>? 123 #\A)
(try 'char-ci>? char-ci>? #\A #\b #\C)
(try 'char-ci>? char-ci>? #\A #\b #\B)
(try 'char-ci>? char-ci>? #\B #\b #\B)
(try 'char-ci>? char-ci>? #\B #\b #\A)
(try 'char-ci>? char-ci>? #\C #\b #\A)
(try 'char-ci>? char-ci>? #\A #\b 123)
)
(test-char-ci>?)
(define (test-char-ci<=?)
(try 'char-ci<=? char-ci<=?)
(try 'char-ci<=? char-ci<=? #\A)
(try 'char-ci<=? char-ci<=? 123)
(try 'char-ci<=? char-ci<=? #\A #\a)
(try 'char-ci<=? char-ci<=? #\A #\b)
(try 'char-ci<=? char-ci<=? #\B #\a)
(try 'char-ci<=? char-ci<=? #\A 123)
(try 'char-ci<=? char-ci<=? 123 #\A)
(try 'char-ci<=? char-ci<=? #\A #\b #\C)
(try 'char-ci<=? char-ci<=? #\A #\b #\B)
(try 'char-ci<=? char-ci<=? #\B #\b #\B)
(try 'char-ci<=? char-ci<=? #\B #\b #\A)
(try 'char-ci<=? char-ci<=? #\C #\b #\A)
(try 'char-ci<=? char-ci<=? #\A #\b 123)
)
(test-char-ci<=?)
(define (test-char-ci>=?)
(try 'char-ci>=? char-ci>=?)
(try 'char-ci>=? char-ci>=? #\A)
(try 'char-ci>=? char-ci>=? 123)
(try 'char-ci>=? char-ci>=? #\A #\a)
(try 'char-ci>=? char-ci>=? #\A #\b)
(try 'char-ci>=? char-ci>=? #\B #\a)
(try 'char-ci>=? char-ci>=? #\A 123)
(try 'char-ci>=? char-ci>=? 123 #\A)
(try 'char-ci>=? char-ci>=? #\A #\b #\C)
(try 'char-ci>=? char-ci>=? #\A #\b #\B)
(try 'char-ci>=? char-ci>=? #\B #\b #\B)
(try 'char-ci>=? char-ci>=? #\B #\b #\A)
(try 'char-ci>=? char-ci>=? #\C #\b #\A)
(try 'char-ci>=? char-ci>=? #\A #\b 123)
)
(test-char-ci>=?)
(define (test-char-alphabetic?)
(try 'char-alphabetic? char-alphabetic? #\a)
(try 'char-alphabetic? char-alphabetic? #\A)
(try 'char-alphabetic? char-alphabetic? #\0)
(try 'char-alphabetic? char-alphabetic? #\newline)
(try 'char-alphabetic? char-alphabetic? 123)
)
(test-char-alphabetic?)
(define (test-char-numeric?)
(try 'char-numeric? char-numeric? #\a)
(try 'char-numeric? char-numeric? #\A)
(try 'char-numeric? char-numeric? #\0)
(try 'char-numeric? char-numeric? #\newline)
(try 'char-numeric? char-numeric? 123)
)
(test-char-numeric?)
(define (test-char-whitespace?)
(try 'char-whitespace? char-whitespace? #\a)
(try 'char-whitespace? char-whitespace? #\A)
(try 'char-whitespace? char-whitespace? #\0)
(try 'char-whitespace? char-whitespace? #\newline)
(try 'char-whitespace? char-whitespace? 123)
)
(test-char-whitespace?)
(define (test-char-upper-case?)
(try 'char-upper-case? char-upper-case? #\a)
(try 'char-upper-case? char-upper-case? #\A)
(try 'char-upper-case? char-upper-case? #\0)
(try 'char-upper-case? char-upper-case? #\newline)
(try 'char-upper-case? char-upper-case? 123)
)
(test-char-upper-case?)
(define (test-char-lower-case?)
(try 'char-lower-case? char-lower-case? #\a)
(try 'char-lower-case? char-lower-case? #\A)
(try 'char-lower-case? char-lower-case? #\0)
(try 'char-lower-case? char-lower-case? #\newline)
(try 'char-lower-case? char-lower-case? 123)
)
(test-char-lower-case?)
(define (test-char->integer)
(try 'char->integer char->integer #\A)
(try 'char->integer char->integer 123)
)
(test-char->integer)
(define (test-integer->char)
(try 'integer->char integer->char 123)
(try 'integer->char integer->char -1)
(try 'integer->char integer->char #x110000)
(try 'integer->char integer->char #xd800)
(try 'integer->char integer->char 123.0)
(try 'integer->char integer->char #\A)
)
(test-integer->char)
(define (test-char-upcase)
(try 'char-upcase char-upcase #\a)
(try 'char-upcase char-upcase #\A)
(try 'char-upcase char-upcase #\@)
(try 'char-upcase char-upcase 123)
(try 'char-upcase char-upcase 'a)
(try 'char-upcase char-upcase "a")
)
(test-char-upcase)
(define (test-char-downcase)
(try 'char-downcase char-downcase #\a)
(try 'char-downcase char-downcase #\A)
(try 'char-downcase char-downcase #\@)
(try 'char-downcase char-downcase 123)
(try 'char-downcase char-downcase 'a)
(try 'char-downcase char-downcase "a")
)
(test-char-downcase)
(define (test-string?) ; no error possible
(string? "5678")
(string? 12345678901234567890)
)
(test-string?)
(define (test-make-string)
(try 'make-string make-string 0)
(try 'make-string make-string 3)
(try 'make-string make-string 536870911)
(try 'make-string make-string 12345678901234567890)
(try 'make-string make-string -1)
(try 'make-string make-string 1.5)
(try 'make-string make-string 5 #\6)
(try 'make-string make-string 1 'a)
)
(test-make-string)
(define (test-string)
(try 'string string)
(try 'string string #\5)
(try 'string string #\5 #\6)
(try 'string string #\5 'b #\7)
)
(test-string)
(define (test-string-length)
(try 'string-length string-length "5678")
(try 'string-length string-length 12345678901234567890)
)
(test-string-length)
(define (test-string-ref)
(try 'string-ref string-ref "5678" 3)
(try 'string-ref string-ref "56" -1)
(try 'string-ref string-ref "56" 2)
(try 'string-ref string-ref "56" 12345678901234567890)
(try 'string-ref string-ref 12345678901234567890 0)
)
(test-string-ref)
(define (test-string-set!)
(let ((x (string #\5 #\6))) (try* x 'string-set! string-set! x 1 #\3))
(let ((x (string #\5 #\6))) (try* x 'string-set! string-set! x -1 #\3))
(let ((x (string #\5 #\6))) (try* x 'string-set! string-set! x 2 #\3))
(let ((x (string #\5 #\6))) (try* x 'string-set! string-set! x 12345678901234567890 #\3))
(let ((x (string #\5 #\6))) (try* x 'string-set! string-set! x 1 'a))
(try 'string-set! string-set! 12345678901234567890 0 #\3)
)
(test-string-set!)
(define (test-string=?)
(try 'string=? string=?)
(try 'string=? string=? "A")
(try 'string=? string=? 123)
(try 'string=? string=? "A" "A")
(try 'string=? string=? "A" "B")
(try 'string=? string=? "A" "A ")
(try 'string=? string=? "B" "A")
(try 'string=? string=? "A " "A")
(try 'string=? string=? "A" 123)
(try 'string=? string=? 123 "A")
(try 'string=? string=? "A" 123)
(try 'string=? string=? "A" "B" "C")
(try 'string=? string=? "A" "B" "B")
(try 'string=? string=? "B" "B" "B")
(try 'string=? string=? "B" "B" "A")
(try 'string=? string=? "C" "B" "A")
(try 'string=? string=? "A" "B" 123)
)
(test-string=?)
(define (test-string<?)
(try 'string<? string<?)
(try 'string<? string<? "A")
(try 'string<? string<? 123)
(try 'string<? string<? "A" "A")
(try 'string<? string<? "A" "B")
(try 'string<? string<? "A" "A ")
(try 'string<? string<? "B" "A")
(try 'string<? string<? "A " "A")
(try 'string<? string<? "A" 123)
(try 'string<? string<? 123 "A")
(try 'string<? string<? "A" 123)
(try 'string<? string<? "A" "B" "C")
(try 'string<? string<? "A" "B" "B")
(try 'string<? string<? "B" "B" "B")
(try 'string<? string<? "B" "B" "A")
(try 'string<? string<? "C" "B" "A")
(try 'string<? string<? "A" "B" 123)
)
(test-string<?)
(define (test-string>?)
(try 'string>? string>?)
(try 'string>? string>? "A")
(try 'string>? string>? 123)
(try 'string>? string>? "A" "A")
(try 'string>? string>? "A" "B")
(try 'string>? string>? "A" "A ")
(try 'string>? string>? "B" "A")
(try 'string>? string>? "A " "A")
(try 'string>? string>? "A" 123)
(try 'string>? string>? 123 "A")
(try 'string>? string>? "A" 123)
(try 'string>? string>? "A" "B" "C")
(try 'string>? string>? "A" "B" "B")
(try 'string>? string>? "B" "B" "B")
(try 'string>? string>? "B" "B" "A")
(try 'string>? string>? "C" "B" "A")
(try 'string>? string>? "A" "B" 123)
)
(test-string>?)
(define (test-string<=?)
(try 'string<=? string<=?)
(try 'string<=? string<=? "A")
(try 'string<=? string<=? 123)
(try 'string<=? string<=? "A" "A")
(try 'string<=? string<=? "A" "B")
(try 'string<=? string<=? "A" "A ")
(try 'string<=? string<=? "B" "A")
(try 'string<=? string<=? "A " "A")
(try 'string<=? string<=? "A" 123)
(try 'string<=? string<=? 123 "A")
(try 'string<=? string<=? "A" 123)
(try 'string<=? string<=? "A" "B" "C")
(try 'string<=? string<=? "A" "B" "B")
(try 'string<=? string<=? "B" "B" "B")
(try 'string<=? string<=? "B" "B" "A")
(try 'string<=? string<=? "C" "B" "A")
(try 'string<=? string<=? "A" "B" 123)
)
(test-string<=?)
(define (test-string>=?)
(try 'string>=? string>=?)
(try 'string>=? string>=? "A")
(try 'string>=? string>=? 123)
(try 'string>=? string>=? "A" "A")
(try 'string>=? string>=? "A" "B")
(try 'string>=? string>=? "A" "A ")
(try 'string>=? string>=? "B" "A")
(try 'string>=? string>=? "A " "A")
(try 'string>=? string>=? "A" 123)
(try 'string>=? string>=? 123 "A")
(try 'string>=? string>=? "A" 123)
(try 'string>=? string>=? "A" "B" "C")
(try 'string>=? string>=? "A" "B" "B")
(try 'string>=? string>=? "B" "B" "B")
(try 'string>=? string>=? "B" "B" "A")
(try 'string>=? string>=? "C" "B" "A")
(try 'string>=? string>=? "A" "B" 123)
)
(test-string>=?)
(define (test-string-ci=?)
(try 'string-ci=? string-ci=?)
(try 'string-ci=? string-ci=? "A")
(try 'string-ci=? string-ci=? 123)
(try 'string-ci=? string-ci=? "A" "a")
(try 'string-ci=? string-ci=? "A" "b")
(try 'string-ci=? string-ci=? "A" "a ")
(try 'string-ci=? string-ci=? "B" "a")
(try 'string-ci=? string-ci=? "A " "a")
(try 'string-ci=? string-ci=? "A" 123)
(try 'string-ci=? string-ci=? 123 "A")
(try 'string-ci=? string-ci=? "A" 123)
(try 'string-ci=? string-ci=? "A" "b" "C")
(try 'string-ci=? string-ci=? "A" "b" "B")
(try 'string-ci=? string-ci=? "B" "b" "B")
(try 'string-ci=? string-ci=? "B" "b" "A")
(try 'string-ci=? string-ci=? "C" "b" "A")
(try 'string-ci=? string-ci=? "A" "b" 123)
)
(test-string-ci=?)
(define (test-string-ci<?)
(try 'string-ci<? string-ci<?)
(try 'string-ci<? string-ci<? "A")
(try 'string-ci<? string-ci<? 123)
(try 'string-ci<? string-ci<? "A" "a")
(try 'string-ci<? string-ci<? "A" "b")
(try 'string-ci<? string-ci<? "A" "a ")
(try 'string-ci<? string-ci<? "B" "a")
(try 'string-ci<? string-ci<? "A " "a")
(try 'string-ci<? string-ci<? "A" 123)
(try 'string-ci<? string-ci<? 123 "A")
(try 'string-ci<? string-ci<? "A" 123)
(try 'string-ci<? string-ci<? "A" "b" "C")
(try 'string-ci<? string-ci<? "A" "b" "B")
(try 'string-ci<? string-ci<? "B" "b" "B")
(try 'string-ci<? string-ci<? "B" "b" "A")
(try 'string-ci<? string-ci<? "C" "b" "A")
(try 'string-ci<? string-ci<? "A" "b" 123)
)
(test-string-ci<?)
(define (test-string-ci>?)
(try 'string-ci>? string-ci>?)
(try 'string-ci>? string-ci>? "A")
(try 'string-ci>? string-ci>? 123)
(try 'string-ci>? string-ci>? "A" "a")
(try 'string-ci>? string-ci>? "A" "b")
(try 'string-ci>? string-ci>? "A" "a ")
(try 'string-ci>? string-ci>? "B" "a")
(try 'string-ci>? string-ci>? "A " "a")
(try 'string-ci>? string-ci>? "A" 123)
(try 'string-ci>? string-ci>? 123 "A")
(try 'string-ci>? string-ci>? "A" 123)
(try 'string-ci>? string-ci>? "A" "b" "C")
(try 'string-ci>? string-ci>? "A" "b" "B")
(try 'string-ci>? string-ci>? "B" "b" "B")
(try 'string-ci>? string-ci>? "B" "b" "A")
(try 'string-ci>? string-ci>? "C" "b" "A")
(try 'string-ci>? string-ci>? "A" "b" 123)
)
(test-string-ci>?)
(define (test-string-ci<=?)
(try 'string-ci<=? string-ci<=?)
(try 'string-ci<=? string-ci<=? "A")
(try 'string-ci<=? string-ci<=? 123)
(try 'string-ci<=? string-ci<=? "A" "a")
(try 'string-ci<=? string-ci<=? "A" "b")
(try 'string-ci<=? string-ci<=? "A" "a ")
(try 'string-ci<=? string-ci<=? "B" "a")
(try 'string-ci<=? string-ci<=? "A " "a")
(try 'string-ci<=? string-ci<=? "A" 123)
(try 'string-ci<=? string-ci<=? 123 "A")
(try 'string-ci<=? string-ci<=? "A" 123)
(try 'string-ci<=? string-ci<=? "A" "b" "C")
(try 'string-ci<=? string-ci<=? "A" "b" "B")
(try 'string-ci<=? string-ci<=? "B" "b" "B")
(try 'string-ci<=? string-ci<=? "B" "b" "A")
(try 'string-ci<=? string-ci<=? "C" "b" "A")
(try 'string-ci<=? string-ci<=? "A" "b" 123)
)
(test-string-ci<=?)
(define (test-string-ci>=?)
(try 'string-ci>=? string-ci>=?)
(try 'string-ci>=? string-ci>=? "A")
(try 'string-ci>=? string-ci>=? 123)
(try 'string-ci>=? string-ci>=? "A" "a")
(try 'string-ci>=? string-ci>=? "A" "b")
(try 'string-ci>=? string-ci>=? "A" "a ")
(try 'string-ci>=? string-ci>=? "B" "a")
(try 'string-ci>=? string-ci>=? "A " "a")
(try 'string-ci>=? string-ci>=? "A" 123)
(try 'string-ci>=? string-ci>=? 123 "A")
(try 'string-ci>=? string-ci>=? "A" 123)
(try 'string-ci>=? string-ci>=? "A" "b" "C")
(try 'string-ci>=? string-ci>=? "A" "b" "B")
(try 'string-ci>=? string-ci>=? "B" "b" "B")
(try 'string-ci>=? string-ci>=? "B" "b" "A")
(try 'string-ci>=? string-ci>=? "C" "b" "A")
(try 'string-ci>=? string-ci>=? "A" "b" 123)
)
(test-string-ci>=?)
(define (test-substring)
(try 'substring substring "abcdef" 0 2)
(try 'substring substring "abcdef" 2 2)
(try 'substring substring "abcdef" 2 5)
(try 'substring substring "abcdef" 2 6)
(try 'substring substring "abcdef" 2 7)
(try 'substring substring "abcdef" -1 5)
(try 'substring substring "abcdef" 2 1)
(try 'substring substring "abcdef" 2 12345678901234567890)
(try 'substring substring "abcdef" 12345678901234567890 2)
(try 'substring substring "abcdef" #\a 5)
(try 'substring substring "abcdef" 2 #\a)
(try 'substring substring 12345678901234567890 0 2)
)
(test-substring)
(define (test-string-append)
(try 'string-append string-append)
(try 'string-append string-append "ab")
(try 'string-append string-append 12345678901234567890)
(try 'string-append string-append "ab" "cd")
(try 'string-append string-append "ab" 12345678901234567890)
(try 'string-append string-append 12345678901234567890 "cd")
(try 'string-append string-append "ab" "cd" "ef")
(try 'string-append string-append "ab" "cd" 12345678901234567890)
)
(test-string-append)
(define (test-string->list)
(try 'string->list string->list "56")
(try 'string->list string->list 12345678901234567890)
)
(test-string->list)
(define (test-list->string)
(try 'list->string list->string '(#\5 #\6))
(try 'list->string list->string '(#\5 b))
(try 'list->string list->string 12345678901234567890)
)
(test-list->string)
(define (test-string-copy)
(try 'string-copy string-copy "ab")
(try 'string-copy string-copy 12345678901234567890)
)
(test-string-copy)
(define (test-string-fill!)
(let ((x (string #\5 #\6))) (try* x 'string-fill! string-fill! x #\a))
(let ((x (string #\5 #\6))) (try* x 'string-fill! string-fill! x 'a))
(try 'string-fill! string-fill! 12345678901234567890 #\a)
)
(test-string-fill!)
(define (test-vector?) ; no error possible
(vector? '#(5 6 7 8))
(vector? 12345678901234567890)
)
(test-vector?)
(define (test-make-vector)
(try 'make-vector make-vector 0)
(try 'make-vector make-vector 3)
(try 'make-vector make-vector 536870911)
(try 'make-vector make-vector 12345678901234567890)
(try 'make-vector make-vector -1)
(try 'make-vector make-vector 1.5)
(try 'make-vector make-vector 5 'a)
)
(test-make-vector)
(define (test-vector)
(try 'vector vector)
(try 'vector vector 5)
(try 'vector vector 5 'b)
(try 'vector vector 5 'b 7)
)
(test-vector)
(define (test-vector-length)
(try 'vector-length vector-length '#(5 6 7 8))
(try 'vector-length vector-length 12345678901234567890)
)
(test-vector-length)
(define (test-vector-ref)
(try 'vector-ref vector-ref '#(5 6 7 8) 3)
(try 'vector-ref vector-ref '#(5 6) -1)
(try 'vector-ref vector-ref '#(5 6) 2)
(try 'vector-ref vector-ref '#(5 6) 12345678901234567890)
(try 'vector-ref vector-ref 12345678901234567890 0)
)
(test-vector-ref)
(define (test-vector-set!)
(let ((x (vector 5 6))) (try* x 'vector-set! vector-set! x 1 3))
(let ((x (vector 5 6))) (try* x 'vector-set! vector-set! x -1 3))
(let ((x (vector 5 6))) (try* x 'vector-set! vector-set! x 2 3))
(let ((x (vector 5 6))) (try* x 'vector-set! vector-set! x 12345678901234567890 3))
(let ((x (vector 5 6))) (try* x 'vector-set! vector-set! x 1 'a))
(try 'vector-set! vector-set! 12345678901234567890 0 3)
)
(test-vector-set!)
(define (test-vector->list)
(try 'vector->list vector->list '#(5 6))
(try 'vector->list vector->list 12345678901234567890)
)
(test-vector->list)
(define (test-list->vector)
(try 'list->vector list->vector '(5 b))
(try 'list->vector list->vector 12345678901234567890)
)
(test-list->vector)
(define (test-vector-fill!)
(let ((x (vector 5 6))) (try* x 'vector-fill! vector-fill! x 'a))
(try 'vector-fill! vector-fill! 12345678901234567890 'a)
)
(test-vector-fill!)
(define (test-procedure?) ; no error possible
(try 'procedure? procedure? append)
(try 'procedure? procedure? '())
(try 'procedure? procedure? "foo")
(try 'procedure? procedure? #f)
)
(test-procedure?)
(define (test-apply)
(try 'apply apply + '())
(try 'apply apply + '(2 3))
(try 'apply apply + 2 '(3))
(try 'apply apply + 2 3 '())
(try 'apply apply + '(2 . #f))
(try 'apply apply + #f)
(try 'apply apply #f '(2 3))
)
(test-apply)
(define (test-map)
(try 'map map sqrt '())
(try 'map map sqrt '(1 4 9))
(try 'map map sqrt #f)
(try 'map map sqrt '(1 . #f))
(try 'map map #f '(1 4 9))
(try 'map map + '() '())
(try 'map map + '(1 2 3) '(0 2 6))
(try 'map map + '(1 2 3) '(0 2))
(try 'map map + '(1 2) '(0 2 6))
(try 'map map + #f '())
(try 'map map + '() #f)
(try 'map map + '(1 . #f) '(0 . #f))
(try 'map map #f '(1 2 3) '(0 2 6))
(try 'map map + '() '() '())
(try 'map map + '(1 2 3) '(0 2 6) '(10 100 1000))
(try 'map map + '(1 2 3) '(0 2) '(10 100 1000))
(try 'map map + '(1 2) '(0 2 6) '(10 100 1000))
(try 'map map + #f '() '())
(try 'map map + '() #f '())
(try 'map map + '() '() #f)
(try 'map map + '(1 . #f) '(0 . #f) '(10 . #f))
(try 'map map #f '(1 2 3) '(0 2 6) '(10 100 1000))
)
(test-map)
(define (test-for-each)
(try 'for-each for-each sqrt '())
(try 'for-each for-each sqrt '(1 4 9))
(try 'for-each for-each sqrt #f)
(try 'for-each for-each sqrt '(1 . #f))
(try 'for-each for-each #f '(1 4 9))
(try 'for-each for-each + '() '())
(try 'for-each for-each + '(1 2 3) '(0 2 6))
(try 'for-each for-each + '(1 2 3) '(0 2))
(try 'for-each for-each + '(1 2) '(0 2 6))
(try 'for-each for-each + #f '())
(try 'for-each for-each + '() #f)
(try 'for-each for-each + '(1 . #f) '(0 . #f))
(try 'for-each for-each #f '(1 2 3) '(0 2 6))
(try 'for-each for-each + '() '() '())
(try 'for-each for-each + '(1 2 3) '(0 2 6) '(10 100 1000))
(try 'for-each for-each + '(1 2 3) '(0 2) '(10 100 1000))
(try 'for-each for-each + '(1 2 3) '(0 2) '(10 100 1000))
(try 'for-each for-each + '(1 2) '(0 2 6) '(10 100 1000))
(try 'for-each for-each + #f '() '())
(try 'for-each for-each + '() #f '())
(try 'for-each for-each + '() '() #f)
(try 'for-each for-each + '(1 . #f) '(0 . #f) '(10 . #f))
(try 'for-each for-each #f '(1 2 3) '(0 2 6) '(10 100 1000))
)
(test-for-each)
(define (test-force) ; no error possible
;(let ((x (delay (+ 2 3)))) (try 'force force x))
(try 'force force 123)
)
(test-force)
(define (test-call-with-current-continuation)
;(try 'call-with-current-continuation call-with-current-continuation list)
(try 'call-with-current-continuation call-with-current-continuation #f)
)
(test-call-with-current-continuation)
(define (test-call-with-input-file)
(try 'call-with-input-file call-with-input-file #f list)
(try 'call-with-input-file call-with-input-file "tmp" #f)
(try 'call-with-input-file call-with-input-file "notexist" list)
)
(test-call-with-input-file)
(define (test-call-with-output-file)
(try 'call-with-output-file call-with-output-file #f list)
(try 'call-with-output-file call-with-output-file "tmp" #f)
)
(test-call-with-output-file)
(define (test-input-port?)
(try 'input-port? input-port? (current-input-port))
(try 'input-port? input-port? (current-output-port))
(try 'input-port? input-port? #f)
)
(test-input-port?)
(define (test-output-port?)
(try 'output-port? output-port? (current-output-port))
(try 'output-port? output-port? (current-input-port))
(try 'output-port? output-port? #f)
)
(test-output-port?)
(define (test-current-input-port) ; no error possible
(try 'current-input-port current-input-port)
)
(test-current-input-port)
(define (test-current-output-port) ; no error possible
(try 'current-output-port current-output-port)
)
(test-current-output-port)
(define (test-with-input-from-file)
(try 'with-input-from-file with-input-from-file #f list)
(try 'with-input-from-file with-input-from-file "tmp" #f)
(try 'with-input-from-file with-input-from-file "noexist" list)
)
(test-with-input-from-file)
(define (test-with-output-to-file)
(try 'with-output-to-file with-output-to-file #f list)
(try 'with-output-to-file with-output-to-file "tmp" #f)
)
(test-with-output-to-file)
(define (test-open-input-file)
(try 'open-input-file open-input-file #f)
(try 'open-input-file open-input-file "noexist")
)
(test-open-input-file)
(define (test-open-output-file)
(try 'open-output-file open-output-file #f)
)
(test-open-output-file)
(define (test-close-input-port)
(try 'close-input-port close-input-port (current-output-port))
(try 'close-input-port close-input-port #f)
)
(test-close-input-port)
(define (test-close-output-port)
(try 'close-output-port close-output-port (current-input-port))
(try 'close-output-port close-output-port #f)
)
(test-close-output-port)
(define (test-read)
(try 'read read)
(try 'read read (current-output-port))
(try 'read read #f)
)
(test-read)
(define (test-read-char)
(try 'read-char read-char)
(try 'read-char read-char (current-output-port))
(try 'read-char read-char #f)
)
(test-read-char)
(define (test-peek-char)
(try 'peek-char peek-char)
(try 'peek-char peek-char (current-output-port))
(try 'peek-char peek-char #f)
)
(test-peek-char)
(define (test-eof-object?) ; no error possible
(try 'eof-object? eof-object? #f)
(try 'eof-object? eof-object? "abc")
)
(test-eof-object?)
(define (test-char-ready?)
(try 'char-ready? char-ready?)
(try 'char-ready? char-ready? (current-input-port))
(try 'char-ready? char-ready? (current-output-port))
(try 'char-ready? char-ready? #f)
)
(test-char-ready?)
(define (test-write)
(try 'write write "abc")
(try 'write write "abc" (current-output-port))
(try 'write write "abc" (current-input-port))
(try 'write write "abc" #f)
)
(test-write)
(define (test-display)
(try 'display display "abc")
(try 'display display "abc" (current-output-port))
(try 'display display "abc" (current-input-port))
(try 'display display "abc" #f)
)
(test-display)
(define (test-newline)
(try 'newline newline)
(try 'newline newline (current-output-port))
(try 'newline newline (current-input-port))
(try 'newline newline #f)
)
(test-newline)
(define (test-write-char)
(try 'write-char write-char #\A)
(try 'write-char write-char 123)
(try 'write-char write-char #\A (current-output-port))
(try 'write-char write-char 123 (current-output-port))
(try 'write-char write-char #\A (current-input-port))
(try 'write-char write-char #\A #f)
)
(test-write-char)
(define (test-load)
(try 'load load "noexist")
(try 'load load #f)
)
(test-load)
(define (test-transcript-on)
(try 'transcript-on transcript-on #f)
)
(test-transcript-on)
(define (test-transcript-off)
(try 'transcript-off transcript-off)
)
(test-transcript-off)
;------------------------------------------------------------------------------
(define (path-exp file dir)
(string-append dir "/" file))
(define (test-setenv)
(try 'setenv setenv "UNKNOWNVAR1")
(try 'setenv setenv "UNKNOWNVAR2" "NOW-DEFINED")
)
(test-setenv)
(define (test-getenv)
(try 'getenv getenv "UNKNOWNVAR1")
(try 'getenv getenv "UNKNOWNVAR2")
(try 'getenv getenv "UNKNOWNVAR1" 999)
(try 'getenv getenv "UNKNOWNVAR2" 999)
)
(test-getenv)
(define (test-command-line)
(define (cdr-command-line) (cdr (command-line)))
(try 'cdr-command-line cdr-command-line)
)
(test-command-line)
(define (test-shell-command)
(try 'shell-command shell-command "echo hello > newfile1")
;(try 'shell-command shell-command "notexist")
)
(test-shell-command)
(define (test-create-directory)
(try 'create-directory create-directory "newdir1")
(try 'create-directory create-directory "newdir1")
(try 'create-directory create-directory "newfile1")
)
(test-create-directory)
(define (test-rename-file)
(try 'rename-file rename-file "newdir1" "newdir2")
(try 'rename-file rename-file "newdir1" "newdir2")
(try 'rename-file rename-file "newfile1" (path-exp "aaa" "newdir2"))
(try 'rename-file rename-file "newfile1" (path-exp "aaa" "newdir2"))
)
(test-rename-file)
(define (test-copy-file)
(try 'copy-file copy-file "error.scm" (path-exp "bbb" "newdir2"))
(try 'copy-file copy-file "notexist" (path-exp "ccc" "newdir2"))
)
(test-copy-file)
(define (test-directory-files)
(define (sort-directory-files)
(sort-list (directory-files "newdir2") string<?))
(try 'sort-directory-files sort-directory-files)
)
(test-directory-files)
(define (test-file-exists?)
(try 'file-exists? file-exists? ".")
(try 'file-exists? file-exists? "error.scm")
(try 'file-exists? file-exists? "newdir2")
(try 'file-exists? file-exists? (path-exp "bbb" "newdir2"))
(try 'file-exists? file-exists? "notexist")
)
(test-file-exists?)
(define (test-file-type)
(try 'file-type file-type ".")
(try 'file-type file-type "error.scm")
(try 'file-type file-type "newdir2")
(try 'file-type file-type (path-exp "bbb" "newdir2"))
(try 'file-type file-type "notexist")
)
(test-file-type)
(define (test-file-size)
(try 'file-size file-size "error.scm")
(try 'file-size file-size (path-exp "bbb" "newdir2"))
(try 'file-size file-size "notexist")
)
(test-file-size)
(define (test-delete-file-and-directory)
(try 'delete-directory delete-directory "newdir2")
(try 'delete-file delete-file (path-exp "aaa" "newdir2"))
(try 'delete-file delete-file (path-exp "bbb" "newdir2"))
(try 'delete-file delete-file (path-exp "ccc" "newdir2"))
(try 'delete-directory delete-directory "newdir2")
)
(test-delete-file-and-directory)
(define (test-open-process)
(define (read-all-open-process)
(let ((p
(open-process (list path: "sort"
arguments: (list "input")
eol-encoding: 'cr-lf))))
(output-port-timeout-set! p 10)
(input-port-timeout-set! p 10)
(let ((x (read-all p)))
(close-port p)
x)))
(try 'open-process open-process
(list path: "sort"
arguments: (list "input")
eol-encoding: 'cr-lf))
(try 'read-all-open-process read-all-open-process)
)
(test-open-process)
(define (test-host-info)
(define (host-info-addresses-host-info hostname)
(host-info-addresses (host-info hostname)))
(try 'host-info host-info "notexist.iro.umontreal.ca")
(try 'host-info-addresses-host-info
host-info-addresses-host-info
"www.iro.umontreal.ca")
)
'(test-host-info)
(define (test-open-tcp-client)
(define (string?-read-line-open-tcp-client)
(let ((p
(open-tcp-client
(list server-address: "www.iro.umontreal.ca"
port-number: 80
eol-encoding: 'cr-lf))))
(output-port-timeout-set! p 10)
(input-port-timeout-set! p 10)
(display "GET /gambit-check\n\n" p)
(force-output p)
(let ((x (read-line p)))
(close-port p)
(string? x))))
'
(try 'open-tcp-client open-tcp-client
(list server-address: "www.iro.umontreal.ca"
port-number: 80
eol-encoding: 'cr-lf))
'
(try 'string?-read-line-open-tcp-client string?-read-line-open-tcp-client)
)
(test-open-tcp-client)
;------------------------------------------------------------------------------
(exit)
Jump to Line
Something went wrong with that request. Please try again.