dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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
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-exception 'scheme-indent-function 2))
(eval . (put 'pass-if-equal '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 '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-code-coverage 'scheme-indent-function 1))
(eval . (put 'with-statprof 'scheme-indent-function 1)) (eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'let-gensyms '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 ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -37,7 +37,8 @@
unbound-variable-analysis unbound-variable-analysis
macro-use-before-definition-analysis macro-use-before-definition-analysis
arity-analysis arity-analysis
format-analysis)) format-analysis
make-analyzer))
;;; ;;;
;;; Tree analyses for warnings. ;;; Tree analyses for warnings.
@ -1086,3 +1087,26 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
#t) #t)
#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. ;; Copyright (C) 2020 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify it
;;;; modify it under the terms of the GNU Lesser General Public ;;; under the terms of the GNU Lesser General Public License as published by
;;;; License as published by the Free Software Foundation; either ;;; the Free Software Foundation; either version 3 of the License, or (at
;;;; version 3 of the License, or (at your option) any later version. ;;; your option) any later version.
;;;; ;;;
;;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
;;;; Lesser General Public License for more details. ;;; General Public License for more details.
;;;; ;;;
;;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public License
;;;; License along with this library; if not, write to the Free Software ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -42,7 +41,6 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (language bytecode) #:use-module (language bytecode)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize) #:use-module (language tree-il optimize)
#:use-module ((srfi srfi-1) #:select (filter-map #:use-module ((srfi srfi-1) #:select (filter-map
fold fold
@ -1316,35 +1314,13 @@ in the frame with for the lambda-case clause @var{clause}."
(emit-clause #f body module-scope free) (emit-clause #f body module-scope free)
(emit-end-program asm)))) (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) (define (kw-arg-ref args kw default)
(match (memq kw args) (match (memq kw args)
((_ val . _) val) ((_ val . _) val)
(_ default))) (_ default)))
(define (compile-bytecode exp env opts) (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))) (asm (make-assembler)))
(call-with-values (lambda () (split-closures exp)) (call-with-values (lambda () (split-closures exp))
(lambda (closures assigned) (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 utils)
#:use-module (language cps with-cps) #:use-module (language cps with-cps)
#:use-module (language tree-il cps-primitives) #:use-module (language tree-il cps-primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize) #:use-module (language tree-il optimize)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language cps intmap) #:use-module (language cps intmap)
@ -2324,28 +2323,6 @@ integer."
(define *comp-module* (make-fluid)) (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 (canonicalize exp)
(define-syntax-rule (with-lexical src id . body) (define-syntax-rule (with-lexical src id . body)
(let ((k (lambda (id) . body))) (let ((k (lambda (id) . body)))
@ -2560,8 +2537,7 @@ integer."
exp)) exp))
(define (compile-cps exp env opts) (define (compile-cps exp env opts)
(values (cps-convert/thunk (values (cps-convert/thunk (canonicalize (optimize exp env opts)))
(canonicalize (optimize-tree-il exp env opts)))
env env
env)) env))

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

@ -23,6 +23,7 @@
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il compile-cps) #:use-module (language tree-il compile-cps)
#:use-module ((language tree-il analyze) #:select (make-analyzer))
#:export (tree-il)) #:export (tree-il))
(define (write-tree-il exp . port) (define (write-tree-il exp . port)
@ -43,4 +44,5 @@
#:parser parse-tree-il #:parser parse-tree-il
#:joiner join #:joiner join
#:compilers `((cps . ,compile-cps)) #:compilers `((cps . ,compile-cps))
#:analyzer make-analyzer
#:for-humans? #f) #:for-humans? #f)

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

@ -28,9 +28,22 @@
compile-and-load compile-and-load
read-and-compile read-and-compile
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 ;;; Compiler
;;; ;;;
@ -156,8 +169,8 @@
(from (current-language)) (from (current-language))
(to 'bytecode) (to 'bytecode)
(env (default-environment from)) (env (default-environment from))
(optimization-level #f) (optimization-level (default-optimization-level))
(warning-level #f) (warning-level (default-warning-level))
(opts '()) (opts '())
(canonicalization 'relative)) (canonicalization 'relative))
(validate-options opts) (validate-options opts)
@ -183,8 +196,10 @@
comp))) comp)))
(define* (compile-and-load file #:key (from (current-language)) (to 'value) (define* (compile-and-load file #:key (from (current-language)) (to 'value)
(env (current-module)) (optimization-level #f) (env (current-module))
(warning-level #f) (opts '()) (optimization-level (default-optimization-level))
(warning-level (default-warning-level))
(opts '())
(canonicalization 'relative)) (canonicalization 'relative))
(validate-options opts) (validate-options opts)
(with-fluids ((%file-port-name-canonicalization canonicalization)) (with-fluids ((%file-port-name-canonicalization canonicalization))
@ -200,10 +215,19 @@
;;; ;;;
(define (compute-analyzer lang warning-level opts) (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) (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) (define (compute-compiler from to optimization-level warning-level opts)
(let lp ((order (or (lookup-compilation-order from to) (let lp ((order (or (lookup-compilation-order from to)
@ -258,8 +282,8 @@
(from (current-language)) (from (current-language))
(to 'bytecode) (to 'bytecode)
(env (default-environment from)) (env (default-environment from))
(optimization-level #f) (optimization-level (default-optimization-level))
(warning-level #f) (warning-level (default-warning-level))
(opts '())) (opts '()))
(let* ((from (ensure-language from)) (let* ((from (ensure-language from))
(to (ensure-language to)) (to (ensure-language to))
@ -298,8 +322,8 @@
(from (current-language)) (from (current-language))
(to 'value) (to 'value)
(env (default-environment from)) (env (default-environment from))
(optimization-level #f) (optimization-level (default-optimization-level))
(warning-level #f) (warning-level (default-warning-level))
(opts '())) (opts '()))
(validate-options opts) (validate-options opts)
(let ((compile1 (compute-compiler from to optimization-level (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-compilers language-decompilers language-evaluator
language-joiner language-for-humans? language-joiner language-for-humans?
language-make-default-environment language-make-default-environment
language-optimizations-for-level
language-analyzer
lookup-compilation-order lookup-decompilation-order lookup-compilation-order lookup-decompilation-order
default-environment) default-environment)
@ -49,7 +51,9 @@
(evaluator #f) (evaluator #f)
(joiner #f) (joiner #f)
(for-humans? #t) (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-syntax-rule (define-language name . spec)
(define name (make-language #:name 'name . spec))) (define name (make-language #:name 'name . spec)))

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

@ -1,20 +1,19 @@
;;; User interface messages ;;; 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 ;;; This library is free software; you can redistribute it and/or modify it
;;; modify it under the terms of the GNU Lesser General Public ;;; under the terms of the GNU Lesser General Public License as published by
;;; License as published by the Free Software Foundation; either ;;; the Free Software Foundation; either version 3 of the License, or (at
;;; version 3 of the License, or (at your option) any later version. ;;; your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
;;; Lesser General Public License for more details. ;;; General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public License
;;; License along with this library; if not, write to the Free Software ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -234,5 +233,3 @@ property alist) using the data in ARGS."
args) args)
(format port "~A: unknown warning type `~A': ~A~%" (format port "~A: unknown warning type `~A': ~A~%"
(location-string location) type args)))) (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; -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -56,7 +56,7 @@
(string=? (native-os) (target-os))) (string=? (native-os) (target-os)))
(native-word-size) (native-word-size)
word-size)) word-size))
(bv (compile '(hello-world) #:to 'bytecode))) (bv (compile '(hello-world) #:warning-level 0 #:to 'bytecode)))
(and=> (parse-elf bv) (and=> (parse-elf bv)
(lambda (elf) (lambda (elf)
(and (equal? (elf-byte-order elf) endian) (and (equal? (elf-byte-order elf) endian)
@ -91,7 +91,7 @@
(pass-if-exception "unknown target" exception:miscellaneous-error (pass-if-exception "unknown target" exception:miscellaneous-error
(with-target "fcpu-unknown-gnu1.0" (with-target "fcpu-unknown-gnu1.0"
(lambda () (lambda ()
(compile '(ohai) #:to 'bytecode))))) (compile '(ohai) #:warning-level 0 #:to 'bytecode)))))
;; Local Variables: ;; Local Variables:
;; eval: (put 'with-target 'scheme-indent-function 1) ;; eval: (put 'with-target 'scheme-indent-function 1)

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

@ -47,87 +47,76 @@
;;; let-keywords ;;; 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', (without-compiler-warnings
;; which caused apparently internal defines to "leak" out into the (with-test-prefix/c&e "let-keywords"
;; encompasing environment ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
(pass-if-exception "empty bindings internal defines leaking out" ;; which caused apparently internal defines to "leak" out into the
exception:unbound-var ;; encompasing environment
(let ((rest '())) (pass-if-exception "empty bindings internal defines leaking out"
(let-keywords rest #f () exception:unbound-var
(define localvar #f) (let ((rest '()))
#f) (let-keywords rest #f ()
localvar)) (define localvar #f)
#f)
localvar))
(pass-if "one key" (pass-if "one key"
(let-keywords '(#:foo 123) #f (foo) (let-keywords '(#:foo 123) #f (foo)
(= foo 123)))) (= 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', (pass-if "one key"
;; which caused apparently internal defines to "leak" out into the (let-keywords* '(#:foo 123) #f (foo)
;; encompasing environment (= foo 123))))
(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" (with-test-prefix/c&e "let-optional"
(let-keywords* '(#:foo 123) #f (foo) ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
(= foo 123)))) ;; 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-optional (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', (pass-if "one var"
;; which caused apparently internal defines to "leak" out into the (let ((rest '(123)))
;; encompasing environment (let-optional* rest ((foo 999))
(pass-if-exception "empty bindings internal defines leaking out" (= foo 123))))))
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* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r) (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)) (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 ;; the compiler, and the compiler compiles itself, using the evaluator
;; (when bootstrapping) and compiled code (when doing a partial rebuild) ;; (when bootstrapping) and compiled code (when doing a partial rebuild)
;; makes me a bit complacent. ;; makes me a bit complacent.
(with-test-prefix/c&e "define*" (without-compiler-warnings
(pass-if "the whole enchilada" (with-test-prefix/c&e "define*"
(equal? (foo 1 2) (pass-if "the whole enchilada"
'(1 2 #f 1 #f #f #f 1 () ()))) (equal? (foo 1 2)
'(1 2 #f 1 #f #f #f 1 () ())))
(pass-if-exception "extraneous arguments" (pass-if-exception "extraneous arguments"
exception:extraneous-arguments exception:extraneous-arguments
(let ((f (lambda* (#:key x) x))) (let ((f (lambda* (#:key x) x)))
(f 1 2 #:x 'x))) (f 1 2 #:x 'x)))
(pass-if-equal "unrecognized keyword" '(#:y) (pass-if-equal "unrecognized keyword" '(#:y)
(catch 'keyword-argument-error (catch 'keyword-argument-error
(lambda () (lambda ()
(let ((f (lambda* (#:key x) x))) (let ((f (lambda* (#:key x) x)))
(f #:y 'not-recognized))) (f #:y 'not-recognized)))
(lambda (key proc fmt args data) (lambda (key proc fmt args data)
data))) data)))
(pass-if-equal "missing argument" '("Keyword argument has no value" #:x) (pass-if-equal "missing argument" '("Keyword argument has no value" #:x)
(catch 'keyword-argument-error (catch 'keyword-argument-error
(lambda () (lambda ()
(let ((f (lambda* (#:key x) x))) (let ((f (lambda* (#:key x) x)))
(f #:x))) (f #:x)))
(lambda (key proc fmt args data) (lambda (key proc fmt args data)
(cons fmt data)))) (cons fmt data))))
(pass-if-equal "invalid keyword" '(not-a-keyword) (pass-if-equal "invalid keyword" '(not-a-keyword)
(catch 'keyword-argument-error (catch 'keyword-argument-error
(lambda () (lambda ()
(let ((f (lambda* (#:key x) x))) (let ((f (lambda* (#:key x) x)))
(f 'not-a-keyword 'something))) (f 'not-a-keyword 'something)))
(lambda (key proc fmt args data) (lambda (key proc fmt args data)
data))) data)))
(pass-if "rest given before keywords" (pass-if "rest given before keywords"
;; Passing the rest argument before the keyword arguments should not ;; Passing the rest argument before the keyword arguments should not
;; prevent keyword argument binding. ;; prevent keyword argument binding.
(let ((f (lambda* (#:key x y z #:rest r) (list x y z r)))) (let ((f (lambda* (#:key x y z #:rest r) (list x y z r))))
(equal? (f 1 2 3 #:x 'x #:z 'z) (equal? (f 1 2 3 #:x 'x #:z 'z)
'(x #f z (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" (with-test-prefix "scm_c_bind_keyword_arguments"
@ -245,98 +235,100 @@
(equal? (transmogrify quote) (equal? (transmogrify quote)
10))) 10)))
(with-test-prefix/c&e "case-lambda" (without-compiler-warnings
(pass-if-exception "no clauses, no args" exception:wrong-num-args (with-test-prefix/c&e "case-lambda"
((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 (pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda) 1)) ((case-lambda) 1))
(pass-if "docstring" (pass-if "docstring"
(equal? "docstring test" (equal? "docstring test"
(procedure-documentation (procedure-documentation
(case-lambda (case-lambda
"docstring test" "docstring test"
(() 0) (() 0)
((x) 1)))))) ((x) 1)))))))
(with-test-prefix/c&e "case-lambda*" (without-compiler-warnings
(pass-if-exception "no clauses, no args" exception:wrong-num-args (with-test-prefix/c&e "case-lambda*"
((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 (pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda*) 1)) ((case-lambda*) 1))
(pass-if "docstring" (pass-if "docstring"
(equal? "docstring test" (equal? "docstring test"
(procedure-documentation (procedure-documentation
(case-lambda* (case-lambda*
"docstring test" "docstring test"
(() 0) (() 0)
((x) 1))))) ((x) 1)))))
(pass-if "unambiguous" (pass-if "unambiguous"
((case-lambda* ((case-lambda*
((a b) #t) ((a b) #t)
((a) #f)) ((a) #f))
1 2)) 1 2))
(pass-if "unambiguous (reversed)" (pass-if "unambiguous (reversed)"
((case-lambda* ((case-lambda*
((a) #f) ((a) #f)
((a b) #t)) ((a b) #t))
1 2)) 1 2))
(pass-if "optionals (order disambiguates)" (pass-if "optionals (order disambiguates)"
((case-lambda* ((case-lambda*
((a #:optional b) #t) ((a #:optional b) #t)
((a b) #f)) ((a b) #f))
1 2)) 1 2))
(pass-if "optionals (order disambiguates (2))" (pass-if "optionals (order disambiguates (2))"
((case-lambda* ((case-lambda*
((a b) #t) ((a b) #t)
((a #:optional b) #f)) ((a #:optional b) #f))
1 2)) 1 2))
(pass-if "optionals (one arg)" (pass-if "optionals (one arg)"
((case-lambda* ((case-lambda*
((a b) #f) ((a b) #f)
((a #:optional b) #t)) ((a #:optional b) #t))
1)) 1))
(pass-if "optionals (one arg (2))" (pass-if "optionals (one arg (2))"
((case-lambda* ((case-lambda*
((a #:optional b) #t) ((a #:optional b) #t)
((a b) #f)) ((a b) #f))
1)) 1))
(pass-if "keywords without keyword" (pass-if "keywords without keyword"
((case-lambda* ((case-lambda*
((a #:key c) #t) ((a #:key c) #t)
((a b) #f)) ((a b) #f))
1)) 1))
(pass-if "keywords with keyword" (pass-if "keywords with keyword"
((case-lambda* ((case-lambda*
((a #:key c) #t) ((a #:key c) #t)
((a b) #f)) ((a b) #f))
1 #:c 2)) 1 #:c 2))
(pass-if "keywords (too many positionals)" (pass-if "keywords (too many positionals)"
((case-lambda* ((case-lambda*
((a #:key c) #f) ((a #:key c) #f)
((a b) #t)) ((a b) #t))
1 2)) 1 2))
(pass-if "keywords (order disambiguates)" (pass-if "keywords (order disambiguates)"
((case-lambda* ((case-lambda*
((a #:key c) #t) ((a #:key c) #t)
((a b c) #f)) ((a b c) #f))
1 #:c 2)) 1 #:c 2))
(pass-if "keywords (order disambiguates (2))" (pass-if "keywords (order disambiguates (2))"
((case-lambda* ((case-lambda*
((a b c) #t) ((a b c) #t)
((a #:key c) #f)) ((a #:key c) #f))
1 #:c 2))) 1 #:c 2))))

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

@ -241,9 +241,11 @@
(define (call-with-warnings thunk) (define (call-with-warnings thunk)
(let ((port (open-output-string))) (let ((port (open-output-string)))
(with-fluids ((*current-warning-port* port) ;; Disable any warnings added by default.
(*current-warning-prefix* "")) (parameterize ((default-warning-level #f))
(thunk)) (with-fluids ((*current-warning-port* port)
(*current-warning-prefix* ""))
(thunk)))
(let ((warnings (get-output-string port))) (let ((warnings (get-output-string port)))
(string-tokenize warnings (string-tokenize warnings
(char-set-complement (char-set #\newline)))))) (char-set-complement (char-set #\newline))))))