scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

most changes are cosmetical 

there are few new tests
This commit is contained in:
chetz 2004-10-03 11:35:21 +00:00
parent da3caf4f5b
commit fc88c1907a
7 changed files with 565 additions and 519 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

640
scsh/test/awk-test.scm
View File

@ -26,45 +26,45 @@
;; --- is the <counter> incremented correct --- ;; --- is the <counter> incremented correct ---
(add-test! 'counter-inc-test 'awk (add-test! 'counter-inc-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(string (let loop ((i 0)) (string (let loop ((i 0))
(if (not (= 9 i)) (if (not (= 9 i))
(begin (begin
(string-append "test-zeile\n" (string-append "test-zeile\n"
(loop (+ i 1)))) (loop (+ i 1))))
"")))) ""))))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(#t (set! read (cons counter read))))) (#t (set! read (cons counter read)))))
(make-string-input-port string)) (make-string-input-port string))
(equal? read '(9 8 7 6 5 4 3 2 1))))) (equal? read '(9 8 7 6 5 4 3 2 1)))))
;; --- does the "int-test" work properly --- ;; --- does the "int-test" work properly ---
(add-test! 'int-test-test 'awk (add-test! 'int-test-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(string (let loop ((i 0)) (string (let loop ((i 0))
(if (not (= 9 i)) (if (not (= 9 i))
(begin (begin
(string-append "test-zeile\n" (string-append "test-zeile\n"
(loop (+ i 1)))) (loop (+ i 1))))
"")))) ""))))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(1 (set! read (cons 1 read))) (1 (set! read (cons 1 read)))
(2 (set! read (cons 2 read))) (2 (set! read (cons 2 read)))
(3 (set! read (cons 3 read))) (3 (set! read (cons 3 read)))
(4 (set! read (cons 4 read))) (4 (set! read (cons 4 read)))
(5 (set! read (cons 5 read))) (5 (set! read (cons 5 read)))
(6 (set! read (cons 6 read))) (6 (set! read (cons 6 read)))
(7 (set! read (cons 7 read))) (7 (set! read (cons 7 read)))
(8 (set! read (cons 8 read))) (8 (set! read (cons 8 read)))
(9 (set! read (cons 9 read))) (9 (set! read (cons 9 read)))
(0 (set! read (cons 0 read))))) (0 (set! read (cons 0 read)))))
(make-string-input-port string)) (make-string-input-port string))
(equal? read '(9 8 7 6 5 4 3 2 1))))) (equal? read '(9 8 7 6 5 4 3 2 1)))))
;; --- big line --- ;; --- big line ---
@ -88,346 +88,352 @@
;; --- special signs --- ;; --- special signs ---
(add-test! 'read-special-signs 'awk (add-test! 'read-special-signs 'awk
(lambda () (lambda ()
(let (( strange-sign-line (let (( strange-sign-line
(let loop ((i 0)) (let loop ((i 0))
(if (= i 256) (if (= i 256)
"" ""
(if (= i 10) ;; works with everything but line-feed (if (= i 10) ;; works with everything but line-feed
(loop (+ i 1)) (loop (+ i 1))
(string-append (ascii->string i) (string-append (ascii->string i)
(loop (+ i 1))))))) (loop (+ i 1)))))))
(read '())) (read '()))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) () (awk (read-line in-port) (line) ()
(#t (set! read line)))) (#t (set! read line))))
(make-string-input-port strange-sign-line)) (make-string-input-port strange-sign-line))
(equal? read strange-sign-line)))) (equal? read strange-sign-line))))
;; --- sre-expr-test --- ;; --- sre-expr-test ---
(add-test! 'sre-expr-test-test 'awk (add-test! 'sre-expr-test-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"sre-expr-test zu prüfen:\n" "sre-expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) () (awk (read-line in-port) (line) ()
(("sre" "zu") (set! read (cons 'sre-zu read))) (("sre" "zu") (set! read (cons 'sre-zu read)))
("eine" (set! read (cons 'eine read))) ("eine" (set! read (cons 'eine read)))
("EINE" (set! read (cons 'EINE read))) ("EINE" (set! read (cons 'EINE read)))
((* "3") (set! read (cons '*3 read))) ((* "3") (set! read (cons '*3 read)))
((? "s") (set! read (cons '?s read))) ((? "s") (set! read (cons '?s read)))
((+ "+") (set! read (cons '++ read))))) ((+ "+") (set! read (cons '++ read)))))
(make-string-input-port str)) (make-string-input-port str))
;; |z6 |z5 |z4 |z3 |z2 |z1 | ;; |z6 |z5 |z4
(equal? (list '++ '?s '*3 '?s '*3 'eine 'sre-zu '?s '*3 'eine 'sre-zu '?s '*3 'EINE '?s '*3 'sre-zu '?s '*3 'sre-zu) (equal? (list '++ '?s '*3 '?s '*3 'eine 'sre-zu '?s '*3 'eine 'sre-zu
read)))) ;; |z3 |z2 |z1 |
'?s '*3 'EINE '?s '*3 'sre-zu '?s '*3 'sre-zu)
read))))
;; --- when-test --- ;; --- when-test ---
(add-test! 'when-bool-exp-test-test 'awk (add-test! 'when-bool-exp-test-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"when-bool-expr-test zu prüfen:\n" "when-bool-expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
((when (= counter 1)) ((when (= counter 1))
(set! read (cons 'first-clause read))) (set! read (cons 'first-clause read)))
((when (equal? line ((when (equal? line
"when-bool-expr-test zu prüfen:")) "when-bool-expr-test zu prüfen:"))
(set! read (cons 'second-clause read))) (set! read (cons 'second-clause read)))
((when (> counter 2)) ((when (> counter 2))
(set! read (cons 'third-clause read))))) (set! read (cons 'third-clause read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'third-clause 'third-clause 'third-clause 'third-clause 'second-clause 'first-clause))))) (list 'third-clause 'third-clause 'third-clause
'third-clause 'second-clause 'first-clause)))))
;; --- expr-test-test --- ;; --- expr-test-test ---
(add-test! 'expr-test-test 'awk (add-test! 'expr-test-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
("paar" (set! read (cons 'first-clause read))) ("paar" (set! read (cons 'first-clause read)))
((equal? line ((equal? line
"expr-test zu prüfen:") "expr-test zu prüfen:")
(set! line (cons 'second-clause read))) (set! line (cons 'second-clause read)))
((> counter 5) ((> counter 5)
(set! read (cons 'third-clause read))) (set! read (cons 'third-clause read)))
((+ "3") ;; makes problems here, but was ok in sre-xpr-test ;;FIXXX it ((+ "3")
(set! read (cons 'fourth-clause read))))) ;; ^^^^^ makes problems here, but was ok in sre-expr-test ;;FIXXX it
(make-string-input-port str)) (set! read (cons 'fourth-clause read)))))
(equal? read (make-string-input-port str))
(list 'third-clause 'fourth-clause 'second-clause 'first-clause))))) (equal? read
(list 'third-clause 'fourth-clause 'second-clause 'first-clause)))))
;; --- several-bodys-in-clause-test --- ;; --- several-bodys-in-clause-test ---
;; XX to do: only for <test>s that were ok till now (int, when) ;; XX to do: only for <test>s that were ok till now (int, when)
(add-test! 'several-bodys-in-clause-test 'awk (add-test! 'several-bodys-in-clause-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(1 (set! read (cons 'clause-one-body-one read)) (1 (set! read (cons 'clause-one-body-one read))
(set! read (cons 'clause-one-body-two read)) (set! read (cons 'clause-one-body-two read))
(set! read (cons 'clause-one-body-three read))) (set! read (cons 'clause-one-body-three read)))
((when (equal? line ((when (equal? line
"eine zeile klein...")) "eine zeile klein..."))
(set! read (cons 'clause-two-body-one read)) (set! read (cons 'clause-two-body-one read))
(set! read (cons 'clause-two-body-two read)) (set! read (cons 'clause-two-body-two read))
(set! read (cons 'clause-two-body-three read))))) (set! read (cons 'clause-two-body-three read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'clause-two-body-three 'clause-two-body-two 'clause-two-body-one (list 'clause-two-body-three 'clause-two-body-two 'clause-two-body-one
'clause-one-body-three 'clause-one-body-two 'clause-one-body-one))))) 'clause-one-body-three 'clause-one-body-two 'clause-one-body-one)))))
;; --- range-wo-begin-wo-end-test --- ;; --- range-wo-begin-wo-end-test ---
;; XX to do: only ok <test>s ... s.u. ;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-wo-begin-wo-end-test 'awk (add-test! 'range-wo-begin-wo-end-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(range 1 3 (set! read (cons 'first-clause read))) (range 1 3 (set! read (cons 'first-clause read)))
(range (when (equal? line (range (when (equal? line
"EINE ZEILE GRO/3...")) "EINE ZEILE GRO/3..."))
(when (equal? line (when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}")) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read))) (set! read (cons 'second-clause read)))
(range (when (equal? line (range (when (equal? line
"expr-test zu prüfen:")) "expr-test zu prüfen:"))
4 4
(set! read (cons 'third-clause read))))) (set! read (cons 'third-clause read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'second-clause 'second-clause 'third-clause 'first-clause))))) (list 'second-clause 'second-clause 'third-clause 'first-clause)))))
;; --- range-w-begin-wo-end-test --- ;; --- range-w-begin-wo-end-test ---
;; XX to do: only ok <test>s ... s.u. ;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-w-begin-wo-end-test 'awk (add-test! 'range-w-begin-wo-end-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(:range 1 3 (set! read (cons 'first-clause read))) (:range 1 3 (set! read (cons 'first-clause read)))
(:range (when (equal? line (:range (when (equal? line
"EINE ZEILE GRO/3...")) "EINE ZEILE GRO/3..."))
(when (equal? line (when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}")) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read))) (set! read (cons 'second-clause read)))
(:range (when (equal? line (:range (when (equal? line
"expr-test zu prüfen:")) "expr-test zu prüfen:"))
4 4
(set! read (cons 'third-clause read))))) (set! read (cons 'third-clause read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'second-clause 'second-clause 'third-clause 'second-clause 'third-clause 'first-clause 'first-clause))))) (list 'second-clause 'second-clause 'third-clause 'second-clause
'third-clause 'first-clause 'first-clause)))))
;; --- range-wo-begin-w-end-test --- ;; --- range-wo-begin-w-end-test ---
;; XX to do: only ok <test>s ... s.u. ;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-wo-begin-w-end-test 'awk (add-test! 'range-wo-begin-w-end-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(range: 1 3 (set! read (cons 'first-clause read))) (range: 1 3 (set! read (cons 'first-clause read)))
(range: (when (equal? line (range: (when (equal? line
"EINE ZEILE GRO/3...")) "EINE ZEILE GRO/3..."))
(when (equal? line (when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}")) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read))) (set! read (cons 'second-clause read)))
(range: (when (equal? line (range: (when (equal? line
"expr-test zu prüfen:")) "expr-test zu prüfen:"))
4 4
(set! read (cons 'third-clause read))))) (set! read (cons 'third-clause read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'second-clause 'second-clause 'third-clause 'second-clause 'third-clause 'first-clause 'first-clause))))) (list 'second-clause 'second-clause 'third-clause 'second-clause
'third-clause 'first-clause 'first-clause)))))
;; --- range-w-begin-w-end-test --- ;; --- range-w-begin-w-end-test ---
;; XX to do: only ok <test>s ... s.u. ;; XX to do: only ok <test>s ... s.u.
(add-test! 'range-w-begin-w-end-test 'awk (add-test! 'range-w-begin-w-end-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(:range: 1 3 (set! read (cons 'first-clause read))) (:range: 1 3 (set! read (cons 'first-clause read)))
(:range: (when (equal? line (:range: (when (equal? line
"EINE ZEILE GRO/3...")) "EINE ZEILE GRO/3..."))
(when (equal? line (when (equal? line
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}")) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}"))
(set! read (cons 'second-clause read))) (set! read (cons 'second-clause read)))
(:range: (when (equal? line (:range: (when (equal? line
"expr-test zu prüfen:")) "expr-test zu prüfen:"))
4 4
(set! read (cons 'third-clause read))))) (set! read (cons 'third-clause read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'second-clause 'second-clause 'third-clause 'second-clause 'third-clause (list 'second-clause 'second-clause 'third-clause 'second-clause 'third-clause
'second-clause 'first-clause 'third-clause 'first-clause 'first-clause))))) 'second-clause 'first-clause 'third-clause 'first-clause 'first-clause)))))
;; --- else-test --- ;; --- else-test ---
(add-test! 'else-test 'awk (add-test! 'else-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) () (awk (read-line in-port) (line) ()
(1 (set! read (cons 'first-clause read))) (1 (set! read (cons 'first-clause read)))
(else (set! read (cons 'second-clause read))) (else (set! read (cons 'second-clause read)))
(4 (set! read (cons 'third-clause read))) (4 (set! read (cons 'third-clause read)))
(5 (set! read (cons 'fourth-clause read))) (5 (set! read (cons 'fourth-clause read)))
(else (set! read (cons 'fifth-clause read))))) (else (set! read (cons 'fifth-clause read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'fifth-clause 'second-clause 'fourth-clause 'second-clause 'third-clause (list 'fifth-clause 'second-clause 'fourth-clause 'second-clause 'third-clause
'second-clause 'fifth-clause 'second-clause 'fifth-clause 'second-clause 'second-clause 'fifth-clause 'second-clause 'fifth-clause 'second-clause
'fifth-clause 'first-clause))))) 'fifth-clause 'first-clause)))))
;; --- test=>expr-test --- ;; --- test=>expr-test ---
(add-test! 'test=>expr-test 'awk (add-test! 'test=>expr-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter () (awk (read-line in-port) (line) counter ()
(counter => (lambda (c) (counter => (lambda (c)
(set! read (cons c read)))) (set! read (cons c read))))
(#f => (lambda (c) (#f => (lambda (c)
(set! read (cons c read)))))) (set! read (cons c read))))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (list 6 5 4 3 2 1))))) (equal? read (list 6 5 4 3 2 1)))))
;; --- after-test --- ;; --- after-test ---
(add-test! 'after-test 'awk (add-test! 'after-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
(set! read (set! read
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) () (awk (read-line in-port) (line) ()
(1 (set! read 1)) (1 (set! read 1))
(2 (set! read 2)) (2 (set! read 2))
(after 'return))) (after 'return)))
(make-string-input-port str))) (make-string-input-port str)))
(equal? read 'return)))) (equal? read 'return))))
;; --- var-decl-test --- ;; --- var-decl-test ---
(add-test! 'var-decl-test 'awk (add-test! 'var-decl-test 'awk
(lambda () (lambda ()
(let ((read 0) (let ((read 0)
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk (read-line in-port) (line) counter ((i 0) (awk (read-line in-port) (line) counter ((i 0)
(x 2) (x 2)
(y 3)) (y 3))
(1 (values (+ x y) x y)) (1 (values (+ x y) x y))
(2 (values i (+ i y) y)) (2 (values i (+ i y) y))
(3 (values (* i 2) x y)) (3 (values (* i 2) x y))
(4 (values (- i y) x y)) (4 (values (- i y) x y))
(5 (values (* i x) x y)) (5 (values (* i x) x y))
(6 (set! read i) (6 (set! read i)
(values i x y)))) (values i x y))))
(make-string-input-port str)) (make-string-input-port str))
(= read 56)))) (= read 56))))
;; --- multiple-return-values-of-next-record-test --- ;; --- multiple-return-values-of-next-record-test ---
(add-test! 'multiple-return-values-of-next-record-test 'awk (add-test! 'multiple-return-values-of-next-record-test 'awk
(lambda () (lambda ()
(let ((read '()) (let ((read '())
(str (string-append "ein paar testzeilen, um\n" (str (string-append "ein paar testzeilen, um\n"
"expr-test zu prüfen:\n" "expr-test zu prüfen:\n"
"EINE ZEILE GRO/3...\n" "EINE ZEILE GRO/3...\n"
"eine zeile klein...\n" "eine zeile klein...\n"
"eine zeile mit zeichen...\n" "eine zeile mit zeichen...\n"
"*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n"))) "*+#'~,;:.-_<>|!§$%&/()=?\"\\[]{}\n")))
((lambda (in-port) ((lambda (in-port)
(awk ((lambda () (awk ((lambda ()
(values (read-line in-port)1 2 'a 'b))) (line x y a b) counter () (values (read-line in-port)1 2 'a 'b))) (line x y a b) counter ()
(1 (set! read (cons x read))) (1 (set! read (cons x read)))
(2 (set! read (cons y read))) (2 (set! read (cons y read)))
(3 (set! read (cons a read))) (3 (set! read (cons a read)))
(4 (set! read (cons b read))))) (4 (set! read (cons b read)))))
(make-string-input-port str)) (make-string-input-port str))
(equal? read (equal? read
(list 'b 'a 2 1))))) (list 'b 'a 2 1)))))

