diff options
-rw-r--r-- | .dir-locals.el | 1 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 28 | ||||
-rw-r--r-- | module/language/tree-il/compile-bytecode.scm | 50 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 26 | ||||
-rw-r--r-- | module/language/tree-il/spec.scm | 2 | ||||
-rw-r--r-- | module/system/base/compile.scm | 46 | ||||
-rw-r--r-- | module/system/base/language.scm | 6 | ||||
-rw-r--r-- | module/system/base/message.scm | 25 | ||||
-rw-r--r-- | test-suite/tests/cross-compilation.test | 6 | ||||
-rw-r--r-- | test-suite/tests/optargs.test | 424 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 8 |
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)))))) |