;;;; optargs.test --- test suite for optional arg processing -*- scheme -*- ;;;; Matthias Koeppe --- June 2001 ;;;; ;;;; Copyright (C) 2001, 2006, 2009, 2010, 2013 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-optargs) #:use-module (test-suite lib) #:use-module (system base compile) #:use-module (ice-9 optargs)) (define exception:invalid-keyword '(keyword-argument-error . "Invalid keyword")) (define exception:unrecognized-keyword '(keyword-argument-error . "Unrecognized keyword")) (define exception:extraneous-arguments ;; Message depends on whether we use the interpreter or VM, and on the ;; evenness of the number of extra arguments (!). ;'(keyword-argument-error . ".*") '(#t . ".*")) (with-test-prefix/c&e "optional argument processing" (pass-if "local defines work with optional arguments" (eval '(begin (define* (test-1 #:optional (x 0)) (define d 1) ; local define #t) (false-if-exception (test-1))) (interaction-environment)))) ;;; ;;; let-keywords ;;; (with-test-prefix/c&e "let-keywords" ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', ;; which caused apparently internal defines to "leak" out into the ;; encompasing environment (pass-if-exception "empty bindings internal defines leaking out" exception:unbound-var (let ((rest '())) (let-keywords rest #f () (define localvar #f) #f) localvar)) (pass-if "one key" (let-keywords '(#:foo 123) #f (foo) (= foo 123)))) ;;; ;;; let-keywords* ;;; (with-test-prefix/c&e "let-keywords*" ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', ;; which caused apparently internal defines to "leak" out into the ;; encompasing environment (pass-if-exception "empty bindings internal defines leaking out" exception:unbound-var (let ((rest '())) (let-keywords* rest #f () (define localvar #f) #f) localvar)) (pass-if "one key" (let-keywords* '(#:foo 123) #f (foo) (= foo 123)))) ;;; ;;; let-optional ;;; (with-test-prefix/c&e "let-optional" ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', ;; which caused apparently internal defines to "leak" out into the ;; encompasing environment (pass-if-exception "empty bindings internal defines leaking out" exception:unbound-var (let ((rest '())) (let-optional rest () (define localvar #f) #f) localvar)) (pass-if "one var" (let ((rest '(123))) (let-optional rest ((foo 999)) (= foo 123))))) ;;; ;;; let-optional* ;;; (with-test-prefix/c&e "let-optional*" ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', ;; which caused apparently internal defines to "leak" out into the ;; encompasing environment (pass-if-exception "empty bindings internal defines leaking out" exception:unbound-var (let ((rest '())) (let-optional* rest () (define localvar #f) #f) localvar)) (pass-if "one var" (let ((rest '(123))) (let-optional* rest ((foo 999)) (= foo 123))))) (define* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r) (list a b c d e f g h i r)) ;; So we could use lots more tests here, but the fact that lambda* is in ;; the compiler, and the compiler compiles itself, using the evaluator ;; (when bootstrapping) and compiled code (when doing a partial rebuild) ;; makes me a bit complacent. (with-test-prefix/c&e "define*" (pass-if "the whole enchilada" (equal? (foo 1 2) '(1 2 #f 1 #f #f #f 1 () ()))) (pass-if-exception "extraneous arguments" exception:extraneous-arguments (let ((f (lambda* (#:key x) x))) (f 1 2 #:x 'x))) (pass-if-equal "unrecognized keyword" '(#:y) (catch 'keyword-argument-error (lambda () (let ((f (lambda* (#:key x) x))) (f #:y 'not-recognized))) (lambda (key proc fmt args data) data))) (pass-if-equal "invalid keyword" '(not-a-keyword) (catch 'keyword-argument-error (lambda () (let ((f (lambda* (#:key x) x))) (f 'not-a-keyword 'something))) (lambda (key proc fmt args data) data))) (pass-if "rest given before keywords" ;; Passing the rest argument before the keyword arguments should not ;; prevent keyword argument binding. (let ((f (lambda* (#:key x y z #:rest r) (list x y z r)))) (equal? (f 1 2 3 #:x 'x #:z 'z) '(x #f z (1 2 3 #:x x #:z z)))))) (with-test-prefix "scm_c_bind_keyword_arguments" (pass-if-equal "unrecognized keyword" '(#:y) (catch 'keyword-argument-error (lambda () (open-file "/dev/null" "r" #:y 'not-recognized)) (lambda (key proc fmt args data) data))) (pass-if-equal "invalid keyword" '(not-a-keyword) (catch 'keyword-argument-error (lambda () (open-file "/dev/null" "r" 'not-a-keyword 'something)) (lambda (key proc fmt args data) data)))) (with-test-prefix/c&e "lambda* inits" (pass-if "can bind lexicals within inits" (begin (define qux (lambda* (#:optional a #:key (b (or a 13) #:a)) b)) #t)) (pass-if "testing qux" (and (equal? (qux) 13) (equal? (qux 1) 1) (equal? (qux #:a 2) 2))) (pass-if "nested lambda* with optional" (begin (define (foo x) (define baz x) (define* (bar #:optional (y baz)) (or (zero? y) (bar (1- y)))) (bar)) (foo 10))) (pass-if "nested lambda* with key" (begin (define (foo x) (define baz x) (define* (bar #:key (y baz)) (or (zero? y) (bar #:y (1- y)))) (bar)) (foo 10)))) (with-test-prefix/c&e "defmacro*" (pass-if "definition" (begin (defmacro* transmogrify (a #:optional (b 10)) `(,a ,b)) #t)) (pass-if "explicit arg" (equal? (transmogrify quote 5) 5)) (pass-if "default arg" (equal? (transmogrify quote) 10))) (with-test-prefix/c&e "case-lambda" (pass-if-exception "no clauses, no args" exception:wrong-num-args ((case-lambda))) (pass-if-exception "no clauses, args" exception:wrong-num-args ((case-lambda) 1)) (pass-if "docstring" (equal? "docstring test" (procedure-documentation (case-lambda "docstring test" (() 0) ((x) 1)))))) (with-test-prefix/c&e "case-lambda*" (pass-if-exception "no clauses, no args" exception:wrong-num-args ((case-lambda*))) (pass-if-exception "no clauses, args" exception:wrong-num-args ((case-lambda*) 1)) (pass-if "docstring" (equal? "docstring test" (procedure-documentation (case-lambda* "docstring test" (() 0) ((x) 1))))) (pass-if "unambiguous" ((case-lambda* ((a b) #t) ((a) #f)) 1 2)) (pass-if "unambiguous (reversed)" ((case-lambda* ((a) #f) ((a b) #t)) 1 2)) (pass-if "optionals (order disambiguates)" ((case-lambda* ((a #:optional b) #t) ((a b) #f)) 1 2)) (pass-if "optionals (order disambiguates (2))" ((case-lambda* ((a b) #t) ((a #:optional b) #f)) 1 2)) (pass-if "optionals (one arg)" ((case-lambda* ((a b) #f) ((a #:optional b) #t)) 1)) (pass-if "optionals (one arg (2))" ((case-lambda* ((a #:optional b) #t) ((a b) #f)) 1)) (pass-if "keywords without keyword" ((case-lambda* ((a #:key c) #t) ((a b) #f)) 1)) (pass-if "keywords with keyword" ((case-lambda* ((a #:key c) #t) ((a b) #f)) 1 #:c 2)) (pass-if "keywords (too many positionals)" ((case-lambda* ((a #:key c) #f) ((a b) #t)) 1 2)) (pass-if "keywords (order disambiguates)" ((case-lambda* ((a #:key c) #t) ((a b c) #f)) 1 #:c 2)) (pass-if "keywords (order disambiguates (2))" ((case-lambda* ((a b c) #t) ((a #:key c) #f)) 1 #:c 2)))