20
scsh/test/bug-report-tests.scm Normal file
View File

@ -0,0 +1,20 @@
;;; Test for the bug reports from user- and hacker-archives
;;; Author: Christoph Hetz
;; for testing: (certainly the path will be an other on other systems...)
;; ,open define-record-types handle
;; ,config ,load C:/cygwin/home/mephisto/cvs-scsh/scsh/scsh/test/test-packages.scm
;; ,load C:/cygwin/home/mephisto/cvs-scsh/scsh/scsh/test/test-base.scm
;; load this file
;; (test-all)
(add-test! '2002-05-86-regexp-weirdness 'archive-users
(lambda ()
(let ((x (rx "{ OK=#t }")))
(and (not (regexp-search? x "foo"))
(regexp-search? x "...{ OK=#t }...")))))
(add-test! '2003-12-74-select-ports-with-zero-timeout 'archive-users
(lambda ()
(select-ports 0 (current-input-port))))

294
scsh/test/file-name-manipulation-test.scm
View File

@ -14,188 +14,186 @@
;; *** tests *** ;; *** tests ***
(add-test! 'file-name-directory? 'file-name-manipulation (add-test! 'file-name-directory? 'file-name-manipulation
(lambda () (lambda ()
(and (not (file-name-directory? "src/des")) (and (not (file-name-directory? "src/des"))
(file-name-directory? "src/des/") (file-name-directory? "src/des/")
(file-name-directory? "/") (file-name-directory? "/")
(not (file-name-directory? ".")) (not (file-name-directory? "."))
(file-name-directory? "")))) (file-name-directory? ""))))
(add-test! 'file-name-non-directory? 'file-name-manipulation (add-test! 'file-name-non-directory? 'file-name-manipulation
(lambda () (lambda ()
(and (file-name-non-directory? "src/des") (and (file-name-non-directory? "src/des")
(not (file-name-non-directory? "src/des/")) (not (file-name-non-directory? "src/des/"))
(not (file-name-non-directory? "/")) (not (file-name-non-directory? "/"))
(file-name-non-directory? ".") (file-name-non-directory? ".")
(file-name-non-directory? "")))) (file-name-non-directory? ""))))
(add-test! 'file-name-as-directory 'file-name-manipulation (add-test! 'file-name-as-directory 'file-name-manipulation
(lambda () (lambda ()
(and (equal? "src/des/" (and (equal? "src/des/"
(file-name-as-directory "src/des")) (file-name-as-directory "src/des"))
(equal? "src/des/" (equal? "src/des/"
(file-name-as-directory "src/des/")) (file-name-as-directory "src/des/"))
(equal? "" (equal? ""
(file-name-as-directory ".")) (file-name-as-directory "."))
(equal? "/" (equal? "/"
(file-name-as-directory "/")) (file-name-as-directory "/"))
(equal? "/" (equal? "/"
(file-name-as-directory ""))))) (file-name-as-directory "")))))
(add-test! 'directory-as-file-name 'file-name-manipulation (add-test! 'directory-as-file-name 'file-name-manipulation
(lambda () (lambda ()
(and (equal? "foo/bar" (and (equal? "foo/bar"
(directory-as-file-name "foo/bar/")) (directory-as-file-name "foo/bar/"))
(equal? "foo/bar" (equal? "foo/bar"
(directory-as-file-name "foo/bar")) (directory-as-file-name "foo/bar"))
(equal? "/" (equal? "/"
(directory-as-file-name "/")) (directory-as-file-name "/"))
(equal? "." (equal? "."
(directory-as-file-name ""))))) (directory-as-file-name "")))))
(add-test! 'file-name-absolute? 'file-name-manipulation (add-test! 'file-name-absolute? 'file-name-manipulation
(lambda () (lambda ()
(and (file-name-absolute? "/usr/shievers") (and (file-name-absolute? "/usr/shievers")
(not (file-name-absolute? "src/des")) (not (file-name-absolute? "src/des"))
(file-name-absolute? "/src/des") (file-name-absolute? "/src/des")
(file-name-absolute? "")))) (file-name-absolute? ""))))
(add-test! 'file-name-directory 'file-name-manipuation (add-test! 'file-name-directory 'file-name-manipuation
(lambda () (lambda ()
(and (equal? "/usr/" (and (equal? "/usr/"
(file-name-directory "/usr/bcd")) (file-name-directory "/usr/bcd"))
(equal? "/usr/bcd/" (equal? "/usr/bcd/"
(file-name-directory "/usr/bcd/")) (file-name-directory "/usr/bcd/"))
(equal? "bdc/" (equal? "bdc/"
(file-name-directory "bdc/.login")) (file-name-directory "bdc/.login"))
(equal? "" (equal? ""
(file-name-directory "main.c")) (file-name-directory "main.c"))
(equal? "" (equal? ""
(file-name-directory "/")) (file-name-directory "/"))
(equal? "" (equal? ""
(file-name-directory ""))))) (file-name-directory "")))))
(add-test! 'file-name-nondirectory 'file-name-manipulation (add-test! 'file-name-nondirectory 'file-name-manipulation
(lambda () (lambda ()
(and (equal? "ian" (and (equal? "ian"
(file-name-nondirectory "/usr/ian")) (file-name-nondirectory "/usr/ian"))
(equal? "" (equal? ""
(file-name-nondirectory "/usr/ian/")) (file-name-nondirectory "/usr/ian/"))
(equal? ".login" (equal? ".login"
(file-name-nondirectory "ian/.login")) (file-name-nondirectory "ian/.login"))
(equal? "main.c" (equal? "main.c"
(file-name-nondirectory "main.c")) (file-name-nondirectory "main.c"))
(equal? "" (equal? ""
(file-name-nondirectory "")) (file-name-nondirectory ""))
(equal? "/" (equal? "/"
(file-name-nondirectory "/"))))) (file-name-nondirectory "/")))))
(add-test! 'split-file-name 'file-name-manipulation (add-test! 'split-file-name 'file-name-manipulation
(lambda () (lambda ()
(and (equal? '("src" "des" "main.c") (and (equal? '("src" "des" "main.c")
(split-file-name "src/des/main.c")) (split-file-name "src/des/main.c"))
(equal? '("" "src" "des" "main.c") (equal? '("" "src" "des" "main.c")
(split-file-name "/src/des/main.c")) (split-file-name "/src/des/main.c"))
(equal? '("main.c") (equal? '("main.c")
(split-file-name "main.c")) (split-file-name "main.c"))
(equal? '("") (equal? '("")
(split-file-name "/"))))) (split-file-name "/")))))
(add-test! 'path-list->file-name 'file-name-manipulation (add-test! 'path-list->file-name 'file-name-manipulation
(lambda () (lambda ()
(and (equal? "src/des/main.c" (and (equal? "src/des/main.c"
(path-list->file-name '("src" "des" "main.c"))) (path-list->file-name '("src" "des" "main.c")))
(equal? "/src/des/main.c" (equal? "/src/des/main.c"
(path-list->file-name '("" "src" "des" "main.c"))) (path-list->file-name '("" "src" "des" "main.c")))
(equal? "/usr/shivers/src/des/main.c" (equal? "/usr/shivers/src/des/main.c"
(path-list->file-name '("src" "des" "main.c") (path-list->file-name '("src" "des" "main.c")
"/usr/shivers"))))) "/usr/shivers")))))
(add-test! 'file-name-extension 'file-name-manipulation (add-test! 'file-name-extension 'file-name-manipulation
(lambda () (lambda ()
(and (equal? ".c" (and (equal? ".c"
(file-name-extension "main.c")) (file-name-extension "main.c"))
(equal? ".old" (equal? ".old"
(file-name-extension "main.c.old")) (file-name-extension "main.c.old"))
(equal? "" (equal? ""
(file-name-extension "/usr/shivers")) (file-name-extension "/usr/shivers"))
(equal? "." (equal? "."
(file-name-extension "foo.")) (file-name-extension "foo."))
(equal? "." (equal? "."
(file-name-extension "foo..")) (file-name-extension "foo.."))
(equal? "" (equal? ""
(file-name-extension "/usr/shivers/.login"))))) (file-name-extension "/usr/shivers/.login")))))
(add-test! 'file-name-sans-extension 'file-name-manipulation (add-test! 'file-name-sans-extension 'file-name-manipulation
(lambda () (lambda ()
(and (equal? "main" (and (equal? "main"
(file-name-sans-extension "main.c")) (file-name-sans-extension "main.c"))
(equal? "main.c" (equal? "main.c"
(file-name-sans-extension "main.c.old")) (file-name-sans-extension "main.c.old"))
(equal? "/usr/shivers" (equal? "/usr/shivers"
(file-name-sans-extension "/usr/shivers")) (file-name-sans-extension "/usr/shivers"))
(equal? "foo" (equal? "foo"
(file-name-sans-extension "foo.")) (file-name-sans-extension "foo."))
(equal? "foo." (equal? "foo."
(file-name-sans-extension "foo..")) (file-name-sans-extension "foo.."))
(equal? "/usr/shivers/.login" (equal? "/usr/shivers/.login"
(file-name-sans-extension "/usr/shivers/.login"))))) (file-name-sans-extension "/usr/shivers/.login")))))
(add-test! 'parse-file-name 'file-name-manipulation (add-test! 'parse-file-name 'file-name-manipulation
(lambda () (lambda ()
(let* ((fname "/usr/shivers/main.c") (let* ((fname "/usr/shivers/main.c")
(f (file-name-nondirectory fname))) (f (file-name-nondirectory fname)))
(equal? (list (file-name-directory fname) (equal? (list (file-name-directory fname)
(file-name-sans-extension f) (file-name-sans-extension f)
(file-name-extension f)) (file-name-extension f))
(call-with-values (call-with-values
(lambda () (lambda ()
(parse-file-name fname)) (parse-file-name fname))
(lambda (a b c) (lambda (a b c)
(list a b c))))))) (list a b c)))))))
(add-test! 'replace-extension 'file-name-manipulation (add-test! 'replace-extension 'file-name-manipulation
(lambda () (lambda ()
(let ((fname "/usr/shivers/main.c") (let ((fname "/usr/shivers/main.c")
(ext "old")) (ext "old"))
(equal? (string-append (file-name-sans-extension fname) ext) (equal? (string-append (file-name-sans-extension fname) ext)
(replace-extension fname ext))))) (replace-extension fname ext)))))
(add-test! 'simplify-file-name 'file-name-manipulation (add-test! 'simplify-file-name 'file-name-manipulation
(lambda () (lambda ()
(and (equal? "/usr/shivers" (and (equal? "/usr/shivers"
(simplify-file-name "/usr/shivers")) (simplify-file-name "/usr/shivers"))
(equal? "/usr/shivers" (equal? "/usr/shivers"
(simplify-file-name "////usr//shivers/")) (simplify-file-name "////usr//shivers/"))
(equal? "/usr/shivers/." (equal? "/usr/shivers/."
(simplify-file-name "////usr/shivers/.")) (simplify-file-name "////usr/shivers/."))
(equal? "//usr/shivers" (equal? "//usr/shivers"
(simplify-file-name "//usr/shivers/")) (simplify-file-name "//usr/shivers/"))
(equal? "/usr/shivers/../test" (equal? "/usr/shivers/../test"
(simplify-file-name "////usr/shivers/../test/"))))) (simplify-file-name "////usr/shivers/../test/")))))
;; XX todo:
(add-test! 'resolve-file-name 'file-name-manipulation (add-test! 'resolve-file-name 'file-name-manipulation
(lambda () (lambda ()
(and (equal? (resolve-file-name "~") (and (equal? (resolve-file-name "~")
(home-dir)) (home-dir))
(string? (resolve-file-name "~/c/main.c" "/usr/bin"))))) (string? (resolve-file-name "~/c/main.c" "/usr/bin")))))
(add-test! 'expand-file-name 'file-name-manipulation (add-test! 'expand-file-name 'file-name-manipulation
(lambda () (lambda ()
(equal? (expand-file-name "~/..///c/bin/main.out" "/usr/bin") (equal? (expand-file-name "~/..///c/bin/main.out" "/usr/bin")
(simplify-file-name (resolve-file-name "~/..///c/bin/main.out" "/usr/bin"))))) (simplify-file-name (resolve-file-name "~/..///c/bin/main.out" "/usr/bin")))))
(add-test! 'absolute-file-name 'file-name-manipulation (add-test! 'absolute-file-name 'file-name-manipulation
(lambda () (lambda ()
(equal? (absolute-file-name "~/c/bin/c.out" "/usr/local") (equal? (absolute-file-name "~/c/bin/c.out" "/usr/local")
"/usr/local/~/c/bin/c.out"))) "/usr/local/~/c/bin/c.out")))
;;(add-test! 'home-dir 'file-name-manipulation ;;(add-test! 'home-dir 'file-name-manipulation
;; was tested with resolve-file-name ;; was tested with resolve-file-name
(add-test! 'home-file 'file-name-manipulation (add-test! 'home-file 'file-name-manipulation
(lambda () (lambda ()
(equal? (home-file "man") (equal? (home-file "man")
(resolve-file-name "~/man")))) (resolve-file-name "~/man"))))

40
scsh/test/pattern-matching-test.scm
View File

@ -43,7 +43,8 @@
(string-append (list->string (list (ascii->char i))) (string-append (list->string (list (ascii->char i)))
(loop (+ i 1)))))) (loop (+ i 1))))))
(define test-string "Dieser Test-String wurde am 29.07.2004 um 5:23PM erstellt.\na aa aaa aaaa\nab aabb aaabbb\naba abba abbba\n1 12 123 1234\nyyyyyyyyyy\n") (define test-string
"Dieser Test-String wurde am 29.07.2004 um 5:23PM erstellt.\na aa aaa aaaa\nab aabb aaabbb\naba abba abbba\n1 12 123 1234\nyyyyyyyyyy\n")
;; *** tests *** ;; *** tests ***
@ -103,18 +104,31 @@
;XXX something is wrong with this ;XXX something is wrong with this
;(add-test! 're-vs-@re-submatch-test 'pattern-matching (add-test! 're-vs-@re-submatch-test 'pattern-matching
; (lambda () (lambda ()
; (let* ((f (lambda () (let* ((f (lambda ()
; (rx (submatch "sub-f1") (rx (submatch "sub-f1")
; (submatch "sub-f2")))) (submatch "sub-f2"))))
; (re (rx (submatch (* "foo")) (re (rx (submatch (* "foo"))
; (submatch (? "bar")) (submatch (? "bar"))
; ,(f) ,(f)
; (submatch "baz"))) (submatch "baz")))
; (match1 (string-match ,re "foofoobarsub-f1sub-f2baz")) (re-@ (rx (submatch (* "foo"))
; (match2 (string-match ,@re "foofoobarsub-f1sub-f2baz"))) (submatch (? "bar"))
; (and (...))))) ,@(f)
(submatch "baz")))
(match1 (string-match re "foofoobarsub-f1sub-f2baz"))
(match2 (string-match re-@ "foofoobarsub-f1sub-f2baz")))
(and match1
match2
(equal? "baz"
(match:substring match1 3))
(equal? "sub-f1"
(match:substring match2 3))
(equal? "sub-f2"
(match:substring match2 4))
(equal? "baz"
(match:substring match2 5))))))
(add-test! 'posix-string-test 'pattern-matching (add-test! 'posix-string-test 'pattern-matching
(lambda () (lambda ()

9
scsh/test/terminal-device-control-test.scm
View File

@ -265,4 +265,11 @@
ttyl/visual-delete-line ttyl/visual-delete-line
ttyl/alt-delete-word ttyl/alt-delete-word
ttyl/no-kernel-status ttyl/no-kernel-status
ttyl/case-map))))) ttyl/case-map)))))
(add-test! 'open-pty-test 'terminal-device-control
(lambda ()
(receive (pty-inport tty-name) (open-pty)
(and (tty? pty-inport)
(equal? tty-name (tty-file-name pty-inport))))))

