[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 07/10: Add language-specific analysis pass to compiler i
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 07/10: Add language-specific analysis pass to compiler infrastructure |
|
Date: |
Fri, 8 May 2020 11:13:43 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 116f94d661b61e297b733363b49042c6c14169b4
Author: Andy Wingo <address@hidden>
AuthorDate: Fri May 8 14:48:47 2020 +0200
Add language-specific analysis pass to compiler infrastructure
* module/system/base/compile.scm (compute-analyzer): Compute analyzer to
run on expressions before the compiler runs.
(add-default-optimizations): Flesh out; still a stub.a
(read-and-compile, compile, compile-and-load, compile-file): Default
warning and optimization levels.
(default-warning-level): New parameter, defaulting to 1.
(default-optimization-level): New parameter, defaulting to 2.
Currently unused.
* module/system/base/language.scm (<language>): Add
optimizations-for-level and analyzer fields.
* module/language/tree-il/compile-bytecode.scm (compile-bytecode):
* module/language/tree-il/compile-cps.scm (optimize-tree-il): No need to
run warnings passes here; compilers infrastructure will run them.
* module/language/tree-il/spec.scm (tree-il): Define make-analyzer as
analyzer.
* module/language/tree-il/analyze.scm (make-analyzer): New exported
procedure.
(%warning-passes): New private variable.
* .dir-locals.el: Add with-test-prefix/c&e indent mode.
* test-suite/tests/cross-compilation.test:
* test-suite/tests/optargs.test:
* test-suite/tests/tree-il.test: Adjust to disable default warnings.
---
.dir-locals.el | 1 +
module/language/tree-il/analyze.scm | 28 +-
module/language/tree-il/compile-bytecode.scm | 50 +---
module/language/tree-il/compile-cps.scm | 26 +-
module/language/tree-il/spec.scm | 2 +
module/system/base/compile.scm | 46 ++-
module/system/base/language.scm | 6 +-
module/system/base/message.scm | 25 +-
test-suite/tests/cross-compilation.test | 6 +-
test-suite/tests/optargs.test | 424 +++++++++++++--------------
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 d76101e..22464d3 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 b4e1ad9..7b5612b 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 ec3fba7..0656b46 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 5d3457e..06ced58 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 10c20a0..c168c5c 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 4a94b5d..8ffbb29 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 51725c1..f73d7db 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 8559a85..21d06cc 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 175e640..120317b 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 9590f41..bd07fb3 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 e650a2f..c326f60 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))))))
- [Guile-commits] branch master updated (728de16 -> 4311dc9), Andy Wingo, 2020/05/08
- [Guile-commits] 06/10: Add #:optimization-level, #:warning-level compile keyword args, Andy Wingo, 2020/05/08
- [Guile-commits] 09/10: Warning and optimization levels always small integers, Andy Wingo, 2020/05/08
- [Guile-commits] 08/10: Wire up simplified warning levels in "guild compile", Andy Wingo, 2020/05/08
- [Guile-commits] 02/10: Remove compilation order cache, Andy Wingo, 2020/05/08
- [Guile-commits] 01/10: Update (system base compile) header, Andy Wingo, 2020/05/08
- [Guile-commits] 04/10: Use more `match' in (system base compile), Andy Wingo, 2020/05/08
- [Guile-commits] 05/10: Rework compile-fold, Andy Wingo, 2020/05/08
- [Guile-commits] 10/10: Define new "lowering" phase in compiler, Andy Wingo, 2020/05/08
- [Guile-commits] 07/10: Add language-specific analysis pass to compiler infrastructure,
Andy Wingo <=
- [Guile-commits] 03/10: Slight (system base compile) refactor, Andy Wingo, 2020/05/08