mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Add language-specific analysis pass to compiler infrastructure

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-05-08 14:48:47 +02:00
parent c8c19f2ef3
commit 116f94d661
11 changed files with 280 additions and 282 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -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))

28
module/language/tree-il/analyze.scm
View file

@ -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))))

50
module/language/tree-il/compile-bytecode.scm
View file

@ -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)

26
module/language/tree-il/compile-cps.scm
View file

@ -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))

2
module/language/tree-il/spec.scm
View file

@ -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)

46
module/system/base/compile.scm
View file

@ -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

6
module/system/base/language.scm
View file

@ -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)))

25
module/system/base/message.scm
View file

@ -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

6
test-suite/tests/cross-compilation.test
View file

@ -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)

364
test-suite/tests/optargs.test
View file

@ -47,87 +47,76 @@
;;; let-keywords
;;;
(with-test-prefix/c&e "let-keywords"
(define-syntax-rule (without-compiler-warnings exp ...)
(parameterize ((default-warning-level #f)) exp ...))
;; 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))
(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))))
(pass-if "one key"
(let-keywords '(#:foo 123) #f (foo)
(= foo 123))))
;;;
;;; let-keywords*
;;;
(with-test-prefix/c&e "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))
;; 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))))
(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))
;;;
;;; let-optional
;;;
(pass-if "one var"
(let ((rest '(123)))
(let-optional rest ((foo 999))
(= foo 123)))))
(with-test-prefix/c&e "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))
;; 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)))))
(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 () ())))
(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-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 "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 "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-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))))))
(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)))
(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-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 "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*)))
(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-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 "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"
((case-lambda*
((a b) #t)
((a) #f))
1 2))
(pass-if "unambiguous (reversed)"
((case-lambda*
((a) #f)
((a b) #t))
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)"
((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 (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)"
((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 "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 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 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 (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)"
((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)))
(pass-if "keywords (order disambiguates (2))"
((case-lambda*
((a b c) #t)
((a #:key c) #f))
1 #:c 2))))

8
test-suite/tests/tree-il.test
View file

@ -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))))))