37
scsh/test/time-procedure-calls.scm
View File

@ -12,35 +12,36 @@
;; *** tests *** ;; *** tests ***
(add-test! 'time-ticks 'time (add-test! 'time-ticks 'time
(lambda () (lambda ()
(call-with-values (call-with-values
(lambda () (lambda ()
(time+ticks)) (time+ticks))
(lambda (tme tcks) (lambda (tme tcks)
(and (number? tme) (and (number? tme)
(number? tcks)))))) (number? tcks))))))
(add-test! 'ticks/sec 'time (add-test! 'ticks/sec 'time
(lambda () (lambda ()
(real? (ticks/sec)))) (real? (ticks/sec))))
(add-test! 'date 'time (add-test! 'date 'time
(lambda () (lambda ()
(date? (date)))) (date? (date))))
(add-test! 'time 'time (add-test! 'time 'time
(lambda () (lambda ()
(integer? (time)))) (integer? (time))))
(add-test! 'date->string 'time (add-test! 'date->string 'time
(lambda () (lambda ()
(string? (date->string (date))))) (string? (date->string (date)))))
(add-test! 'format-date 'time (add-test! 'format-date 'time
(lambda () (lambda ()
(string? (format-date "~a ~A ~b ~B ~c ~d ~H ~I ~j ~m ~M ~p ~S ~U ~w ~W ~x ~X ~y ~Y ~Z" (date))))) (string? (format-date "~a ~A ~b ~B ~c ~d ~H ~I ~j ~m ~M ~p ~S ~U ~w ~W ~x ~X ~y ~Y ~Z"
(date)))))
;;; fill-in-date! seems to be not implemented yet. ;;; fill-in-date! is not implemented yet.
;(add-test! 'fill-in-date! 'time ;(add-test! 'fill-in-date! 'time
; (lambda () ; (lambda ()
; (date? (fill-in-date! (date))))) ; (date? (fill-in-date! (date)))))

