Commit | Line | Data |
---|---|---|
a148c752 JOR |
1 | ;;;; session.test --- test suite for (ice-9 session) -*- scheme -*- |
2 | ;;;; Jose Antonio Ortega Ruiz <jao@gnu.org> -- August 2010 | |
3 | ;;;; | |
9f17d967 | 4 | ;;;; Copyright (C) 2010, 2012, 2013 Free Software Foundation, Inc. |
a148c752 JOR |
5 | ;;;; |
6 | ;;;; This library is free software; you can redistribute it and/or | |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
19 | ;;;; 02110-1301 USA | |
20 | ||
21 | (define-module (test-suite session) | |
22 | #:use-module (test-suite lib) | |
fc835b1b | 23 | #:use-module (ice-9 match) |
bfdbea1f | 24 | #:use-module (system base compile) |
a148c752 JOR |
25 | #:use-module (ice-9 session)) |
26 | ||
27 | (define (find-module mod) | |
28 | (call/cc (lambda (k) | |
29 | (apropos-fold-all (lambda (m _) | |
30 | (and (not (module? m)) (k #f)) | |
31 | (and (eq? m mod) (k #t))) | |
32 | #f)))) | |
33 | (define (find-mod-name mod-name) | |
34 | (find-module (resolve-module mod-name #f #:ensure #f))) | |
35 | ||
36 | ||
37 | (with-test-prefix "apropos-fold-all" | |
38 | (pass-if "a root module: ice-9" (find-mod-name '(ice-9))) | |
39 | (pass-if "a child of test-suite" (find-mod-name '(test-suite lib))) | |
40 | (pass-if "a non-module" (not (find-mod-name '(ice-999-0)))) | |
41 | (pass-if "a childish non-module" (not (find-mod-name '(ice-9 ice-999-0)))) | |
42 | (pass-if "an anonymous module" (find-mod-name (module-name (make-module))))) | |
43 | ||
44 | (define (find-interface mod-name) | |
45 | (let* ((mod (resolve-module mod-name #f #:ensure #f)) | |
46 | (ifc (and mod (module-public-interface mod)))) | |
47 | (and ifc | |
48 | (call/cc (lambda (k) | |
49 | (apropos-fold-exported (lambda (i _) | |
50 | (and (eq? i ifc) (k #t))) | |
51 | #f)))))) | |
52 | ||
53 | (with-test-prefix "apropos-fold-exported" | |
54 | (pass-if "a child of test-suite" (find-interface '(test-suite lib))) | |
55 | (pass-if "a child of ice-9" (find-interface '(ice-9 session)))) | |
bfdbea1f LC |
56 | |
57 | (with-test-prefix "procedure-arguments" | |
58 | ||
59 | (define-syntax-rule (pass-if-valid-arguments name proc expected) | |
60 | (pass-if name | |
61 | (let ((args (procedure-arguments (compile 'proc #:to 'value)))) | |
62 | (or (equal? args 'expected) | |
63 | (pk 'invalid-args args #f))))) | |
64 | ||
65 | (pass-if-valid-arguments "lambda" | |
66 | (lambda (a b c) #f) | |
67 | ((required . (a b c)) (optional) (keyword) | |
68 | (allow-other-keys? . #f) (rest . #f))) | |
69 | (pass-if-valid-arguments "lambda with rest" | |
70 | (lambda (a b . r) #f) | |
71 | ((required . (a b)) (optional) (keyword) | |
72 | (allow-other-keys? . #f) (rest . r))) | |
73 | (pass-if-valid-arguments "lambda* with optionals" | |
74 | (lambda* (a b #:optional (p 1) (q 2)) #f) | |
75 | ((required . (a b)) (optional . (p q)) | |
76 | (keyword) (allow-other-keys? . #f) (rest . #f))) | |
77 | (pass-if-valid-arguments "lambda* with keywords" | |
78 | (lambda* (a b #:key (k 42) l) #f) | |
79 | ((required . (a b)) (optional) | |
f41accb9 | 80 | (keyword . ((#:k . 3) (#:l . 4))) (allow-other-keys? . #f) |
bfdbea1f LC |
81 | (rest . #f))) |
82 | (pass-if-valid-arguments "lambda* with keywords and a-o-k" | |
83 | (lambda* (a b #:key (k 42) #:allow-other-keys) #f) | |
84 | ((required . (a b)) (optional) | |
f41accb9 | 85 | (keyword . ((#:k . 3))) (allow-other-keys? . #t) |
bfdbea1f LC |
86 | (rest . #f))) |
87 | (pass-if-valid-arguments "lambda* with optionals, keys, and rest" | |
88 | (lambda* (a b #:optional o p #:key k l #:rest r) #f) | |
89 | ((required . (a b)) (optional . (o p)) | |
f41accb9 | 90 | (keyword . ((#:k . 6) (#:l . 7))) (allow-other-keys? . #f) |
9f17d967 | 91 | (rest . r))) |
a8215aed LC |
92 | |
93 | (pass-if "aok? is preserved" | |
94 | ;; See <http://bugs.gnu.org/10938>. | |
95 | (let* ((proc (compile '(lambda (a b) #f) #:to 'value)) | |
96 | (args (procedure-arguments proc))) | |
97 | (set-procedure-property! proc 'arglist (map cdr args)) | |
fc835b1b AW |
98 | (equal? args (procedure-arguments proc)))) |
99 | ||
100 | (pass-if "interpreted procedures (simple)" | |
101 | (match (procedure-arguments | |
102 | (eval '(lambda (x y) #f) (current-module))) | |
103 | (((required _ _) | |
104 | (optional) | |
105 | (keyword) | |
106 | (allow-other-keys? . #f) | |
107 | (rest . #f)) | |
108 | #t) | |
109 | (_ #f))) | |
110 | ||
111 | (pass-if "interpreted procedures (complex)" | |
112 | (match (procedure-arguments | |
113 | (eval '(lambda* (a b #:optional c #:key d) #f) (current-module))) | |
114 | (((required _ _) | |
115 | (optional _) | |
116 | (keyword (#:d . 3)) | |
117 | (allow-other-keys? . #f) | |
118 | (rest . #f)) | |
119 | #t) | |
120 | (_ #f)))) | |
bfdbea1f LC |
121 | |
122 | ;;; Local Variables: | |
123 | ;;; eval: (put 'pass-if-valid-arguments 'scheme-indent-function 1) | |
124 | ;;; End: |