;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
-;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
+;;;; 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
#:use-module (system base compile)
#:use-module (ice-9 optargs))
+(define exception:invalid-keyword
+ '(keyword-argument-error . "Invalid keyword"))
+
(define exception:unrecognized-keyword
- ;; Can be `vm-error' or `misc-error' depending on whether we use the
- ;; interpreter or VM:
- ;; (vm-error vm-run "Bad keyword argument list: unrecognized keyword" ())
- ;; (misc-error #f "~A ~S" ("unrecognized keyword" (#:y 2)) #f)
- (cons #t ".*"))
+ '(keyword-argument-error . "Unrecognized keyword"))
(define exception:extraneous-arguments
- ;; Can be `vm-error' or `misc-error' depending on whether we use the
- ;; interpreter or VM, and depending on the evenness of the number of extra
- ;; arguments (!).
- (cons #t ".*"))
-
-
-(define-syntax c&e
- (syntax-rules (pass-if pass-if-exception)
- ((_ (pass-if test-name exp))
- (begin (pass-if (string-append test-name " (eval)")
- (primitive-eval 'exp))
- (pass-if (string-append test-name " (compile)")
- (compile 'exp #:to 'value #:env (current-module)))))
- ((_ (pass-if-exception test-name exc exp))
- (begin (pass-if-exception (string-append test-name " (eval)")
- exc (primitive-eval 'exp))
- (pass-if-exception (string-append test-name " (compile)")
- exc (compile 'exp #:to 'value
- #:env (current-module)))))))
-
-(define-syntax with-test-prefix/c&e
- (syntax-rules ()
- ((_ section-name exp ...)
- (with-test-prefix section-name (c&e exp) ...))))
+ ;; 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"
(let ((f (lambda* (#:key x) x)))
(f 1 2 #:x 'x)))
- (pass-if-exception "unrecognized keyword"
- exception:unrecognized-keyword
- (let ((f (lambda* (#:key x) x)))
- (f #:y 'not-recognized)))
+ (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
(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)))
HCoop / bpt / guile.git / blobdiff