44
scsh/test/user-and-group-db-access.scm
View File

@ -12,25 +12,25 @@
;; *** tests *** ;; *** tests ***
(add-test! 'user-info 'user-and-group-db-access (add-test! 'user-info 'user-and-group-db-access
(lambda () (lambda ()
(let* ((user-0 (user-info (getenv "USER"))) (let* ((user-0 (user-info (getenv "USER")))
(user-name (user-info:name user-0)) (user-name (user-info:name user-0))
(user-id (user-info:uid user-0)) (user-id (user-info:uid user-0))
(user-gid (user-info:gid user-0)) (user-gid (user-info:gid user-0))
(user-hdir (user-info:home-dir user-0)) (user-hdir (user-info:home-dir user-0))
(user-shell (user-info:shell user-0)) (user-shell (user-info:shell user-0))
(group-0 (group-info user-gid)) (group-0 (group-info user-gid))
(group-name (group-info:name group-0)) (group-name (group-info:name group-0))
(group-id (group-info:gid group-0)) (group-id (group-info:gid group-0))
(group-mem (group-info:members group-0))) (group-mem (group-info:members group-0)))
(and (string? user-name) (and (string? user-name)
(integer? user-id) (integer? user-id)
(integer? user-gid) (integer? user-gid)
(string? user-hdir) (string? user-hdir)
(string? user-shell) (string? user-shell)
(string? group-name) (string? group-name)
(integer? group-id) (integer? group-id)
(list? group-mem) (list? group-mem)
(equal? user-name (user-info:name (user-info user-id))) (equal? user-name (user-info:name (user-info user-id)))
(equal? (user-info (getenv "USER")) (user-info:name (user-info user-id))) (equal? (user-info (getenv "USER")) (user-info:name (user-info user-id)))
(equal? group-id (group-info:gid (group-info group-name))))))) (equal? group-id (group-info:gid (group-info group-name)))))))