summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el1
-rw-r--r--module/language/tree-il/analyze.scm28
-rw-r--r--module/language/tree-il/compile-bytecode.scm50
-rw-r--r--module/language/tree-il/compile-cps.scm26
-rw-r--r--module/language/tree-il/spec.scm2
-rw-r--r--module/system/base/compile.scm46
-rw-r--r--module/system/base/language.scm6
-rw-r--r--module/system/base/message.scm25
-rw-r--r--test-suite/tests/cross-compilation.test6
-rw-r--r--test-suite/tests/optargs.test424
-rw-r--r--test-suite/tests/tree-il.test8
11 files changed, 310 insertions, 312 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index d76101e98..22464d327 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -10,6 +10,7 @@
(eval . (put 'pass-if-exception 'scheme-indent-function 2))
(eval . (put 'pass-if-equal 'scheme-indent-function 2))
(eval . (put 'with-test-prefix 'scheme-indent-function 1))
+ (eval . (put 'with-test-prefix/c&e 'scheme-indent-function 1))
(eval . (put 'with-code-coverage 'scheme-indent-function 1))
(eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'let-gensyms 'scheme-indent-function 1))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index b4e1ad970..7b5612bcf 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008-2014,2016,2018-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008-2014,2016,2018-2020 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
@@ -37,7 +37,8 @@
unbound-variable-analysis
macro-use-before-definition-analysis
arity-analysis
- format-analysis))
+ format-analysis
+ make-analyzer))
;;;
;;; Tree analyses for warnings.
@@ -1086,3 +1087,26 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
#t)
#t))
+
+(define %warning-passes
+ `(#(unused-variable 3 ,unused-variable-analysis)
+ #(unused-toplevel 2 ,unused-toplevel-analysis)
+ #(shadowed-toplevel 2 ,shadowed-toplevel-analysis)
+ #(unbound-variable 1 ,unbound-variable-analysis)
+ #(macro-use-before-definition 1 ,macro-use-before-definition-analysis)
+ #(arity-mismatch 1 ,arity-analysis)
+ #(format 1 ,format-analysis)))
+
+(define (make-analyzer warning-level warnings)
+ (define (enabled-for-level? level)
+ (match warning-level
+ ((? boolean?) warning-level)
+ ((? exact-integer?) (>= warning-level level))))
+ (let ((analyses (filter-map (match-lambda
+ (#(kind level analysis)
+ (and (or (enabled-for-level? level)
+ (memq kind warnings))
+ analysis)))
+ %warning-passes)))
+ (lambda (exp env)
+ (analyze-tree analyses exp env))))
diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm
index ec3fba777..0656b462f 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -2,19 +2,18 @@
;; Copyright (C) 2020 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
+;;; 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 program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
@@ -42,7 +41,6 @@
#:use-module (ice-9 match)
#:use-module (language bytecode)
#:use-module (language tree-il)
- #:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
#:use-module ((srfi srfi-1) #:select (filter-map
fold
@@ -1316,35 +1314,13 @@ in the frame with for the lambda-case clause @var{clause}."
(emit-clause #f body module-scope free)
(emit-end-program asm))))
-(define %warning-passes
- `((unused-variable . ,unused-variable-analysis)
- (unused-toplevel . ,unused-toplevel-analysis)
- (shadowed-toplevel . ,shadowed-toplevel-analysis)
- (unbound-variable . ,unbound-variable-analysis)
- (macro-use-before-definition . ,macro-use-before-definition-analysis)
- (arity-mismatch . ,arity-analysis)
- (format . ,format-analysis)))
-
-(define (optimize-tree-il x e opts)
- (define warnings
- (or (and=> (memq #:warnings opts) cadr)
- '()))
-
- ;; Go through the warning passes.
- (let ((analyses (filter-map (lambda (kind)
- (assoc-ref %warning-passes kind))
- warnings)))
- (analyze-tree analyses x e))
-
- (optimize x e opts))
-
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define (compile-bytecode exp env opts)
- (let* ((exp (canonicalize (optimize-tree-il exp env opts)))
+ (let* ((exp (canonicalize (optimize exp env opts)))
(asm (make-assembler)))
(call-with-values (lambda () (split-closures exp))
(lambda (closures assigned)
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 5d3457e16..06ced5835 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -60,7 +60,6 @@
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language tree-il cps-primitives)
- #:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language cps intmap)
@@ -2324,28 +2323,6 @@ integer."
(define *comp-module* (make-fluid))
-(define %warning-passes
- `((unused-variable . ,unused-variable-analysis)
- (unused-toplevel . ,unused-toplevel-analysis)
- (shadowed-toplevel . ,shadowed-toplevel-analysis)
- (unbound-variable . ,unbound-variable-analysis)
- (macro-use-before-definition . ,macro-use-before-definition-analysis)
- (arity-mismatch . ,arity-analysis)
- (format . ,format-analysis)))
-
-(define (optimize-tree-il x e opts)
- (define warnings
- (or (and=> (memq #:warnings opts) cadr)
- '()))
-
- ;; Go through the warning passes.
- (let ((analyses (filter-map (lambda (kind)
- (assoc-ref %warning-passes kind))
- warnings)))
- (analyze-tree analyses x e))
-
- (optimize x e opts))
-
(define (canonicalize exp)
(define-syntax-rule (with-lexical src id . body)
(let ((k (lambda (id) . body)))
@@ -2560,8 +2537,7 @@ integer."
exp))
(define (compile-cps exp env opts)
- (values (cps-convert/thunk
- (canonicalize (optimize-tree-il exp env opts)))
+ (values (cps-convert/thunk (canonicalize (optimize exp env opts)))
env
env))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 10c20a010..c168c5c67 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -23,6 +23,7 @@
#:use-module (system base pmatch)
#:use-module (language tree-il)
#:use-module (language tree-il compile-cps)
+ #:use-module ((language tree-il analyze) #:select (make-analyzer))
#:export (tree-il))
(define (write-tree-il exp . port)
@@ -43,4 +44,5 @@
#:parser parse-tree-il
#:joiner join
#:compilers `((cps . ,compile-cps))
+ #:analyzer make-analyzer
#:for-humans? #f)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 4a94b5d5d..8ffbb294f 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -28,9 +28,22 @@
compile-and-load
read-and-compile
compile
- decompile))
+ decompile
+ default-warning-level
+ default-optimization-level))
+(define (level-validator x)
+ (match x
+ ((? boolean?) x)
+ ((and (? exact-integer?) (not (? negative?))) x)
+ (_ (error
+ "bad warning or optimization level: expected #f, #t, or integer >= 0"
+ x))))
+
+(define default-warning-level (make-parameter 1 level-validator))
+(define default-optimization-level (make-parameter 2 level-validator))
+
;;;
;;; Compiler
;;;
@@ -156,8 +169,8 @@
(from (current-language))
(to 'bytecode)
(env (default-environment from))
- (optimization-level #f)
- (warning-level #f)
+ (optimization-level (default-optimization-level))
+ (warning-level (default-warning-level))
(opts '())
(canonicalization 'relative))
(validate-options opts)
@@ -183,8 +196,10 @@
comp)))
(define* (compile-and-load file #:key (from (current-language)) (to 'value)
- (env (current-module)) (optimization-level #f)
- (warning-level #f) (opts '())
+ (env (current-module))
+ (optimization-level (default-optimization-level))
+ (warning-level (default-warning-level))
+ (opts '())
(canonicalization 'relative))
(validate-options opts)
(with-fluids ((%file-port-name-canonicalization canonicalization))
@@ -200,10 +215,19 @@
;;;
(define (compute-analyzer lang warning-level opts)
- (lambda (exp env) #t))
+ (match (language-analyzer lang)
+ (#f (lambda (exp env) (values)))
+ (proc (proc warning-level
+ (let lp ((opts opts))
+ (match opts
+ (() '())
+ ((#:warnings warnings . _) warnings)
+ ((_ _ . opts) (lp opts))))))))
(define (add-default-optimizations lang optimization-level opts)
- opts)
+ (match (language-optimizations-for-level lang)
+ (#f opts)
+ (get-opts (append opts (get-opts optimization-level)))))
(define (compute-compiler from to optimization-level warning-level opts)
(let lp ((order (or (lookup-compilation-order from to)
@@ -258,8 +282,8 @@
(from (current-language))
(to 'bytecode)
(env (default-environment from))
- (optimization-level #f)
- (warning-level #f)
+ (optimization-level (default-optimization-level))
+ (warning-level (default-warning-level))
(opts '()))
(let* ((from (ensure-language from))
(to (ensure-language to))
@@ -298,8 +322,8 @@
(from (current-language))
(to 'value)
(env (default-environment from))
- (optimization-level #f)
- (warning-level #f)
+ (optimization-level (default-optimization-level))
+ (warning-level (default-warning-level))
(opts '()))
(validate-options opts)
(let ((compile1 (compute-compiler from to optimization-level
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 51725c179..f73d7db03 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -27,6 +27,8 @@
language-compilers language-decompilers language-evaluator
language-joiner language-for-humans?
language-make-default-environment
+ language-optimizations-for-level
+ language-analyzer
lookup-compilation-order lookup-decompilation-order
default-environment)
@@ -49,7 +51,9 @@
(evaluator #f)
(joiner #f)
(for-humans? #t)
- (make-default-environment make-fresh-user-module))
+ (make-default-environment make-fresh-user-module)
+ (optimizations-for-level #f)
+ (analyzer #f))
(define-syntax-rule (define-language name . spec)
(define name (make-language #:name 'name . spec)))
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 8559a8568..21d06cc88 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -1,20 +1,19 @@
;;; User interface messages
-;; Copyright (C) 2009, 2010, 2011, 2012, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2012,2016,2018,2020 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 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.
+;;; 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
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
@@ -234,5 +233,3 @@ property alist) using the data in ARGS."
args)
(format port "~A: unknown warning type `~A': ~A~%"
(location-string location) type args))))
-
-;;; message.scm ends here
diff --git a/test-suite/tests/cross-compilation.test b/test-suite/tests/cross-compilation.test
index 175e6402b..120317b42 100644
--- a/test-suite/tests/cross-compilation.test
+++ b/test-suite/tests/cross-compilation.test
@@ -1,6 +1,6 @@
;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010-2014, 2020 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
@@ -56,7 +56,7 @@
(string=? (native-os) (target-os)))
(native-word-size)
word-size))
- (bv (compile '(hello-world) #:to 'bytecode)))
+ (bv (compile '(hello-world) #:warning-level 0 #:to 'bytecode)))
(and=> (parse-elf bv)
(lambda (elf)
(and (equal? (elf-byte-order elf) endian)
@@ -91,7 +91,7 @@
(pass-if-exception "unknown target" exception:miscellaneous-error
(with-target "fcpu-unknown-gnu1.0"
(lambda ()
- (compile '(ohai) #:to 'bytecode)))))
+ (compile '(ohai) #:warning-level 0 #:to 'bytecode)))))
;; Local Variables:
;; eval: (put 'with-target 'scheme-indent-function 1)
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 9590f414c..bd07fb3e4 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -47,87 +47,76 @@
;;; 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-syntax-rule (without-compiler-warnings exp ...)
+ (parameterize ((default-warning-level #f)) exp ...))
+
+(without-compiler-warnings
+ (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))))
+
+
+ (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))))
+
+ (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)))))
+
+ (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))
@@ -136,46 +125,47 @@
;; 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 "missing argument" '("Keyword argument has no value" #:x)
- (catch 'keyword-argument-error
- (lambda ()
- (let ((f (lambda* (#:key x) x)))
- (f #:x)))
- (lambda (key proc fmt args data)
- (cons fmt 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))))))
+(without-compiler-warnings
+ (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 "missing argument" '("Keyword argument has no value" #:x)
+ (catch 'keyword-argument-error
+ (lambda ()
+ (let ((f (lambda* (#:key x) x)))
+ (f #:x)))
+ (lambda (key proc fmt args data)
+ (cons fmt 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"
@@ -245,98 +235,100 @@
(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)))
+(without-compiler-warnings
+ (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)))))))
+
+(without-compiler-warnings
+ (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))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index e650a2f00..c326f6031 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -241,9 +241,11 @@
(define (call-with-warnings thunk)
(let ((port (open-output-string)))
- (with-fluids ((*current-warning-port* port)
- (*current-warning-prefix* ""))
- (thunk))
+ ;; Disable any warnings added by default.
+ (parameterize ((default-warning-level #f))
+ (with-fluids ((*current-warning-port* port)
+ (*current-warning-prefix* ""))
+ (thunk)))
(let ((warnings (get-output-string port)))
(string-tokenize warnings
(char-set-complement (char-set #\newline))))))